Add asynchronous REPL implementation.

2 files changed, 213 insertions, 0 deletions

diff --git a/Makefile.am b/Makefile.am
index 5164774..f7c959d 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -49,6 +49,7 @@ SOURCES = 					\
   chickadee/queue.scm				\
   chickadee/freetype.scm			\
   chickadee/readline.scm			\
+  chickadee/async-repl.scm			\
   chickadee/math.scm				\
   chickadee/math/vector.scm			\
   chickadee/math/bezier.scm			\
diff --git a/chickadee/async-repl.scm b/chickadee/async-repl.scm
new file mode 100644
index 0000000..328e8f8
--- /dev/null
+++ b/chickadee/async-repl.scm
@@ -0,0 +1,212 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2021 David Thompson <davet@gnu.org>
+;;;
+;;; Chickadee 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.
+;;;
+;;; Chickadee 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, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary
+;;
+;; Non-blocking terminal REPL with readline support.
+;;
+;;; Code:
+
+(define-module (chickadee async-repl)
+  #:use-module (chickadee readline)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 suspendable-ports)
+  #:use-module (srfi srfi-9)
+  #:use-module (system base language)
+  #:use-module (system repl common)
+  #:use-module (system repl debug)
+  #:export (make-async-repl
+            async-repl?
+            set-async-repl-debug!
+            start-async-debugger
+            start-async-repl
+            update-async-repl
+            close-async-repl))
+
+;; Need to access some private API things.
+(define run-repl* (@@ (system repl repl) run-repl*))
+(define meta-command-token (@@ (system repl repl) meta-command-token))
+
+(define %async-repl-prompt-tag (make-prompt-tag 'async-repl))
+
+(define-record-type <async-repl>
+  (%make-async-repl input-port output-port)
+  async-repl?
+  (input-port async-repl-input-port)
+  (output-port async-repl-output-port)
+  (state async-repl-state set-async-repl-state!)
+  (cont async-repl-cont set-async-repl-cont!)
+  (debug async-repl-debug set-async-repl-debug!)  )
+
+(define (async-repl-waiting? repl)
+  (eq? (async-repl-state repl) 'waiting))
+
+(define (async-repl-ready? repl)
+  (eq? (async-repl-state repl) 'ready))
+
+(define (async-repl-send repl line)
+  (let ((output-port (async-repl-output-port repl)))
+    (add-readline-history line)
+    (display line output-port)
+    (newline output-port)
+    (force-output output-port)
+    (set-async-repl-state! repl 'ready)))
+
+(define* (make-async-repl)
+  ;; Need non-blocking I/O.
+  (install-suspendable-ports!)
+  ;; Our REPL is not going to read from standard input, but instead
+  ;; from the input port of a pipe.  Readline will read from
+  ;; standard input and then we will pass that text along through
+  ;; the pipe to the REPL.
+  (match (pipe)
+    ((input-port . output-port)
+     ;; Set input port to non-blocking mode.
+     (let ((flags (fcntl input-port F_GETFL)))
+       (fcntl input-port F_SETFL (logior O_NONBLOCK flags)))
+     (%make-async-repl input-port output-port))))
+
+(define* (async-repl-prompt repl prompt)
+  (install-readline-handler prompt
+                            (lambda (line)
+                              (async-repl-send repl line)
+                              (remove-readline-handler)))
+  (set-async-repl-state! repl 'waiting)
+  ;; Suspend the REPL until readline tells us that the user has
+  ;; input a new line.
+  (abort-to-prompt %async-repl-prompt-tag (current-dynamic-state)))
+
+(define (run-async-repl repl debug)
+  (define (repl-read repl*)
+    (define (flush-leading-whitespace)
+      (let ((c (peek-char)))
+        (cond
+         ((eof-object? c) #t)
+         ((char-whitespace? c)
+          (read-char)
+          (flush-leading-whitespace))
+         (else #t))))
+    (define (read-expression)
+      (when (char-ready?)
+        (flush-leading-whitespace)
+        (let ((c (peek-char)))
+          (cond
+           ((eof-object? c) ; end of file
+            (pk 'eof)
+            (read-char)
+            *unspecified*)
+           ((eqv? c #\,) ; metacommand
+            (read-char) ; need to read first char
+            meta-command-token)
+           ((eqv? c #\;) ; comment
+            (read-line)
+            *unspecified*)
+           (else ; read code using current language reader
+            (parameterize ((current-read-waiter
+                            (lambda (port)
+                              ;; If 'read' doesn't complete because it
+                              ;; needs more input, then prompt the user
+                              ;; for another line.
+                              (async-repl-prompt repl "...> "))))
+              (let ((read (language-reader (repl-language repl*))))
+                (read (current-input-port) (current-module)))))))))
+    ;; Check if there are more expressions to process from the
+    ;; previous user input before prompting for new input.
+    (if (char-ready?)
+        (read-expression)
+        (let ((debug (async-repl-debug repl)))
+          ;; If we have debug info then it's time to launch a sub-REPL to
+          ;; do the debugging.
+          (when debug
+            (set-async-repl-debug! repl #f)
+            (format #t "~a~%" (debug-error-message debug))
+            (format #t "Entering a new prompt.  ")
+            (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
+            (run-async-repl repl debug))
+          (async-repl-prompt repl (repl-prompt repl*))
+          (read-expression))))
+  (define (error-string stack key args)
+    (call-with-output-string
+      (lambda (port)
+        (let ((frame (and (< 0 (vector-length stack)) (vector-ref stack 0))))
+          (print-exception port frame key args)))))
+  (define (on-error key . args)
+    (unless (eq? key 'quit)
+      (let* ((tag (and (pair? (fluid-ref %stacks))
+                       (cdr (fluid-ref %stacks))))
+             (stack (narrow-stack->vector
+                     (make-stack #t)
+                     ;; Cut three frames from the top of the stack:
+                     ;; make-stack, this one, and the throw handler.
+                     3
+                     ;; Narrow the end of the stack to the most recent
+                     ;; start-stack.
+                     tag
+                     ;; And one more frame, because %start-stack invoking
+                     ;; the start-stack thunk has its own frame too.
+                     0 (and tag 1)))
+             (debug (make-debug stack 0 (error-string stack key args))))
+        ;; We cannot jump right into the debugger REPL here because
+        ;; there are C frames in the stack.  This means that we cannot
+        ;; resume any continuations we create via abort-to-prompt.
+        ;; Instead, we record the debugger object so that the next
+        ;; time the REPL reader procedure is called we can jump
+        ;; straight into a debugging REPL.
+        (set-async-repl-debug! repl debug))))
+  ;; The user can change the module from inside the REPL, and we don't
+  ;; want that to affect the outside environment when the user exits
+  ;; the REPL.
+  (save-module-excursion
+   (lambda ()
+     (let ((repl* (make-repl (current-language) debug)))
+       ;; The REPL implementation allows custom procedures for the on-error
+       ;; handler, but the validator only accepts symbols!  So, we just
+       ;; mutate the dang options ourselves.
+       (match (assq 'on-error (repl-options repl*))
+         ((_ . spec)
+          (set-car! spec on-error)))
+       (run-repl* repl* repl-read)))))
+
+(define* (start-async-repl repl #:optional (on-quit (const #t)))
+  (bind-readline-variable "blink-matching-paren" "on")
+  (parameterize ((current-input-port (async-repl-input-port repl)))
+    (define-syntax-rule (with-repl-prompt body ...)
+      (call-with-prompt %async-repl-prompt-tag
+        (lambda () body ...)
+        handler))
+    (define (handler k state)
+      (define (resume)
+        (with-repl-prompt (with-dynamic-state state k)))
+      (set-async-repl-cont! repl resume))
+    (with-repl-prompt
+     (run-async-repl repl #f)
+     (on-quit))))
+
+(define (update-async-repl repl)
+  (when (and (async-repl-waiting? repl) (char-ready?))
+    (readline-read-char)
+    (when (async-repl-ready? repl)
+      (set-async-repl-state! repl 'running)
+      ((async-repl-cont repl)))))
+
+(define (close-async-repl repl)
+  (close-port (async-repl-input-port repl))
+  (close-port (async-repl-output-port repl))
+  (remove-readline-handler)
+  (newline))