diff options
Diffstat (limited to 'catbird/repl.scm')
-rw-r--r-- | catbird/repl.scm | 349 |
1 files changed, 349 insertions, 0 deletions
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) |