From f782e70390525fa2e5bfdf8e2ff249ece1640a98 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sat, 8 Oct 2022 09:24:43 -0400
Subject: Update error handling to use Guile's new exception API.

---
 chickadee.scm           |  4 ++--
 chickadee/cli/play.scm  | 45 ++++++++++++++++++++++-----------------------
 chickadee/game-loop.scm | 23 +++++++++++------------
 doc/api.texi            | 11 ++++-------
 4 files changed, 39 insertions(+), 44 deletions(-)

diff --git a/chickadee.scm b/chickadee.scm
index c8ad719..8dc0400 100644
--- a/chickadee.scm
+++ b/chickadee.scm
@@ -387,8 +387,8 @@ border is disabled, otherwise it is enabled.")
         (with-projection (atomic-box-ref default-projection)
           (draw alpha)))
       (sdl2:swap-gl-window (unwrap-window window)))
-    (define (on-error stack key args)
-      (error stack key args)
+    (define (on-error e stack)
+      (error e stack)
       ;; Flush all input events that have occurred while in the error
       ;; state.
       (while (poll-event) #t))
diff --git a/chickadee/cli/play.scm b/chickadee/cli/play.scm
index 7745008..4e18b31 100644
--- a/chickadee/cli/play.scm
+++ b/chickadee/cli/play.scm
@@ -21,6 +21,7 @@
   #:use-module (chickadee async-repl)
   #:use-module (chickadee cli)
   #:use-module (chickadee config)
+  #:use-module (ice-9 exceptions)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
@@ -195,29 +196,24 @@ Resume the game loop without entering a debugger."
                 (repl-opt
                  (set! repl (make-async-repl))
                  (start-async-repl repl abort-game)))))))))
-    (define (handle-error stack key args)
+    (define (handle-error e stack)
       ;; Setup the REPL debug object.
-      (let* ((tag (and (pair? (fluid-ref %stacks))
-                       (cdr (fluid-ref %stacks))))
-             (stack (narrow-stack->vector
-                     stack
-                     ;; Take the stack from the given frame, cutting 0
-                     ;; frames.
-                     0
-                     ;; Narrow the end of the stack to the most recent
-                     ;; start-stack.
-                     ;;tag
-                     ;; And one more frame, because %start-stack
-                     ;; invoking the start-stack thunk has its own frame
-                     ;; too.
-                     0 (and tag 1)
-                     ))
-             (error-string (call-with-output-string
-                             (lambda (port)
-                               (let ((frame (and (< 0 (vector-length stack))
-                                                 (vector-ref stack 0))))
-                                 (print-exception port frame key args))))))
-        (set! debug (make-debug stack 0 error-string))
+      (let* ((frame (stack-ref stack 0))
+             (error-string
+              (format #f "~a: In procedure: ~a:~%In procedure: ~a: ~a~%"
+                      (match (frame-source frame)
+                        ((_ file-name line . column)
+                         (format #f "~a:~a:~a" (basename file-name) line column))
+                        (_ "unknown"))
+                      (frame-procedure-name frame)
+                      (if (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))
+                          ""))))
+        (set! debug (make-debug (narrow-stack->vector stack 0) 0 error-string))
         ;; Just update the REPL endlessly until the developer says to
         ;; resume.
         (let* ((window (current-window))
@@ -264,7 +260,10 @@ Resume the game loop without entering a debugger."
                                                button)
               #:controller-move (trampoline controller-move controller axis
                                             value)
-              #:error (if repl handle-error #f))
+              #:error (if (or (assq-ref opts 'repl)
+                              (assq-ref opts 'repl-server))
+                          handle-error
+                          #f))
     (when (async-repl? repl)
       (close-async-repl repl))))
 
diff --git a/chickadee/game-loop.scm b/chickadee/game-loop.scm
index 76e649a..d0bd287 100644
--- a/chickadee/game-loop.scm
+++ b/chickadee/game-loop.scm
@@ -26,17 +26,19 @@
 ;;;
 
 (define (call-with-error-handling handler thunk)
+  "Call THUNK and respond to any exceptions with HANDLER.  Return #t if
+an error was handled."
   (if handler
       (let ((stack #f))
-        (catch #t
-          (lambda ()
-            (thunk)
-            #f)
-          (lambda (key . args)
-            (handler stack key args)
-            #t)
-          (lambda (key . args)
-            (set! stack (make-stack #t 3)))))
+        (define (pre-unwind-handler . args)
+          (set! stack (make-stack #t 4)))
+        (define (throw-handler)
+          (with-throw-handler #t thunk pre-unwind-handler)
+          #f)
+        (define (exception-handler e)
+          (handler e stack)
+          #t)
+        (with-exception-handler exception-handler throw-handler #:unwind? #t))
       (begin
         (thunk)
         #f)))
@@ -44,9 +46,6 @@
 (define-syntax-rule (with-error-handling handler body ...)
   (call-with-error-handling handler (lambda () body ...)))
 
-(define (default-error-handler stack key args)
-  (apply throw key args))
-
 
 ;;;
 ;;; Game loop kernel
diff --git a/doc/api.texi b/doc/api.texi
index bebef33..9ed9eff 100644
--- a/doc/api.texi
+++ b/doc/api.texi
@@ -290,22 +290,19 @@ values are:
 @end enumerate
 
 @item
-@var{error}: Called with three arguments when an error occurs:
+@var{error}: Called with two arguments when an error occurs:
 
 @enumerate
 
 @item
-@var{stack}: The call stack at the point of error.
+@var{exception}: The exception object.
 
 @item
-@var{key}: The exception key.
-
-@item
-@var{args}: The arguments thrown with the exception.
+@var{stack}: The call stack at the point of the exception.
 
 @end enumerate
 
-The default behavior is to re-throw the error.
+If no error handler is specified, exceptions will simply be re-raised.
 
 @end itemize
 
-- 
cgit v1.2.3