;;;;
;;;; repl.stk   -- STklos REPL
;;;;
;;;; Copyright © 2000-2024 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date:  4-Jun-2000 15:07 (eg)
;;;;

;; This file defines the REPL module. This module does not export anything
;; and is completely self-contained. This is the module which is last loaded
;; in the default boot file.
;;


(define-module REPL
  (import SCHEME)
  (export main-repl repl repl-prompt repl-make-prompt repl-display-prompt
          repl-prompt-use-color? repl-change-default-ports main-repl-hook
          repl-theme get-repl-color repl-show-startup-message
          repl-add-command
          @ @1 @2 @3 @4 @5 @*)

;;; In module REPL

(define interactive?   (interactive-port? (current-input-port)))

(define repl-level 0)
(define repl-backtrace '())

(define default-in  (current-input-port))
(define default-out (current-output-port))
(define default-err (current-error-port))

(define @1 #void)
(define @2 #void)
(define @3 #void)
(define @4 #void)
(define @5 #void)
(define @* (list @1 @2 @3 @4 @5))

;; define @ as an alias on @1
(let ((M (find-module 'REPL))) (%symbol-link '@ '@1 M M))


#|
<doc EXT repl-theme
 * (repl-theme)
 * (repl-theme plist)
 * (repl-theme name)
 *
 * The {{stklos}} REPL colors can be customized using a property list (or a theme
 * name) using the `repl-theme` parameter. The properties that can be used in this
 * property list are:
 *
 * - `#:error` for the color of error messages
 * - `#:prompt` for the color of the prompt
 * - `#:help-prompt` for the color of the help prompt
 * - `#:help` for the color of the help messages
 * - `#:repl-depth` for the color of the depth indicator for recursive REPLs
 * - `#:info` for the color of information messages.
 *
 * There are three default themes:
 *
 * - **classic** which is the (colorful) default theme.
 * - **monochrome** which doesn't use colors
 * - **minimal** where only the prompt and errors are colored.
 *
 * Colors are expressed using the conventions of
 * <<ansicolor, the `ansi-color` primitive>>. For instance:
 *
 * @lisp
 * (key-set! (repl-theme) :prompt '(bold green)) ;; set the prompt to bold green
 *
 * (repl-theme 'minimal)                         ;; to use a sober prompt
 *
 * (repl-theme '(#:error (bold red)              ;; explicitly defined theme
 *               #:prompt (bold bg-red white)))
 * @end lisp
 *
 * NOTE: A good place to change your theme is the `stklosrc` file.
doc>
|#
(define *repl-themes* `(
     (classic     .  (:error       (bold red)         ;; error messages
                      :input       (normal bold)      ;; normal input
                      :prompt      (bold magenta)     ;; prompt color
                      :help-prompt (bold green)       ;; help prompt color
                      :help        (bold blue)        ;; help messages
                      :repl-depth  yellow             ;; REPL depth
                      :info        (bold blue)))      ;; information

     (monochrome  .  ())

     (minimal     . (:error  (bold red)
                     :prompt  underline))))

(define-parameter repl-theme #f
  (lambda (theme)
    (if (symbol? theme)
        (let ((val (assoc theme *repl-themes*)))
          (if val (cdr val) '()))
        theme)))

(define (get-repl-color key)
  (key-get (repl-theme) key ""))


;;; ======================================================================
;;;
;;; REPL commands
;;;
;;; ======================================================================
(define *repl-commands* '())

#|
<doc EXT repl-add-command
 * (repl-add-command names doc func)
 *
 * Add a new command to the REPL. The names of the command are given in the
 * first parameter as a list (or a symbol if there is only one name).
 * The documentation of the command is given as a string as the second parameter.
 * Finally, the function given as the third parameter is called when the new command
 * is executed by the user. The code hereafter, permits to add a command to call an
 * editor, with the commands |,editor| or |,ed| followed (eventually) by a file name.
 *
 * @lisp
 * (repl-add-command '(editor ed)
 *                  "Edit a file with $EDITOR (or emacs if unset)"
 *                  (lambda ()
 *                    (let ((cmd (or (getenv "EDITOR") "emacs")))
 *                      (system (string-append cmd " " (read-line) " 2>/dev/null")))))
 * @end lisp
 *
 * NOTE: {{stklos}} has already a number of commands defined, but
 * |repl-add-command| can be  useful to define your own commrand. A good place to add
 * such a definition is in the |stklosrc| file.
doc>
|#
(define (repl-add-command names doc func)
  (let* ((names (if (symbol? names) (list names) names))
         (old   (assoc names *repl-commands*)))
    (if old
       (set-cdr! old (list doc func))   ;; already present. Replace.
       (set! *repl-commands* (cons (list names doc func)
                                   *repl-commands*)))))

(define (display-repl-command-help)
  (let* ((lines (map (lambda (x)
                       (let ((out (open-output-string)))
                         (for-each (lambda (c) (fprintf out ",~a " c))
                                   (car x))
                         (cons (get-output-string out) (cadr x))))
                     *repl-commands*))
         (max-len (apply max (map string-length (map car lines)))))

    ;; Print all the lines aligned on max-len characters
    (display (do-color (get-repl-color :help)  "Available commands:\n"))
    (display (do-color 'normal))
    (for-each (lambda (x)
                (print " - "
                       (car x)
                       (make-string (- max-len (string-length (car x)))
                                    #\space)
                       " "
                       (cdr x)))
              (reverse lines))) ;; to keep the declaration order

  ;; Print somme helps on the @ variables
  (display (do-color (get-repl-color :help)  "\nAvailable variables:\n"))
  (display (do-color 'normal))
  (display "If not redefined by your program, the following variables are available\n")
  (display " - @1 (aka @), @2, @3, @4, @5 contain the last REPL's computed values\n")
  (display " - @* contains a list of @1, @2, @3, @4 and @5 values\n")

  ;; Print somme helps on the ! shell escape
  (display (do-color (get-repl-color :help)  "\nShell commands:\n"))
  (display (do-color 'normal))
  (display "!cmd a1 a2 ...  executes the command \"cmd\" with the arguments a1 a2...\n"))


(define (do-repl-command name)
  (define (search-repl-command name)
    (let Loop ((lst *repl-commands*))
      (if (pair? lst)
          ;; See if (car lst) is a known repl command
          (let ((cmd (car lst)))
            (if (memq name (car cmd))
                ((caddr cmd))
                (Loop (cdr lst))))
          ;; List of possibilities exhausted
          (format (current-error-port)
                  "bad command name: '~s'.\nType ',help' for some help.\n"
                  name))))

  ;; Skip the leading spaces
  (let Loop ()
    (when (eq? (peek-char) #\space)
      (read-char)
      (Loop)))

  ;; And try to find a REPL command
  (search-repl-command name))


;; A simple trim for the commands below
(let ((simple-trim (lambda (str)
                     (regexp-replace "\\s*$"
                                     (regexp-replace "^\\s*" str "")
                                     ""))))

  ;; ==== backtrace
  (repl-add-command '(backtrace bt)
                    "Show the stack when last error occurred"
                    (lambda () (%display-backtrace repl-backtrace 6)))
  ;; ==== cd
  (repl-add-command 'cd
                    "Change current directory"
                    (lambda () (chdir (simple-trim (read-line)))))
  ;; ==== quit
  (repl-add-command '(quit q)
                    "Exit STklos"
                    (lambda () (exit 0)))
  ;; ==== time
  (repl-add-command '(time t)
                    "Print the time used to run the next expression"
                    (lambda () (printf "~w~%" (eval-from-string
                                          (format "(time (eval '~a))" (read))))))
  ;; ==== describe
  (repl-add-command '(describe d)
                    "Describe an object"
                    (lambda () (describe (eval (read)))))
  ;; ==== expand
  (repl-add-command '(expand e)
                    "Pretty print the macro expansion of a form"
                    (lambda () (pretty-print (macro-expand (read)))))
  ;; ==== import
  (repl-add-command '(import i)
                    "Import a library"
                    (lambda () (eval-from-string (format "(import ~a)" (read)))))
  ;; == require-feature
  (repl-add-command '(require-feature r)
                    "Require a feature"
                    (lambda () (require-feature (read))))
  ;; ==== open
  (repl-add-command '(open o)
                    "Open file or URL"
                    (lambda ()
                      (let ((cmd (if (equal? (os-name) "Darwin") "open" "xdg-open")))
                        (system (string-append cmd " " (read-line) " 2>/dev/null")))))
  ;; ==== browse
  (repl-add-command '(browse b)
                    "Browse file or URL with the default browser"
                    (lambda () (open-in-browser (read-line))))

  ;; ==== describe
  (repl-add-command '(describe d)
                    "Describe an object"
                    (lambda () (describe (eval (read)))))
  ;; ==== manual
  (repl-add-command '(manual m)
                    "Search reference manual"
                    (lambda () (manual (simple-trim (read-line)))))
  ;; ==== apropos
  (repl-add-command '(apropos a)
                    "Search for symbols containing a given string"
                    (lambda () (print (apropos (simple-trim (read-line))))))
  ;; == version
  (repl-add-command '(version v)
                    "Show version"
                    (lambda () (printf "~a ~a~%" (version) (%push-id))))
  ;; ==== help
  (repl-add-command
   '(help ? h)
   "This help if no parameter, or help on its argument"
   (lambda ()
     (let ((arg (read-line)))
       (if (equal? arg "")
           (display-repl-command-help)
           (help (read-from-string arg))))))

) ;; end of REPL commands

;; ----------------------------------------------------------------------
;;      repl-handler ...
;;         -- The error handler for the REPL
;; ----------------------------------------------------------------------
(define %other-error-handlers '())

(define (%try-matching-condition e)
  (assoc e %other-error-handlers (lambda(key pred?) (pred? key))))

(define (%add-error-to-repl-handler pred? action)
  ;; Usage exemple:
  ;; (%add-error-to-repl-handler integer? (lambda (v port)
  ;;                                       (format port "Got error #~S\n" v)))
  ;; (raise 42) will print "Got error #42" instead of a "non condition was raised"
  ;; error
  (set! %other-error-handlers (cons (cons pred? action) %other-error-handlers)))


(define (display-error-message who msg bt out)
  (let* ((loc (%build-error-location who bt))
         (from (if (cadr loc)
                   (format " (near line ~a in file ~s)" (cdadr loc) (caadr loc))
                   "")))
    (display (do-color (get-repl-color :error)
                       (format "**** Error~A:\n~A: ~A\n" from (car loc) msg)
                       'normal
                       "\t(type \""
                       'underline ",help" 'normal
                       "\" for more information)\n")
             out)))


(define (repl-handler c port)
  (if (condition? c)
      (cond
        ((condition-has-type? c &error-message)         ;; &error-message
           (let ((who (condition-ref c 'location))
                 (msg (condition-ref c 'message))
                 (bt  (condition-ref c 'backtrace)))
             (display-error-message who msg bt port)
             (set! repl-backtrace bt)))
        ((condition-has-type? c &message)               ;; &message (e.g. ^C)
           (format port (condition-ref c 'message)))
        ((condition-has-type? c &uncaught-exception)
           (repl-handler (uncaught-exception-reason c) port))
        ((condition-has-type? c &exit-r7rs)             ;; R7RS exit function
         (let ((retcode (condition-ref c 'retcode)))
           (%pre-exit retcode)
           (emergency-exit retcode)))
        (else                                           ;; Unknown
           (format port "**** Unknown condition raised.\n")
           (format port "Condition type: ~A\n" (struct-type-name (struct-type c)))
           (format port "Condition slots: ~S\n" (struct->list c))))
      ;; Value raised is not a condition. Display it
      (let ((res (%try-matching-condition c)))
        (if res
            ( (cdr res) c port)
            (format port "**** The following non-condition was raised: ~S\n" c)))))

;; ----------------------------------------------------------------------
;;      repl-prompt ...
;; ----------------------------------------------------------------------
(define-parameter repl-prompt "")

;; ----------------------------------------------------------------------
;;      repl-prompt-use-color? ...
;; ----------------------------------------------------------------------
(define-parameter repl-prompt-use-color? #t)

;; ----------------------------------------------------------------------
;;      make-prompt ...
;; ----------------------------------------------------------------------
(define (make-prompt module)
  (let ((str1 (if (> repl-level 1) (format "[~A] " repl-level) ""))
        (str2 (format "~A>" (module-name module))))
    (repl-prompt (if (repl-prompt-use-color?)
                     (string-append
                        (do-color (get-repl-color :repl-depth) str1 'normal)
                        (do-color (get-repl-color :prompt) str2 'normal
                                  (get-repl-color :input))
                        " ")
                     (string-append str1 str2 " ")))))

;; ----------------------------------------------------------------------
;;      repl-make-prompt ...
;; ----------------------------------------------------------------------
(define-parameter repl-make-prompt make-prompt)

;; ----------------------------------------------------------------------
;;      display-prompt ...
;; ----------------------------------------------------------------------
(define (display-prompt port)
  (display (repl-prompt) port)
  (flush-output-port port))

;; ----------------------------------------------------------------------
;;      repl-display-prompt ...
;; ----------------------------------------------------------------------
(define-parameter repl-display-prompt display-prompt)


#|
<doc EXT repl-show-startup-message
 * (repl-show-startup-message)
 * (repl-show-startup-message val)
 *
 * If this parameter is a true value, a banner is printed when {{stklos}} starts
 * in interactive mode. Otherwise, no banner is printed. By default, this parameter
 * is set to `#t`.
 *
 * NOTE: This parameter can be set to `#f` with the |--no-startup-message| option of
 * the {{stklos}} command. Otherwise, a good place to set this parameter is in the
 * `stklosrc` file.
doc>
|#
(define-parameter repl-show-startup-message
  (key-get *%system-state-plist* #:startup-message #t))

;; ----------------------------------------------------------------------
;;      main-repl-hook ...
;; ----------------------------------------------------------------------
(define-parameter main-repl-hook void)

;; ----------------------------------------------------------------------
;;      repl-change-default-ports ...
;; ----------------------------------------------------------------------
(define (repl-change-default-ports :key  (in  default-in)
                                         (out default-out)
                                         (err default-err))
  (set! default-in in)
  (set! default-out out)
  (set! default-err err))


;; ----------------------------------------------------------------------
;;      repl-fold-case? ...
;; ----------------------------------------------------------------------
(define (repl-fold-case?)
  ;; See if user used stklos(1) "--case-insensitive" option
  (key-get *%system-state-plist* #:fold-case #f))

;; ----------------------------------------------------------------------
;;      repl ...
;; ----------------------------------------------------------------------

#|
<doc EXT repl
 * (repl)
 * (repl :in inport :out outport :err errport)
 *
 * This procedure launches a new Read-Eval-Print-Loop. Calls to |repl| can be
 * embedded. The ports used for input/output as well as the error port can
 * be passed when |repl| is called. If not passed, they default to
 * |current-input-port|, |current-output-port| and |current-error-port|.
doc>
|#
(define (repl :key (in  default-in)
                   (out default-out)
                   (err default-err))
  (let ((eof #f))
    (set! repl-level (+ repl-level 1))
    (let Loop ()
      (with-handler (lambda (c) (repl-handler c err))
         ;; display prompt
         (when interactive?
           ( (repl-make-prompt) (current-module) )
           ( (repl-display-prompt) err ))

         (let ((e (%read in)))
           (display (do-color 'normal))
           (cond
             ((eof-object? e)
                (set! repl-level (- repl-level 1))
                (set! eof #t)
                (display "\n")
                (flush-output-port err)
                (flush-output-port out))

             ((and (pair? e) (eq? (car e) 'unquote))
                 ;; Spcial ,xxx commands
                 (do-repl-command (cadr e)))

             ((and (symbol? e)
                   (not (symbol-bound? e))
                   (char=? (string-ref (symbol->string e) 0) #\!))
                 ;; Shell command "!xxx arg1 arg2"
                 (let* ((end (read-line (current-input-port)))
                        (all (format "~a~a" e end)))
                   (system (substring all 1 (string-length all)))))

             (else
                (call-with-values
                  (lambda () (eval e))
                  (lambda v
                    (when interactive?
                      (cond
                        ((null? v)
                           ;; (values)
                           #f)
                        ((eq? (car v) (void))
                           (when (= (length v) 2)
                             ;; Special convention for variable definition
                             (display (do-color (get-repl-color :info)
                                                (format ";; ~A\n" (cadr v))
                                                'normal)
                                      out)))
                        (else
                         ;; Build @* REPl variable
                         (case (length v)
                           ((1) (set! @* (list (car v) @1 @2 @3 @4)))
                           ((2) (set! @* (list (car v) (cadr v) @1 @2 @3)))
                           ((3) (set! @* (list (car v) (cadr v) (caddr v) @1 @2)))
                           ((4) (set! @* (list (car v) (cadr v) (caddr v) (cadddr v)
                                               @1)))
                           (else (set! @* (list (car v) (cadr v) (caddr v) (cadddr v)
                                                (car (cddddr v))))))
                         ;; Build @i variables
                         (set! @5 (car (cddddr @*)))
                         (set! @4 (cadddr @*))
                         (set! @3 (caddr @*))
                         (set! @2 (cadr @*))
                         (set! @1 (car @*))

                         ;; Print values
                         (for-each (lambda (x) (write-shared x out) (newline out))
                                     v)))
                      (flush-output-port out))))))))
      ;; Loop if we have not meet an EOF
      (unless eof (Loop)))))

;; ----------------------------------------------------------------------
;;      main-repl ...
;; ----------------------------------------------------------------------
(define (main-repl)
  ;; Initialize signals suitable for a REPL session (e.g. be immune to ^C)
  (%initialize-signals)

  (when (repl-fold-case?)
    ;; Be case insensitive if user asked for it
    (read-case-sensitive #f))

  (when interactive?
    ;; Use classic theme if the user has not set a theme in his/her init file
    (unless (repl-theme)
      (repl-theme 'classic))
    (when (repl-show-startup-message)
      (let* ((utf8?  (key-get *%system-state-plist* :use-utf8 #f))
             (line1   (format "STklos version ~a (~a)\n" (version) (%push-id)))
             (line2  "Copyright (C) 1999-2024 Erick Gallesio <eg@stklos.net>\n")
             (line3 (format "[~a/~a/~a/~a]\n"
                            (machine-type)
                            (%thread-system)
                            (key-get *%system-state-plist* :readline 'no-readline)
                            (if utf8? 'utf8 'no-utf8)))
             (line4  "Type ',h' for help\n")
             (col1  (get-repl-color :input))
             (col2  (get-repl-color :info)))
        (display (do-color 'normal col1 "  \\    " col2 line1 'normal))
        (display (do-color 'normal col1 "   \\   " col2 line2 'normal))
        (display (do-color 'normal col1 "  / \\  " col2 line3 'normal))
        (display (do-color 'normal col1 " /   \\ " col2 line4 'normal)))))
  ;; Lauch the REPL
  ((main-repl-hook))
  (repl)
  (%pre-exit 0))
)


; LocalWords:  repl
