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 (chickadee)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics path)
  #:use-module (chickadee graphics text)
  #: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)
  #:export (<repl>
            <repl-mode>
            resize-repl))

;; TODO: Multiple values
;; TODO: Multiple expressions
;; TODO: Debugger
;; TODO: Switching languages

(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> (<node-2d>)
  (language #:accessor language #:init-value (lookup-language 'scheme))
  (module #:accessor module #:init-thunk make-user-module)
  (max-line-length #:accessor max-line-length #:init-value 256)
  (log-lines #:accessor log-lines #:init-form (make-ring-buffer 64)))

(define-method (on-boot (repl <repl>))
  (attach-to repl
             (make <canvas>
               #:name 'background)
             (make <label>
               #:name 'log
               #:rank 1)
             (make <line-editor>
               #:name 'editor
               #:rank 1))
  (log-append repl "Enter ',help' for help.")
  (refresh-prompt repl))

(define-method (log-append (repl <repl>) line)
  (ring-buffer-put! (log-lines repl)
                    ;; Truncate long lines
                    (if (> (string-length line) (max-line-length repl))
                        (substring line 0 (max-line-length repl))
                        line))
  (refresh-log repl))

(define-method (concatenate-log (repl <repl>))
  (let ((n (- (inexact->exact
               (floor
                (/ (height repl)
                   (font-line-height (font (& repl log))))))
              1))
        (lines (log-lines repl)))
    (string-join (let loop ((i (max (- (ring-buffer-length lines) n) 0)))
                   (if (< i (ring-buffer-length lines))
                       (cons (ring-buffer-ref lines i)
                             (loop (+ i 1)))
                       '()))
                 "\n")))

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

(define-method (refresh-prompt (repl <repl>))
  (set! (prompt (& repl editor))
        (format #f "~a@~a> "
                (language-name (language repl))
                (module-name (module 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* ((val *unspecified*)
         (str (with-output-to-string
                (lambda ()
                  (set! val (thunk))))))
    (unless (string-null? str)
      (for-each (lambda (line)
                  (log-append repl line))
                (string-split str #\newline)))
    val))

(define-method (with-error-handling (repl <repl>) thunk)
  (let ((stack #f))
    (define (handle-error e)
      (let ((frame (stack-ref stack 0)))
        (log-append repl
                    (format #f "~a: In procedure: ~a:"
                            (match (frame-source frame)
                              ((_ file-name line . column)
                               (format #f "~a:~a:~a"
                                       (if file-name
                                           (basename file-name)
                                           "unknown file")
                                       line column))
                              (_ "unknown"))
                            (or (frame-procedure-name frame)
                                "unknown")))
        (log-append repl
                    (format #f "In procedure: ~a: ~a"
                            (or (and (exception-with-origin? e)
                                     (exception-origin e))
                                "unknown")
                            (if (and (exception-with-message? e)
                                     (exception-with-irritants? e))
                                (apply format #f (exception-message e)
                                       (exception-irritants e))
                                "")))
        (with-output-to-log repl
                            (lambda ()
                              (display-backtrace stack
                                                 (current-output-port))))))
    (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 (compile-line)
    (with-output-to-log repl
                        (lambda ()
                          (compile (repl-read-expression repl line)
                                   #:from (language repl)
                                   #:env (module repl)))))
  (with-error-handling repl compile-line))

(define-method (write-value-to-log (repl <repl>) x)
  (unless (unspecified? x)
    (with-output-to-log repl (lambda () (write 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 ()
               (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)
        (write-value-to-log repl (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."
  (abort-game))

(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
      (log-append repl (format #f "~a" (module-name (module repl))))
      (set! (module repl) (resolve-module module-name))))

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