From 14464dee966fe415d4c8e1fb8b5205653b22003f Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Mon, 3 Oct 2022 19:22:23 -0400
Subject: Add prototype catbird modules.

---
 catbird/repl.scm | 349 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 349 insertions(+)
 create mode 100644 catbird/repl.scm

(limited to 'catbird/repl.scm')

diff --git a/catbird/repl.scm b/catbird/repl.scm
new file mode 100644
index 0000000..d3c2197
--- /dev/null
+++ b/catbird/repl.scm
@@ -0,0 +1,349 @@
+;; TODO: Multiple values
+;; TODO: Multiple expressions
+;; TODO: Debugger
+;; TODO: Switching languages
+(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 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))
+
+(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)
+  (set! (width repl) w)
+  (set! (height repl) h)
+  (set! (painter (& repl background))
+        (with-style ((fill-color %background-color))
+          (fill
+           (rectangle (vec2 0.0 0.0) w h))))
+  (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."
+  (exit-catbird))
+
+(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)
-- 
cgit v1.2.3