;;; Hoot read-eval-print loop
;;; Copyright (C) 2026 David Thompson <dave@spritely.institute>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;;
;;; Extensible REPL with sub-REPL and meta-command support.  Can be
;;; used in the traditional CLI manner, or with a GUI, or headlessly
;;; through the procedural API.
;;;
;;; Code:

(library (hoot repl)
  (export &repl-quit-exception
          repl-quit-exception?
          repl-quit-exception-repl

          make-repl-language
          repl-language?
          repl-language-title
          repl-language-reader
          repl-language-evaluator

          make-repl-environment
          make-repl-debug-environment
          repl-environment?
          repl-environment-language
          repl-environment-module
          repl-environment-data
          repl-environment-welcome
          repl-environment-prompt

          make-meta-command
          meta-command?
          meta-command-name
          meta-command-aliases
          meta-command-usage
          meta-command-summary
          meta-command-documentation
          meta-command-reader
          meta-command-procedure
          define-meta-command

          meta-expression?
          meta-expression-command
          meta-expression-arguments

          make-repl-debug
          repl-debug?
          repl-debug-exception
          repl-debug-stack

          make-repl
          repl?
          repl-environment
          repl-stack
          repl-meta-commands
          repl-meta-command-ref
          repl-add-meta-command!
          repl-depth
          repl-push!
          repl-pop!
          repl-welcome
          repl-prompt
          repl-read
          repl-eval
          repl-meta-eval
          repl-eval-with-error-handling
          current-repl
          run-repl
          spawn-repl)
  (import (hoot apply)
          (hoot assoc)
          (hoot config)
          (hoot control)
          (hoot eq)
          (hoot error-handling)
          (hoot errors)
          (hoot eval)
          (hoot exceptions)
          (hoot hashtables)
          (hoot keywords)
          (hoot lists)
          (hoot match)
          (hoot modules)
          (hoot not)
          (hoot numbers)
          (hoot pairs)
          (hoot parameters)
          (hoot ports)
          (hoot procedures)
          (hoot read)
          (hoot records)
          (hoot strings)
          (hoot symbols)
          (hoot syntax)
          (hoot syntax-objects)
          (hoot user)
          (hoot values)
          (hoot write))

  (define-exception-type &repl-quit-exception &exception
    make-repl-quit-exception
    repl-quit-exception?
    (repl repl-quit-exception-repl))

  ;; Somewhat mimicks Guile's <language> type in lieu of having the
  ;; real language tower.
  (define-record-type <repl-language>
    (%make-repl-language title reader evaluator)
    repl-language?
    (title repl-language-title)          ; string
    (reader repl-language-reader)        ; procedure: port -> any
    (evaluator repl-language-evaluator)) ; procedure: exp module -> any

  (define-record-type <repl-debug>
    (make-repl-debug exception stack)
    repl-debug?
    (exception repl-debug-exception) ; exception
    (stack repl-debug-stack)) ; vector of stack frames

  (define-record-type <repl-environment>
    (%make-repl-environment language module data welcome prompt)
    repl-environment?
    (language repl-environment-language) ; <repl-language>
    (module repl-environment-module set-repl-environment-module!) ; runtime module
    (data repl-environment-data)   ; extra context, such as debug info
    (welcome repl-environment-welcome)  ; procedure: repl -> any
    (prompt repl-environment-prompt))   ; procedure: repl -> any

  (define-record-type <meta-command>
    (%make-meta-command name aliases group usage summary documentation
                        reader proc)
    meta-command?
    (name meta-command-name) ; symbol
    (aliases meta-command-aliases) ; list of symbol
    (group meta-command-group) ; symbol
    (usage meta-command-usage) ; string
    (summary meta-command-summary) ; string
    (documentation meta-command-documentation) ; string
    (reader meta-command-reader) ; procedure port -> any
    (proc meta-command-procedure)) ; procedure: repl arg ... -> any

  (define-record-type <meta-expression>
    (make-meta-expression command arguments)
    meta-expression?
    (command meta-expression-command) ; <meta-command>
    (arguments meta-expression-arguments)) ; list of any

  (define-record-type <repl>
    (%make-repl environment stack meta-commands)
    repl?
    (environment repl-environment set-repl-environment!) ; <repl-environment>
    (stack repl-stack set-repl-stack!)  ; list of <repl-environment>
    (meta-commands %repl-meta-commands)) ; hash table of symbol -> <meta-command>

  (define* (make-repl-language #:key title reader evaluator)
    "Return a new language named @var{title} that parses input text with
@var{reader} and evaluates expressions with @var{evaluator}.
@var{reader} is a procedure of one argument: an input port.
@var{evaluator} is a procedure of two arguments: an expression to
evaluate and a module in which to perform the evaluation."
    (%make-repl-language title reader evaluator))

  (define scheme
    (make-repl-language #:title "Scheme"
                        #:reader read
                        #:evaluator eval))

  (define* (make-meta-command #:key name (aliases '()) group
                              (usage "") (summary "") (documentation "")
                              reader proc)
    "Return a new REPL meta-command that can be invoked by @var{name} or
any of the names in the @var{aliases} list."
    (%make-meta-command name aliases group usage summary documentation
                        reader proc))

  (define (read-string-all port)
    (string-concatenate
     (let lp ()
       (match (read-string 1024 port)
         ((? eof-object?) '())
         (str (cons str (lp)))))))

  (define-syntax define-meta-command
    (lambda (stx)
      (define (make-reader args)
        (define nreq
          (let lp ((args args) (n 0))
            (syntax-case args ()
              (() n)
              (rest ; rest args
               (identifier? #'rest)
               n)
              ((kw . _) ; keyword/optional args
               (keyword? (syntax->datum #'kw))
               n)
              ((arg . args)
               (lp #'args (1+ n))))))
        #`(lambda (repl port)
            (define read
              (repl-language-reader
               (repl-environment-language
                (repl-environment repl))))
            ;; Read required args, then attempt to read any additional
            ;; args.  There's a big caveat: If we hit a newline in
            ;; between complete expressions, all expressions that
            ;; follow after the newline will *not* be read.  This is
            ;; very similar to Guile's default meta-command reader.
            (append (list #,@(make-list nreq #'(read port)))
                    (let lp ((str (string-append (read-line) "\n")))
                      (let ((port (open-input-string str)))
                        (match (read port)
                          ((? eof-object?) '())
                          (arg (cons arg (lp (read-string-all port))))))))))
      (define (parse-body body name args)
        (let lp ((body body)
                 (name name)
                 (aliases #f)
                 (group #f)
                 (usage #f)
                 (summary #f)
                 (doc #f)
                 (reader #f))
          (syntax-case body ()
            ((#:name name . body)
             (lp #'body #'name aliases group usage summary doc reader))
            ((#:aliases aliases . body)
             (lp #'body name #'aliases group usage summary doc reader))
            ((#:group group . body)
             (lp #'body name aliases #'group usage summary doc reader))
            ((#:usage usage . body)
             (lp #'body name aliases group #'usage summary doc reader))
            ((#:summary summary . body)
             (lp #'body name aliases group usage #'summary doc reader))
            ((#:documentation doc . body)
             (lp #'body name aliases group usage summary #'doc reader))
            ((#:reader reader . body)
             (lp #'body name aliases group usage summary doc #'reader))
            ((kw . _)
             (keyword? (syntax->datum #'kw))
             (syntax-violation 'define-meta-command "invalid keyword argument" #'kw))
            (_
             #`((#:name #,name
                 #,@(if aliases #`(#:aliases #,aliases) '())
                 #,@(if usage #`(#:usage #,usage) '())
                 #,@(if summary #`(#:summary #,summary) '())
                 #,@(if doc #`(#:documentation #,doc) '())
                 #,@(if reader
                        #`(#:reader #,reader)
                        #`(#:reader #,(make-reader args))))
                #,body)))))
      (syntax-case stx ()
        ((_ (name repl . args) . body)
         (with-syntax ((((kwarg ...) body) (parse-body #'body #'name #'args)))
           #'(define name
               (make-meta-command kwarg ... #:proc (lambda* (repl . args) . body))))))))

  (define (meta-command-read cmd repl port)
    "Read meta-command arguments from @var{port} using the reader for
@var{cmd}."
    ((meta-command-reader cmd) repl port))

  ;; TODO: Show help groups like Guile does.
  (define-meta-command (meta:help repl)
    #:name 'help
    #:aliases '(h)
    #:group 'help
    #:summary "Show help."
    (define (print-usage+summary cmd)
      (let* ((name (symbol->string (meta-command-name cmd)))
             (aliases (map symbol->string
                           (meta-command-aliases cmd)))
             (usage (meta-command-usage cmd))
             (breakpoint 40)
             ;; 3 characters of padding to account for the comma
             ;; and spaces around the command name.
             (padding 3)
             ;; This isn't a correct measurement in UTF-8
             ;; terms, but it's close enough for now.
             ;; Basically, we want to indent a consistent
             ;; amount and wrap to a new line if we
             ;; overflow.
             (name+usage-chars
              (+ (string-length name)
                 (string-length usage)))
             (alias-chars
              (+ (fold (lambda (str n)
                         (+ (string-length str) n))
                       0 aliases)
                 (match aliases
                   (() 0)
                   ;; Number of commas/spaces + open/close brackets +
                   ;; trailing space.
                   (_ (+ (* (1- (length aliases)) 2) 3))))))
        (display " ,")
        (display name)
        (display " ")
        (display (meta-command-usage cmd))
        ;; Maybe break the line here if the name + usage text goes
        ;; past the breakpoint.  Attempt to right align the alias
        ;; text at the breakpoint.
        (cond
         ((>= (+ name+usage-chars padding) breakpoint)
          (newline)
          (display (make-string (max (- breakpoint alias-chars) 0) #\space)))
         (else
          (display (make-string (- breakpoint name+usage-chars
                                   alias-chars padding)
                                #\space))))
        (match aliases
          (() (values))
          ((first . rest)
           (display "[")
           (display ",")
           (display first)
           (for-each (lambda (alias)
                       (display " ,")
                       (display alias))
                     rest)
           (display "]")))
        (display " - ")
        (display (meta-command-summary cmd))
        (newline)))
    (display "Commands [abbrev]:\n\n")
    (for-each print-usage+summary (repl-meta-commands repl)))

  (define-meta-command (meta:describe repl exp)
    #:name 'describe
    #:aliases '(d)
    #:group 'help
    #:usage "OBJ"
    #:summary "Show description/documentation."
    (match (repl-eval repl exp)
      ((? procedure? proc)
       ;; TODO: Display procedure argument list and docstring.
       (display "Procedure: ")
       (display (procedure-name proc)))
      (_ (display #f)))
    (newline))

  (define-meta-command (meta:quit repl)
    #:name 'quit
    #:aliases '(q)
    #:group 'system
    #:summary "Exit the REPL."
    (repl-pop! repl))

  (define-meta-command (meta:change-module repl #:optional name)
    #:name 'module
    #:aliases '(m)
    #:group 'module
    #:usage "[MODULE]"
    #:summary "Change module / show current module."
    (if name
        (let* ((env (repl-environment repl))
               (module (repl-environment-module env))
               (new (resolve-module module name #:load? #t #:define? #t)))
          (set-repl-environment-module! env new)
          (values))
        (let ((module (repl-environment-module (repl-environment repl))))
          (display (module-name module))
          (newline))))

  (define-meta-command (meta:import repl . names)
    #:name 'import
    #:aliases '(use)
    #:group 'module
    #:usage "[MODULE ...]"
    #:summary "Import modules / List those imported."
    (if (null? names)
        ;; List imported modules
        (for-each (lambda (module)
                    (display (module-name module))
                    (newline))
                  (module-imported-modules
                   (repl-environment-module
                    (repl-environment repl))))
        ;; Import modules
        (let* ((env (repl-environment repl))
               (dst (repl-environment-module env)))
          (for-each (lambda (src)
                      (for-each (lambda (name)
                                  (module-import! dst src name))
                                (module-exported-names src)))
                    (map (lambda (name)
                           (or (resolve-module dst name #:load? #t)
                               (error "no such module" name)))
                         names)))))

  (define (assert-debugger repl)
    (unless (repl-debug? (repl-environment-data (repl-environment repl)))
      (error "Not in a debugger.")))

  (define-meta-command (meta:backtrace repl)
    #:name 'backtrace
    #:aliases '(bt)
    #:group 'debug
    #:summary "Print a backtrace."
    (assert-debugger repl)
    (let* ((debug (repl-environment-data (repl-environment repl)))
           (exn (repl-debug-exception debug))
           (stack (repl-debug-stack debug))
           (origin (and (exception-with-origin? exn) (exception-origin exn))))
      (call-with-values (lambda ()
                          (if (exception-with-source? exn)
                              (values (exception-source-file exn)
                                      (exception-source-line exn)
                                      (exception-source-column exn))
                              (values #f #f #f)))
        (lambda (file line column)
          (format-exception exn (current-output-port))
          (newline)
          (newline)
          (print-backtrace stack origin file line column
                           (current-output-port))))))

  (define %meta-commands
    (list meta:help
          meta:describe
          meta:quit
          meta:change-module
          meta:import
          meta:backtrace))

  (define (welcome repl)
    (string-append "Hoot "
                   %version
                   "

Enter `,help' for help."))

  (define (welcome/debug repl)
    (let ((port (open-output-string)))
      (newline port)
      (format-exception
       (repl-debug-exception
        (repl-environment-data
         (repl-environment repl)))
       port)
      (display "\n\nEntering a new prompt.  " port)
      (display "Type `,bt' for a backtrace or `,q' to continue." port)
      (get-output-string port)))

  (define (prompt repl)
    (let ((depth (repl-depth repl))
          (env (repl-environment repl))
          (port (open-output-string)))
      (display (module-name (repl-environment-module env)) port)
      (unless (zero? depth)
        (display " [" port)
        (display depth port)
        (display "]" port))
      (display "> " port)
      (get-output-string port)))

  (define* (make-repl-environment #:key (language scheme)
                                  (module (interaction-environment))
                                  data (welcome welcome) (prompt prompt))
    "Return a fresh REPL environment for evaluating @var{language} in
@var{module}.  @var{data} can be any arbitrary object to associate
with this environment, perhaps including debug information.
@var{welcome} is a procedure that displays a welcome message when the
enviroment is entered.  @var{prompt} is a procedure that returns an
input prompt to display to the user.  Both @var{welcome} and
@var{prompt} take just one argument: a REPL object."
    (%make-repl-environment language module data welcome prompt))

  (define (make-repl-debug-environment env exn stack)
    (make-repl-environment #:language (repl-environment-language env)
                           #:module (repl-environment-module env)
                           #:data (make-repl-debug exn stack)
                           #:welcome welcome/debug))

  (define* (make-repl #:key (environment (make-repl-environment))
                      (meta-commands %meta-commands))
    "Return a fresh REPL for @var{environment} with @var{meta-commands}."
    (let ((repl (%make-repl environment '() (make-eq-hashtable))))
      (for-each (lambda (cmd)
                  (repl-add-meta-command! repl cmd))
                meta-commands)
      repl))

  (define (repl-depth repl)
    "Return the current depth of @var{repl}."
    (length (repl-stack repl)))

  (define (repl-add-meta-command! repl cmd)
    "Add meta-command @var{cmd} to @var{repl}."
    (let ((commands (%repl-meta-commands repl)))
      (hashtable-set! commands (meta-command-name cmd) cmd)
      (for-each (lambda (alias)
                  (hashtable-set! commands alias cmd))
                (meta-command-aliases cmd))))

  (define (repl-meta-commands repl)
    "Return a list of meta-commands associated with @var{repl}."
    (let ((commands (make-eq-hashtable)))
      (hashtable-for-each
       (lambda (name cmd)
         (hashtable-set! commands cmd #t))
       (%repl-meta-commands repl))
      (hashtable-keys commands)))

  (define (repl-meta-command-ref repl name)
    "Return the meta-command in @var{repl} associated with @var{name}, or
@code{#f} if there is no such command."
    (hashtable-ref (%repl-meta-commands repl) name))

  (define (repl-welcome repl)
    "Return the welcome message for the current environment in @var{repl}."
    ((repl-environment-welcome (repl-environment repl)) repl))

  (define (repl-prompt repl)
    "Return the current prompt message for @var{repl}."
    ((repl-environment-prompt (repl-environment repl)) repl))

  (define* (repl-read repl #:optional (port (current-input-port)))
    "Read an expression from @var{port} using the current reader for
@var{repl}.  The returned expression may be a meta-command invocation."
    (define (whitespace? ch)
      (memq ch '(#\tab #\newline #\vtab #\page #\return #\space #\240)))
    (define (read-meta-command-name)
      (string->symbol
       (list->string
        (let lp ()
          (match (peek-char port)
            ((or (? eof-object?) (? whitespace?))
             '())
            (_ (cons (read-char port) (lp))))))))
    (let consume-whitespace ()
      (when (whitespace? (peek-char port))
        (read-char port)
        (consume-whitespace)))
    (let ((lang (repl-environment-language (repl-environment repl))))
      (case (peek-char port)
        ;; Meta-command
        ((#\,)
         (read-char port)
         (let ((name (read-meta-command-name)))
           (match (repl-meta-command-ref repl name)
             (#f
              (error "unknown meta-command" name))
             (cmd
              (make-meta-expression cmd (meta-command-read cmd repl port))))))
        ;; Language expression
        (else ((repl-language-reader lang) port)))))

  (define (repl-eval repl exp)
    "Eval @var{exp} in the current environment of @var{repl}."
    (let* ((env (repl-environment repl))
           (lang (repl-environment-language env)))
      ((repl-language-evaluator lang) exp (repl-environment-module env))))

  (define* (repl-meta-eval repl cmd #:optional (args '()))
    "Invoke the meta-command @var{cmd} in @var{repl} with @var{args}."
    (define (handle-exception exn)
      (cond
       ((repl-quit-exception? exn)
        (raise-exception exn))
       (else
        (display "While executing meta-command:\n\n")
        (format-exception exn (current-output-port))
        (newline))))
    (with-exception-handler handle-exception
      (lambda () (apply (meta-command-procedure cmd) repl args))
      #:unwind? #t))

  (define error-prompt (make-prompt-tag 'repl-error))
  (define (repl-eval-with-error-handling repl exp)
    "Eval @var{exp}, either a language or meta-command
expression, in the current environment of @var{repl}.  If an exception
is thrown while evaluating a language expression, a debugging sub-REPL
will be entered."
    (cond
     ((meta-expression? exp)
      (repl-meta-eval repl
                      (meta-expression-command exp)
                      (meta-expression-arguments exp)))
     (else
      (define (enter-debugger exn)
        ;; TODO: Trim stack frames.
        (let* ((stack (capture-stack (stack-height)))
               (debug (make-repl-debug exn stack))
               (env (repl-environment repl)))
          (repl-push! repl (make-repl-debug-environment env exn stack))))
      (define (handle-exception exn)
        (cond
         ((repl-quit-exception? exn)
          (raise-exception exn))
         (else
          (enter-debugger exn)
          (abort-to-prompt error-prompt))))
      (call-with-prompt error-prompt
        (lambda ()
          (with-exception-handler handle-exception
            (lambda ()
              (repl-eval repl exp))))
        (lambda (_) (values))))))

  (define (repl-push! repl environment)
    "Enter a sub-REPL within @var{repl} using @var{environment}, saving the
current environment on the environment stack to be restored later."
    (set-repl-stack! repl (cons (repl-environment repl) (repl-stack repl)))
    (set-repl-environment! repl environment))

  (define (repl-pop! repl)
    "Leave the current environment in @var{repl}, restoring the previous
environment if there is one.  Otherwise, raise an exception."
    (match (repl-stack repl)
      (()
       (raise (make-repl-quit-exception repl)))
      ((env . stack)
       (set-repl-environment! repl env)
       (set-repl-stack! repl stack)))
    (values))

  (define current-repl (make-parameter #f))

  (define (simple-repl-reader repl)
    (display (repl-prompt repl))
    (flush-output-port (current-output-port))
    (repl-read repl))

  ;; TODO: Use readline-like reader when current input port is a TTY.
  (define* (run-repl repl #:key (reader simple-repl-reader))
    "Run @var{repl} using @var{reader} to prompt the user and read input."
    (define unspecified (if #f #f))
    (define (unspecified? x)
      (eq? x unspecified))
    (define repl-tag (make-prompt-tag 'repl))
    (define (read)
      (define (handle-exception exn)
        (display "While reading input:\n\n")
        (format-exception exn (current-output-port))
        (newline)
        (flush-output-port (current-output-port))
        (unless (port-open? (current-input-port))
          (abort-to-prompt repl-tag))
        unspecified)
      (with-exception-handler handle-exception
        (lambda () (reader repl))
        #:unwind? #t))
    (define (eval exp)
      (define (handle-exception exn)
        (when (repl-quit-exception? exn)
          (abort-to-prompt repl-tag)))
      (with-exception-handler handle-exception
        (lambda ()
          (repl-eval-with-error-handling repl exp))
        #:unwind? #t))
    (define (print . vals)
      (for-each (lambda (val)
                  (unless (unspecified? val)
                    (display "=> ")
                    (write val)
                    (newline)))
                vals)
      (flush-output-port (current-output-port)))
    (define (loop prev-depth)
      (let ((depth (repl-depth repl)))
        (when (> depth prev-depth)
          (display (repl-welcome repl))
          (newline)
          (flush-output-port (current-output-port)))
        (match (read)
          ((? eof-object?)
           (values))
          ((? unspecified?)
           (loop depth))
          (exp
           (call-with-values (lambda () (eval exp)) print)
           (loop depth)))))
    (call-with-prompt repl-tag
      (lambda ()
        (parameterize ((current-repl repl))
          (loop -1)))
      (lambda (k) (values))))

  (define* (spawn-repl #:key (environment (make-repl-environment))
                       (meta-commands %meta-commands)
                       (reader simple-repl-reader))
    "Create and run a REPL for @var{environment} with @var{meta-commands}."
    (run-repl
     (make-repl #:environment environment
                #:meta-commands meta-commands))))
