From 4950f0e791f9cab3092718c36200d01cef06bf89 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Sat, 29 Oct 2022 09:07:18 -0400
Subject: Add error handling when in developer mode.

---
 catbird.scm        |  3 +++
 catbird/kernel.scm | 76 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 79 insertions(+)

diff --git a/catbird.scm b/catbird.scm
index 417cadb..eb08d10 100644
--- a/catbird.scm
+++ b/catbird.scm
@@ -71,6 +71,9 @@
                   (load* kernel)
                   (thunk)
                   (add-overlay))
+                #:error
+                (lambda (e stack)
+                  (on-error kernel e stack))
                 #:draw
                 (lambda (alpha)
                   (render kernel alpha))
diff --git a/catbird/kernel.scm b/catbird/kernel.scm
index bbdb9fe..08d26ba 100644
--- a/catbird/kernel.scm
+++ b/catbird/kernel.scm
@@ -32,10 +32,14 @@
   #:use-module (chickadee data array-list)
   #:use-module (chickadee math rect)
   #:use-module (ice-9 atomic)
+  #:use-module (ice-9 exceptions)
   #:use-module (ice-9 match)
   #:use-module (oop goops)
   #:use-module (srfi srfi-1)
+  #:use-module (system repl command)
   #:use-module (system repl coop-server)
+  #:use-module (system repl debug)
+  #:use-module (system repl repl)
   #:export (<kernel>
             all-regions
             bind-input/global
@@ -50,6 +54,7 @@
             load*
             on-controller-add
             on-controller-remove
+            on-error
             take-controller-focus
             take-keyboard-focus
             unbind-input/global))
@@ -67,6 +72,9 @@
   (keyboard-focus #:accessor keyboard-focus #:init-value #f)
   (controller-focus #:getter controller-focus #:init-thunk make-hash-table)
   (repl #:accessor repl #:init-value #f)
+  (stack #:accessor stack #:init-value #f)
+  (exception #:accessor exception #:init-value #f)
+  (debugging? #:accessor debugging? #:init-value #f)
   (frame-start-time #:accessor frame-start-time #:init-value 0.0)
   (average-frame-time #:accessor average-frame-time #:init-value 0.0))
 
@@ -285,6 +293,74 @@
 
 
 ;;;
+;;; Error handling
+;;;
+
+(define-method (on-error (kernel <kernel>) e s)
+  (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)
+        (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))
+      (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))
+
+;;;
 ;;; Global kernel API
 ;;;
 
-- 
cgit v1.2.3