Open in-engine REPL upon error.

3 files changed, 93 insertions, 106 deletions

diff --git a/catbird/kernel.scm b/catbird/kernel.scm
index 5dc31a1..6560d47 100644
--- a/catbird/kernel.scm
+++ b/catbird/kernel.scm
@@ -48,6 +48,8 @@
             current-controller-focus
             current-kernel
             current-keyboard-focus
+            default-error-handler
+            error-handler
             find-region-by-name
             frames-per-second
             kill-region
@@ -307,78 +309,22 @@
 ;;; Error handling
 ;;;
 
-(define-method (on-error (kernel <kernel>) e s)
+(define (default-error-handler exception stack)
+  (when (quit-exception? exception)
+    (raise-exception exception))
+  (let ((port (current-error-port))
+        (key (exception-kind exception))
+        (args (exception-args exception)))
+    (print-exception port (stack-ref stack 0) key args)
+    (display "Backtrace:\n" port)
+    (display-backtrace stack port)
+    (newline port)))
+
+(define-method (on-error (kernel <kernel>) exception stack)
   (if developer-mode?
-      (let* ((window (current-window))
-             (title (window-title window)))
-        (set-window-title! window (string-append "[ERROR] " title))
-        (set! (stack kernel) s)
-        (set! (exception kernel) e)
-        (set! (debugging? kernel) #t)
-        (let ((port (current-error-port)))
-          (display "an error has occurred!\n\n" port)
-          (display "Backtrace:\n" port)
-          (display-backtrace s port)
-          (newline port)
-          (display (error-message kernel) port)
-          (newline port))
-        (display "waiting for developer to debug..." (current-error-port))
-        (while (debugging? kernel)
-          (poll-coop-repl-server (repl kernel))
-          (usleep 160000)
-          #t)
-        (set-window-title! window title)
-        (set! (stack kernel) #f)
-        (set! (exception kernel) #f))
-      (raise-exception e)))
-
-(define-method (error-message (kernel <kernel>))
-  (let* ((s (stack kernel))
-         (e (exception kernel))
-         (frame (stack-ref s 0)))
-    (format #f "~a: In procedure: ~a:~%In procedure: ~a: ~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")
-            (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))
-                ""))))
-
-(define-method (debugger (kernel <kernel>))
-  (let ((s (stack kernel))
-        (e (exception kernel)))
-    (if (and s e)
-        (let ((debug (make-debug (narrow-stack->vector s 0)
-                                 0
-                                 (error-message kernel))))
-          (format #t "~a~%" (debug-error-message debug))
-          (format #t "Entering a new prompt.  ")
-          (format #t "Type `,bt' for a backtrace or `,q' to resume the game loop.\n")
-          (start-repl #:debug debug)
-          (set! (debugging? kernel) #f))
-        (display "nothing to debug!\n"))))
-
-(define-meta-command ((debug-game catbird) repl)
-  "debug-game
-Enter a debugger for the current game loop error."
-  (debugger (current-kernel)))
-
-(define-meta-command ((resume-game catbird) repl)
-  "resume-game
-Resume the game loop without entering a debugger."
-  (set! (debugging? (current-kernel)) #f))
+      ((error-handler kernel) exception stack)
+      (raise-exception exception)))
+
 
 ;;;
 ;;; Global kernel API
diff --git a/catbird/overlay.scm b/catbird/overlay.scm
index 5c3cf17..420b146 100644
--- a/catbird/overlay.scm
+++ b/catbird/overlay.scm
@@ -43,6 +43,32 @@
 (define (make-overlay)
   (make <overlay> #:name 'overlay))
 
+(define-method (open-repl (overlay <overlay>))
+  (unless (is-a? (major-mode overlay) <repl-mode>)
+    (push-major-mode overlay (make <repl-mode>)))
+  (open-repl (major-mode overlay)))
+
+(define-method (freeze-all-regions (overlay <overlay>))
+  (for-each (lambda (region)
+              ;; Freeze everything except the overlay.
+              (unless (eq? (scene region) overlay)
+                (freeze region)))
+            (all-regions)))
+
+(define (unfreeze-all-regions)
+  (for-each unfreeze (all-regions)))
+
+(define-method (handle-error (overlay <overlay>) exception stack)
+  (freeze-all-regions overlay)
+  (open-repl overlay)
+  (let ((repl (& overlay repl)))
+    (enter-debugger repl exception stack)))
+
+(define-method (on-enter (overlay <overlay>))
+  (set! (error-handler (current-kernel))
+        (lambda (exception stack)
+          (handle-error overlay exception stack))))
+
 (define-method (notify (scene <overlay>) message)
   (run-script scene
     (let* ((padding 8.0)
@@ -71,6 +97,10 @@
       (sleep 5.0)
       (detach notification))))
 
+(define-meta-command ((resume r) system repl)
+  "- Resume game."
+  (unfreeze-all-regions))
+
 (define-class <fps-display> (<node-2d>))
 
 (define-method (on-boot (fps-display <fps-display>))
diff --git a/catbird/repl.scm b/catbird/repl.scm
index 7ca62ee..d8b0bfd 100644
--- a/catbird/repl.scm
+++ b/catbird/repl.scm
@@ -48,6 +48,9 @@
   #:use-module (system vm program)
   #:export (<repl>
             <repl-mode>
+            define-meta-command
+            enter-debugger
+            open-repl
             resize-repl
             repl-print))
 
@@ -172,11 +175,16 @@
   (refresh-prompt repl))
 
 (define-method (push-repl-level (repl <repl>) (new-level <repl-level>))
-  (state-push! (level-state repl) new-level))
+  (state-push! (level-state repl) new-level)
+  (refresh-prompt repl))
 
 (define-method (pop-repl-level (repl <repl>))
   (state-pop! (level-state repl))
   (unless (state-current (level-state repl))
+    ;; HACK: This really shouldn't be here but I'm not sure how to get
+    ;; rid of it yet.  It would be better if <repl-mode> handled it
+    ;; somehow.
+    (restore-keyboard-focus)
     (detach repl)))
 
 (define-method (log-append (repl <repl>) node)
@@ -198,15 +206,16 @@
     (place-below log editor)))
 
 (define-method (refresh-prompt (repl <repl>))
-  (set! (prompt (& repl editor))
-        (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)))))
+  (when (level repl)
+    (set! (prompt (& repl editor))
+          (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)))
@@ -240,28 +249,29 @@
       (log-append repl str))
     (apply values vals)))
 
+(define-method (enter-debugger (repl <repl>) exception stack)
+  (let* ((key (exception-kind exception))
+         (args (exception-args exception))
+         (frame (and stack (stack-ref stack 0))))
+    (with-output-to-log
+     repl
+     (lambda ()
+       (print-exception (current-output-port) frame key args)
+       (newline)
+       (display "Entering a new prompt. ")
+       (display "Type `,bt' for a backtrace, `,q' to exit debugger, or `,r' to resume game.")
+       (newline)))
+    (push-repl-level repl (make <repl-level>
+                            #:language (language repl)
+                            #:module (module repl)
+                            #:depth (+ (depth repl) 1)
+                            #:debug (make <repl-debug> #:stack stack)))))
+
 (define-method (with-error-handling (repl <repl>) thunk)
   (let ((stack #f))
     (define (handle-error e)
-      (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.
-          (values))
-        (with-output-to-log repl enter-debugger)))
+      (enter-debugger repl e stack)
+      (values))
     (define (pre-unwind-handler . args)
       ;; Get stack tag.
       (let ((tag (and (pair? (fluid-ref %stacks))
@@ -283,7 +293,7 @@
         pre-unwind-handler))
     (define (exception-handler e)
       (if (quit-exception? e)
-          (raise-exception e)
+          (pop-repl-level repl)
           (handle-error e)))
     (with-exception-handler exception-handler throw-handler #:unwind? #t)))
 
@@ -498,13 +508,12 @@
 ;;; REPL major mode
 ;;;
 
-(define-class <repl-mode> (<major-mode>)
-  (prev-keyboard-focus #:accessor prev-keyboard-focus #:init-value #f))
+(define-class <repl-mode> (<major-mode>))
 
 (define (repl mode)
   (& (parent mode) repl))
 
-(define-method (on-enter (mode <repl-mode>))
+(define-method (open-repl (mode <repl-mode>))
   (let* ((scene (parent mode))
          (region (car (regions scene)))
          (repl (or (& (parent mode) repl)
@@ -514,15 +523,17 @@
       (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 (on-enter (mode <repl-mode>))
+  (open-repl mode))
+
 (define-method (close-repl (mode <repl-mode>))
   (let ((scene (parent mode)))
     (hide (& scene repl))
-    (take-keyboard-focus (prev-keyboard-focus mode))
+    (restore-keyboard-focus)
     (remove-minor-mode (parent mode) <line-edit-mode>)
     (pop-major-mode scene)))