path: root/catbird/repl.scm

;;; Catbird Game Engine
;;; Copyright © 2022 David Thompson <davet@gnu.org>
;;;
;;; 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:
;;
;; In-engine asynchronous REPL implementation.
;;
;;; Code:
(define-module (catbird repl)
  #:use-module (catbird asset)
  #: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 pushdown)
  #: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 frame)
  #:use-module (system vm loader)
  #:use-module (system vm program)
  #:export (<repl>
            <repl-mode>
            resize-repl
            repl-print))

;; TODO: $number values like regular Guile REPL
;; TODO: Debugger
;; TODO: Switching languages
;; TODO: Describe, apropos commands
;; TODO: <node-2d> printer


;;;
;;; 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-method (repl-print (asset <asset>))
  (make <horizontal-container>
    #:children
    (list (make <label>
            #:text (format #f "#<~a " (class-name (class-of asset))))
          (repl-print (artifact asset))
          (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-state #:getter level-state #:init-thunk make-pushdown-state))

(define-method (level (repl <repl>))
  (state-current (level-state repl)))

(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)
  (state-push! (level-state repl) (make <repl-level>))
  (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>))
  (state-push! (level-state repl) new-level))

(define-method (pop-repl-level (repl <repl>))
  (state-pop! (level-state repl))
  (unless (state-current (level-state repl))
    (detach repl)))

(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-expressions (repl <repl>) line)
  (let ((read* (language-reader (language repl))))
    (call-with-input-string line
      (lambda (port)
        (let loop ()
          (let ((exp (read* port (module repl))))
            (if (eof-object? exp)
                '()
                (cons exp (loop)))))))))

(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.
          (values))
        (with-output-to-log repl enter-debugger)))
    (define (pre-unwind-handler . args)
      ;; Get stack tag.
      (let ((tag (and (pair? (fluid-ref %stacks))
                      (cdr (fluid-ref %stacks)))))
        (set! stack (make-stack #t
                                ;; Remove 3 inner stack frames added by the
                                ;; error handling code.
                                3
                                ;; Remove outer stack frames up to the
                                ;; start of the most recent stack.
                                tag
                                ;; And one more frame, because %start-stack
                                ;; invoking the start-stack thunk has its own frame
                                ;; too.
                                0 (and tag 1)))))
    (define (throw-handler)
      (with-throw-handler #t
        (lambda () (start-stack #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 (compile-and-eval exp)
    (define thunk
      (load-thunk-from-memory
       (compile exp
                #:from (language repl)
                #:to 'bytecode
                #:env (module repl))))
    (save-module-excursion
     (lambda ()
       (set-current-module (module repl))
       (call-with-values (lambda () (with-error-handling repl thunk)) list))))
  (define (compile-line)
    (append-map (lambda (exp)
                  (compile-and-eval exp))
                (repl-read-expressions repl line)))
  (with-output-to-log 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))
                  (repl-compile repl line)))
    (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))))))

(define-meta-command ((backtrace bt) debug repl)
  "Print a backtrace."
  (let ((dbg (debug repl)))
    (if dbg
        (let ((stack (stack dbg)))
          (let loop ((i (- (stack-length stack) 1))
                     (prev-file ""))
            (when (>= i 0)
              (let* ((frame (stack-ref stack i))
                     (source (frame-source frame))
                     (file (or (and source (source:file source)) "<unknown port>")))
                (unless (string=? file prev-file)
                  (log-append repl (format #f "In ~a:" file)))
                (if source
                    (let ((text (format #f "  ~a:~a ~a ~a"
                                        (source:line-for-user source)
                                        (source:column source)
                                        i
                                        (frame-call-representation frame)))
                          (uri (format #f "file://~a:~a:~a"
                                       (%search-load-path file)
                                       (source:line-for-user source)
                                       (source:column source))))
                      (log-append repl (make <link>
                                         #:uri uri
                                         #:text text)))
                    (log-append repl (format #f "      ~a ~a" i
                                             (frame-procedure-name frame))))
                (loop (- i 1) file)))))
        (log-append repl "not in a debugger"))))


;;;
;;; 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)