From 72c76fb7b6f1b99c654ae9b8deee0dacfda6a7d5 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Mon, 27 Mar 2023 08:31:59 -0400
Subject: Allow REPL to render more than just text.

---
 catbird/repl.scm | 130 +++++++++++++++++++++++++++++++++++++++----------------
 1 file 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))))))
 
 
 ;;;
-- 
cgit v1.2.3