summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2021-09-13 08:19:25 -0400
committerDavid Thompson <dthompson2@worcester.edu>2021-09-13 08:19:25 -0400
commitdcc07a578042b79de90c0c168596a916fe97c8d7 (patch)
tree390469e6adbadb2b7961ece6f0f9c04e06c086e4
parentf35eb7269743a0433a2bcf21acac6f6b956d34fe (diff)
Add asynchronous REPL implementation.
-rw-r--r--Makefile.am1
-rw-r--r--chickadee/async-repl.scm212
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))