repl: Add nested REPL support and start of a debugger.

1 files changed, 65 insertions, 36 deletions

diff --git a/catbird/repl.scm b/catbird/repl.scm
index 3c56f35..c281411 100644
--- a/catbird/repl.scm
+++ b/catbird/repl.scm
@@ -114,11 +114,32 @@
     (beautify-user-module! module)
     module))
 
+(define-class <repl-debug> ()
+  (stack #:accessor stack #:init-keyword #:stack))
+
+(define-class <repl-level> ()
+  (depth #:accessor depth #:init-keyword #:depth #:init-value 0)
+  (language #:accessor language #:init-keyword #:language
+            #:init-value (lookup-language 'scheme))
+  (module #:accessor module #:init-keyword #:module
+          #:init-thunk make-user-module)
+  (debug #:accessor debug #:init-keyword #:debug #:init-value #f))
+
 (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)))
+  (level #:accessor level #:init-form (make <repl-level>))
+  (level-stack #:accessor level-stack #:init-value '()))
+
+(define-method (language (repl <repl>))
+  (language (level repl)))
+
+(define-method (module (repl <repl>))
+  (module (level repl)))
+
+(define-method (depth (repl <repl>))
+  (depth (level repl)))
+
+(define-method (debug (repl <repl>))
+  (debug (level repl)))
 
 (define-method (initialize (repl <repl>) initargs)
   (next-method)
@@ -134,6 +155,17 @@
   (log-append repl "Enter ',help' for help.")
   (refresh-prompt repl))
 
+(define-method (push-repl-level (repl <repl>) (new-level <repl-level>))
+  (set! (level-stack repl) (cons (level repl) (level-stack repl)))
+  (set! (level repl) new-level))
+
+(define-method (pop-repl-level (repl <repl>))
+  (match (level-stack repl)
+    (() (detach repl))
+    ((prev . rest)
+     (set! (level repl) prev)
+     (set! (level-stack repl) rest))))
+
 (define-method (log-append (repl <repl>) node)
   (let ((container (make <margin-container>
                      #:margin 2.0
@@ -154,9 +186,14 @@
 
 (define-method (refresh-prompt (repl <repl>))
   (set! (prompt (& repl editor))
-        (format #f "~a@~a> "
-                (language-name (language repl))
-                (module-name (module repl)))))
+        (if (= (depth repl) 0)
+            (format #f "~a@~a> "
+                    (language-name (language repl))
+                    (module-name (module repl)))
+            (format #f "~a@~a [~a]> "
+                    (language-name (language repl))
+                    (module-name (module repl))
+                    (depth repl)))))
 
 (define-method (resize-repl (repl <repl>) w h)
   (let ((bg (& repl background)))
@@ -188,33 +225,25 @@
 (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))))))
+      (let* ((key (exception-kind e))
+             (args (exception-args e))
+             (frame (and stack (stack-ref stack 0))))
+        (define (enter-debugger)
+          (print-exception (current-output-port)
+                           frame key args)
+          (newline)
+          (display "Entering a new prompt. ")
+          (display "Type `,bt' for a backtrace or `,q' to continue.")
+          (newline)
+          (push-repl-level repl (make <repl-level>
+                                  #:language (language repl)
+                                  #:module (module repl)
+                                  #:depth (+ (depth repl) 1)
+                                  #:debug (make <repl-debug>
+                                            #:stack stack)))
+          ;; So nothing gets printed as a return value.
+          *unspecified*)
+        (with-output-to-log repl enter-debugger)))
     (define (pre-unwind-handler . args)
       (set! stack (make-stack #t 4)))
     (define (throw-handler)
@@ -381,7 +410,7 @@
 
 (define-meta-command ((quit q) system repl)
   "- Quit program."
-  (abort-game))
+  (pop-repl-level repl))
 
 (define-meta-command ((import use) module repl module-name)
   "MODULE - Import a module."
@@ -390,7 +419,7 @@
 (define-meta-command ((module m) module repl #:optional module-name*)
   "[MODULE] - Change current module or show current module."
   (if module-name*
-      (set! (module repl) (resolve-module module-name*))
+      (set! (module (level repl)) (resolve-module module-name*))
       (log-append repl (format #f "~a" (module-name (module repl))))))