path: root/catbird/repl.scm

;;; Catbird Game Engine
;;; Copyright © 2022 David Thompson <davet@gnu.org>
;;;
;;; Catbird 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 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Catbird 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 Catbird.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; In-engine asynchronous REPL implementation.
;;
;;; Code:
(define-module (catbird repl)
  #:use-module (catbird line-editor)
  #:use-module (catbird kernel)
  #:use-module (catbird mode)
  #:use-module (catbird node)
  #:use-module (catbird node-2d)
  #:use-module (catbird region)
  #:use-module (catbird ring-buffer)
  #:use-module (catbird scene)
  #:use-module (catbird ui)
  #:use-module (chickadee)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics path)
  #:use-module (chickadee graphics text)
  #:use-module (chickadee graphics texture)
  #:use-module (chickadee math vector)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (system base compile)
  #:use-module (system base language)
  #:use-module (system vm loader)
  #:export (<repl>
            <repl-mode>
            resize-repl
            repl-print))

;; TODO: $number values like regular Guile REPL
;; TODO: Multiple expressions
;; TODO: Debugger
;; TODO: Switching languages


;;;
;;; Graphical Printers
;;;

(define-method (repl-print obj)
  (make <label> #:text (with-output-to-string (lambda () (write obj)))))

(define-method (repl-print (pair <pair>))
  (let ((open (make <label> #:text "("))
        (close (make <label> #:text ")")))
    (make <horizontal-container>
      #:children (match pair
                   ((vals ...)
                    `(,open
                      ,@(let loop ((vals vals))
                          (match vals
                            (() '())
                            ((x)
                             (list (repl-print x)))
                            ((x . rest)
                             (append (list (repl-print x)
                                           (make <label> #:text " "))
                                     (loop rest)))))
                      ,close))
                   ((first . second)
                    (list open
                          (repl-print first)
                          (make <label> #:text " . ")
                          (repl-print second)
                          close))))))

(define-method (repl-print (v <vector>))
  (make <horizontal-container>
    #:children `(,(make <label> #:text "#(")
                 ,@(let loop ((i 0))
                     (when (< i (vector-length v))
                       (let ((x (vector-ref v i)))
                         (if (= i (- (vector-length v) 1))
                             (list (repl-print x))
                             (cons* (repl-print x)
                                    (make <label> #:text " ")
                                    (loop (+ i 1)))))))
                 ,(make <label> #:text ")"))))

(define <texture> (class-of null-texture))
(define-method (repl-print (texture <texture>))
  (make <sprite> #:texture texture))


;;;
;;; REPL
;;;

(define %background-color (make-color 0.0 0.0 0.0 0.9))

(define (make-user-module)
  (let ((module (resolve-module '(guile-user) #f)))
    (beautify-user-module! module)
    module))

(define-class <repl-debug> ()
  (stack #:accessor stack #:init-keyword #:stack))

(define-class <repl-level> ()
  (depth #:accessor depth #:init-keyword #:depth #:init-value 0)
  (language #:accessor language #:init-keyword #:language
            #:init-value (lookup-language 'scheme))
  (module #:accessor module #:init-keyword #:module
          #:init-thunk make-user-module)
  (debug #:accessor debug #:init-keyword #:debug #:init-value #f))

(define-class <repl> (<node-2d>)
  (level #:accessor level #:init-form (make <repl-level>))
  (level-stack #:accessor level-stack #:init-value '()))

(define-method (language (repl <repl>))
  (language (level repl)))

(define-method (module (repl <repl>))
  (module (level repl)))

(define-method (depth (repl <repl>))
  (depth (level repl)))

(define-method (debug (repl <repl>))
  (debug (level repl)))

(define-method (initialize (repl <repl>) initargs)
  (next-method)
  (attach-to repl
             (make <canvas>
               #:name 'background)
             (make <vertical-container>
               #:name 'log
               #:rank 1)
             (make <line-editor>
               #:name 'editor
               #:rank 1))
  (log-append repl "Enter ',help' for help.")
  (refresh-prompt repl))

(define-method (push-repl-level (repl <repl>) (new-level <repl-level>))
  (set! (level-stack repl) (cons (level repl) (level-stack repl)))
  (set! (level repl) new-level))

(define-method (pop-repl-level (repl <repl>))
  (match (level-stack repl)
    (() (detach repl))
    ((prev . rest)
     (set! (level repl) prev)
     (set! (level-stack repl) rest))))

(define-method (log-append (repl <repl>) node)
  (let ((container (make <margin-container>
                     #:margin 2.0
                     #:children (list node))))
    (attach-to (& repl log) container)
    (refresh-log repl)))

(define-method (log-append (repl <repl>) (text <string>))
  (log-append repl (make <label> #:text text)))

(define-method (refresh-log (repl <repl>))
  (let ((log (& repl log))
        (editor (& repl editor)))
    (layout log)
    (set! (position-y log)
          (max (- (height repl) (height log)) (height editor)))
    (place-below log editor)))

(define-method (refresh-prompt (repl <repl>))
  (set! (prompt (& repl editor))
        (if (= (depth repl) 0)
            (format #f "~a@~a> "
                    (language-name (language repl))
                    (module-name (module repl)))
            (format #f "~a@~a [~a]> "
                    (language-name (language repl))
                    (module-name (module repl))
                    (depth repl)))))

(define-method (resize-repl (repl <repl>) w h)
  (let ((bg (& repl background)))
    (set! (width repl) w)
    (set! (height repl) h)
    (set! (painter bg)
          (with-style ((fill-color %background-color))
            (fill
             (rectangle (vec2 0.0 0.0) w h))))
    (resize bg)
    (refresh-log repl)))

(define-method (repl-read-expression (repl <repl>) line)
  (call-with-input-string line
    (lambda (port)
      ((language-reader (language repl)) port (module repl)))))

(define-method (with-output-to-log (repl <repl>) thunk)
  (let* ((vals #f)
         (str (call-with-output-string
                (lambda (port)
                  (parameterize ((current-output-port port)
                                 (current-error-port port))
                    (set! vals (call-with-values thunk list)))))))
    (unless (string-null? str)
      (log-append repl str))
    (apply values vals)))

(define-method (with-error-handling (repl <repl>) thunk)
  (let ((stack #f))
    (define (handle-error e)
      (let* ((key (exception-kind e))
             (args (exception-args e))
             (frame (and stack (stack-ref stack 0))))
        (define (enter-debugger)
          (print-exception (current-output-port)
                           frame key args)
          (newline)
          (display "Entering a new prompt. ")
          (display "Type `,bt' for a backtrace or `,q' to continue.")
          (newline)
          (push-repl-level repl (make <repl-level>
                                  #:language (language repl)
                                  #:module (module repl)
                                  #:depth (+ (depth repl) 1)
                                  #:debug (make <repl-debug>
                                            #:stack stack)))
          ;; So nothing gets printed as a return value.
          *unspecified*)
        (with-output-to-log repl enter-debugger)))
    (define (pre-unwind-handler . args)
      (set! stack (make-stack #t 4)))
    (define (throw-handler)
      (with-throw-handler #t thunk pre-unwind-handler))
    (define (exception-handler e)
      (if (quit-exception? e)
          (raise-exception e)
          (handle-error e)))
    (with-exception-handler exception-handler throw-handler #:unwind? #t)))

(define-method (repl-compile (repl <repl>) line)
  (define thunk
    (load-thunk-from-memory
     (compile (repl-read-expression repl line)
              #:from (language repl)
              #:to 'bytecode
              #:env (module repl))))
  (define (compile-line)
    (with-output-to-log repl thunk))
  (with-error-handling repl compile-line))

(define-method (write-value-to-log (repl <repl>) x)
  (unless (unspecified? x)
    (log-append repl (make <horizontal-container>
                       #:children
                       (list (make <label> #:text "=> ")
                             (repl-print x))))))

(define (skip-whitespace str i)
  (let loop ((i i))
    (cond
     ((= i (string-length str))
      (- i 1))
     ((char-whitespace? (string-ref str i))
      (loop (+ i 1)))
     (else
      i))))

(define (find-whitespace str i)
  (let loop ((i i))
    (cond
     ((= i (string-length str))
      i)
     ((char-whitespace? (string-ref str i))
      i)
     (else
      (loop (+ i 1))))))

(define (meta-command-string? str)
  (and (not (string-null? str))
       (eqv? (string-ref str (skip-whitespace str 0)) #\,)))

(define (parse-meta-command str)
  (let* ((i (skip-whitespace str 0))
         (j (find-whitespace str i)))
    (cons (substring str i j)
          (call-with-input-string (substring str j)
            (lambda (port)
              (let loop ()
                (let ((exp (read port)))
                  (if (eof-object? exp)
                      '()
                      (cons exp (loop))))))))))

(define-method (meta-command (repl <repl>) line)
  (match (parse-meta-command line)
    ((name args ...)
     (let ((meta (lookup-meta-command name)))
       (if meta
           (with-error-handling repl
             (lambda ()
               (with-output-to-log repl
                                   (lambda ()
                                     (apply-meta-command meta repl args)))))
           (log-append repl
                       (string-append "Unknown meta-command: "
                                      name)))))))

(define-method (repl-eval (repl <repl>))
  (let* ((editor (& repl editor))
         (line (get-line editor)))
    (save-to-history editor)
    (log-append repl (string-append (prompt editor) line))
    (if (meta-command-string? line)
        (meta-command repl line)
        (for-each (lambda (val)
                    (write-value-to-log repl val))
                  (call-with-values (lambda () (repl-compile repl line)) list)))
    (clear-line editor)
    (refresh-log repl)
    (refresh-prompt repl)))


;;;
;;; Meta commands
;;;

(define-record-type <meta-command>
  (make-meta-command name aliases category docstring proc)
  meta-command?
  (name meta-command-name)
  (aliases meta-command-aliases)
  (category meta-command-category)
  (docstring meta-command-docstring)
  (proc meta-command-proc))

(define (apply-meta-command meta repl args)
  (apply (meta-command-proc meta) repl args))

(define *meta-commands* '())

(define (lookup-meta-command name)
  (find (lambda (m)
          (or (string=? (meta-command-name m) name)
              (any (lambda (alias)
                     (string=? alias name))
                   (meta-command-aliases m))))
        *meta-commands*))

(define (add-meta-command! name aliases category docstring proc)
  (set! *meta-commands*
        (cons (make-meta-command name aliases category docstring proc)
              *meta-commands*)))

(define (symbol->meta-command sym)
  (string-append "," (symbol->string sym)))

(define-syntax define-meta-command
  (syntax-rules ()
    ((_ ((name aliases ...) category repl args ...) docstring body ...)
     (add-meta-command! (symbol->meta-command 'name)
                        (map symbol->meta-command '(aliases ...))
                        'category
                        docstring
                        (lambda* (repl args ...)
                          body ...)))
    ((_ (name category repl args ...) docstring body ...)
     (add-meta-command! (symbol->meta-command 'name)
                        '()
                        'category
                        docstring
                        (lambda* (repl args ...)
                          body ...)))))

(define-meta-command (help help repl)
  "- Show this help information."
  (for-each (lambda (m)
              (match (meta-command-aliases m)
                (()
                 (log-append repl
                             (format #f "~a ~a"
                                     (meta-command-name m)
                                     (meta-command-docstring m))))
                (aliases
                 (log-append repl
                             (format #f "~a ~a ~a"
                                     (meta-command-name m)
                                     aliases
                                     (meta-command-docstring m))))))
            (sort *meta-commands*
                  (lambda (a b)
                    (string<? (meta-command-name a)
                              (meta-command-name b))))))

(define-meta-command ((quit q) system repl)
  "- Quit program."
  (pop-repl-level repl))

(define-meta-command ((import use) module repl module-name)
  "MODULE - Import a module."
  (module-use! (module repl) (resolve-module module-name)))

(define-meta-command ((module m) module repl #:optional module-name*)
  "[MODULE] - Change current module or show current module."
  (if module-name*
      (set! (module (level repl)) (resolve-module module-name*))
      (log-append repl (format #f "~a" (module-name (module repl))))))


;;;
;;; REPL major mode
;;;

(define-class <repl-mode> (<major-mode>)
  (prev-keyboard-focus #:accessor prev-keyboard-focus #:init-value #f))

(define (repl mode)
  (& (parent mode) repl))

(define-method (on-enter (mode <repl-mode>))
  (let* ((scene (parent mode))
         (region (car (regions scene)))
         (repl (or (& (parent mode) repl)
                   (make <repl>
                     #:name 'repl))))
    (unless (parent repl)
      (attach-to (parent mode) repl))
    (show repl)
    (resize-repl repl (area-width region) (area-height region))
    (set! (prev-keyboard-focus mode) (current-keyboard-focus))
    (take-keyboard-focus region)
    (add-minor-mode scene (make <line-edit-mode>
                            #:editor (& repl editor)))))

(define-method (close-repl (mode <repl-mode>))
  (let ((scene (parent mode)))
    (hide (& scene repl))
    (take-keyboard-focus (prev-keyboard-focus mode))
    (remove-minor-mode (parent mode) <line-edit-mode>)
    (pop-major-mode scene)))

(define-method (eval-expression (mode <repl-mode>))
  (repl-eval (repl mode)))

(bind-input <repl-mode> (key-press 'escape) close-repl)
(bind-input <repl-mode> (key-press 'g '(ctrl)) close-repl)
(bind-input <repl-mode> (key-press 'return) eval-expression)