diff options
| -rw-r--r-- | catbird/repl.scm | 130 |
1 files changed, 92 insertions, 38 deletions
diff --git a/catbird/repl.scm b/catbird/repl.scm index 7378ecf..d3768b5 100644 --- a/catbird/repl.scm +++ b/catbird/repl.scm @@ -28,10 +28,12 @@ #:use-module (catbird region) #:use-module (catbird ring-buffer) #:use-module (catbird scene) + #:use-module (catbird ui) #:use-module (chickadee) #:use-module (chickadee graphics color) #:use-module (chickadee graphics path) #:use-module (chickadee graphics text) + #:use-module (chickadee graphics texture) #:use-module (chickadee math vector) #:use-module (ice-9 exceptions) #:use-module (ice-9 match) @@ -42,13 +44,68 @@ #:use-module (system base language) #:export (<repl> <repl-mode> - resize-repl)) + resize-repl + repl-print)) ;; TODO: Multiple values ;; TODO: Multiple expressions ;; TODO: Debugger ;; TODO: Switching languages + +;;; +;;; Graphical Printers +;;; + +(define-method (repl-print obj) + (make <label> #:text (with-output-to-string (lambda () (write obj))))) + +(define-method (repl-print (pair <pair>)) + (let ((open (make <label> #:text "(")) + (close (make <label> #:text ")"))) + (make <horizontal-container> + #:children (match pair + ((vals ...) + `(,open + ,@(let loop ((vals vals)) + (match vals + (() '()) + ((x) + (list (repl-print x))) + ((x . rest) + (append (list (repl-print x) + (make <label> #:text " ")) + (loop rest))))) + ,close)) + ((first . second) + (list open + (repl-print first) + (make <label> #:text " . ") + (repl-print second) + close)))))) + +(define-method (repl-print (v <vector>)) + (make <horizontal-container> + #:children `(,(make <label> #:text "#(") + ,@(let loop ((i 0)) + (when (< i (vector-length v)) + (let ((x (vector-ref v i))) + (if (= i (- (vector-length v) 1)) + (list (repl-print x)) + (cons* (repl-print x) + (make <label> #:text " ") + (loop (+ i 1))))))) + ,(make <label> #:text ")")))) + +(define <texture> (class-of null-texture)) +(define-method (repl-print (texture <texture>)) + (make <sprite> #:texture texture)) + + +;;; +;;; REPL +;;; + (define %background-color (make-color 0.0 0.0 0.0 0.9)) (define (make-user-module) @@ -62,11 +119,12 @@ (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>)) +(define-method (initialize (repl <repl>) initargs) + (next-method) (attach-to repl (make <canvas> #:name 'background) - (make <label> + (make <vertical-container> #:name 'log #:rank 1) (make <line-editor> @@ -75,33 +133,23 @@ (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 (log-append (repl <repl>) node) + (let ((container (make <margin-container> + #:margin 2.0 + #:children (list node)))) + (attach-to (& repl log) container) + (refresh-log repl))) + +(define-method (log-append (repl <repl>) (text <string>)) + (log-append repl (make <label> #:text text))) (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)))) + (let ((log (& repl log)) + (editor (& repl editor))) + (layout log) + (set! (position-y log) + (max (- (height repl) (height log)) (height editor))) + (place-below log editor))) (define-method (refresh-prompt (repl <repl>)) (set! (prompt (& repl editor)) @@ -127,9 +175,11 @@ (define-method (with-output-to-log (repl <repl>) thunk) (let* ((val *unspecified*) - (str (with-output-to-string - (lambda () - (set! val (thunk)))))) + (str (call-with-output-string + (lambda (port) + (parameterize ((current-output-port port) + (current-error-port port)) + (set! val (thunk))))))) (unless (string-null? str) (for-each (lambda (line) (log-append repl line)) @@ -187,7 +237,7 @@ (define-method (write-value-to-log (repl <repl>) x) (unless (unspecified? x) - (with-output-to-log repl (lambda () (write x))))) + (log-append repl (repl-print x)))) (define (skip-whitespace str i) (let loop ((i i)) @@ -232,8 +282,12 @@ (if meta (with-error-handling repl (lambda () - (apply-meta-command meta repl args))) - (log-append repl (string-append "Unknown meta-command: " name))))))) + (with-output-to-log 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)) @@ -327,11 +381,11 @@ "MODULE - Import a module." (module-use! (module repl) (resolve-module module-name))) -(define-meta-command ((module m) module repl #:optional 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)))) + (if module-name* + (set! (module repl) (resolve-module module-name*)) + (log-append repl (format #f "~a" (module-name (module repl)))))) ;;; |