diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | chickadee/async-repl.scm | 212 |
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)) |