repl: Add really crappy exception handling.

1 files changed, 42 insertions, 24 deletions

diff --git a/starling/repl.scm b/starling/repl.scm
index 47947c0..b972b5f 100644
--- a/starling/repl.scm
+++ b/starling/repl.scm
@@ -27,6 +27,7 @@
   #:use-module (chickadee math rect)
   #:use-module (chickadee math vector)
   #:use-module (chickadee scripting)
+  #:use-module (ice-9 control)
   #:use-module (ice-9 eval-string)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
@@ -63,35 +64,52 @@
     (modify-user-text repl
                       (substring text 0 (max (- (string-length text) 1) 0)))))
 
-(define-method (eval-user-text (repl <repl>))
-  (let* ((result #f)
-         (output (with-output-to-string
-                   (lambda ()
-                     (set! result (eval-string (user-text repl)
-                                               #:module (module repl))))))
-         (log (log repl)))
-    (for-each (lambda (line)
-                (ring-buffer-put! log line))
-              (let ((result-text (if (unspecified? result)
-                                     ""
-                                     (with-output-to-string
-                                       (lambda ()
-                                         (display "=> ")
-                                         (write result))))))
-                (match (string-split (string-append (text (& repl prompt))
-                                                    "\n" output result-text)
-                                     #\newline)
-                  ;; Drop trailing newlines
-                  ((lines ... "") lines)
-                  (lines lines))))
+(define-method (print (repl <repl>) s)
+  (for-each (lambda (line)
+              (ring-buffer-put! (log repl) line))
+            (match (string-split s #\newline)
+              ;; Drop trailing newlines
+              ((lines ... "") lines)
+              (lines lines))))
+
+(define-method (flush-log (repl <repl>))
+  (let ((log (log repl)))
     (let loop ((i 0)
                (labels (lines repl)))
       (when (< i (ring-buffer-length log))
         (match labels
           ((label . rest)
            (set! (text label) (ring-buffer-ref log i))
-           (loop (+ i 1) rest)))))
-    (modify-user-text repl "")))
+           (loop (+ i 1) rest)))))))
+
+(define-method (eval-user-text (repl <repl>))
+  (let ((result *unspecified*))
+    (values (with-output-to-string
+              (lambda ()
+                (set! result
+                  (let/ec cancel
+                    (start-stack 'repl-stack
+                                 (with-exception-handler (lambda (exception)
+                                                           ;;(backtrace)
+                                                           (display exception)
+                                                           (cancel *unspecified*))
+                                   (lambda ()
+                                     (eval-string (user-text repl)
+                                                  #:module (module repl)))))))))
+            result)))
+
+(define-method (eval-and-print (repl <repl>))
+  (call-with-values (lambda () (eval-user-text repl))
+    (lambda (output result)
+      (print repl (text (& repl prompt)))
+      (print repl output)
+      (unless (unspecified? result)
+        (print repl (with-output-to-string
+                      (lambda ()
+                        (display "=> ")
+                        (write result)))))
+      (flush-log repl)
+      (modify-user-text repl ""))))
 
 (define-method (on-boot (repl <repl>))
   (let* ((res (resolution (car (cameras repl))))
@@ -138,7 +156,7 @@
   (match key
     ('escape (close-repl repl))
     ('backspace (backward-delete repl))
-    ('return (eval-user-text repl))
+    ('return (eval-and-print repl))
     (_ #f)))
 
 (define-method (on-text-input (repl <repl>) text)