Add game loop error hook.

* chickadee.scm (error-hook): New variable.
(display-game-loop-error, call-with-error-handling): New procedures.
(run-hook*): New syntax.
(run-game): Wrap all hooks with error handling.

1 files changed, 75 insertions, 47 deletions

diff --git a/chickadee.scm b/chickadee.scm
index 3e9a4dc..e604113 100644
--- a/chickadee.scm
+++ b/chickadee.scm
@@ -44,6 +44,7 @@
             controller-press-hook
             controller-release-hook
             controller-move-hook
+            error-hook
             run-game
             abort-game
             time))
@@ -65,6 +66,7 @@
 (define controller-press-hook (make-hook 2))
 (define controller-release-hook (make-hook 2))
 (define controller-move-hook (make-hook 3))
+(define error-hook (make-hook 1))
 
 (define open-controller (@@ (chickadee input controller) open-controller))
 (define close-controller (@@ (chickadee input controller) close-controller))
@@ -72,6 +74,32 @@
 
 (define game-loop-prompt-tag (make-prompt-tag 'game-loop))
 
+(define (display-game-loop-error stack key args)
+  (let ((port (current-error-port)))
+    (display "Backtrace:\n" port)
+    (display-backtrace stack port)
+    (newline port)
+    (apply display-error (stack-ref stack 0) port args)
+    (newline port)))
+
+(define (call-with-error-handling thunk)
+  (let ((stack #f))
+    (catch #t
+      thunk
+      (lambda (key . args)
+        (if (hook-empty? error-hook)
+            (apply throw key args)
+            (begin
+              (display-game-loop-error stack key args)
+              (run-hook error-hook stack))))
+      (lambda (key . args)
+        (set! stack (make-stack #t 3))))))
+
+(define-syntax-rule (run-hook* args ...)
+  (call-with-error-handling
+   (lambda ()
+     (run-hook args ...))))
+
 (define* (run-game #:key
                    (window-title "Chickadee!")
                    (window-width 640)
@@ -92,64 +120,64 @@
     (define (process-event event)
       (cond
        ((quit-event? event)
-        (run-hook quit-hook))
+        (run-hook* quit-hook))
        ((keyboard-down-event? event)
-        (run-hook key-press-hook
-                  (keyboard-event-key event)
-                  (keyboard-event-scancode event)
-                  (keyboard-event-modifiers event)
-                  (keyboard-event-repeat? event)))
+        (run-hook* key-press-hook
+                   (keyboard-event-key event)
+                   (keyboard-event-scancode event)
+                   (keyboard-event-modifiers event)
+                   (keyboard-event-repeat? event)))
        ((keyboard-up-event? event)
-        (run-hook key-release-hook
-                  (keyboard-event-key event)
-                  (keyboard-event-scancode event)
-                  (keyboard-event-modifiers event)))
+        (run-hook* key-release-hook
+                   (keyboard-event-key event)
+                   (keyboard-event-scancode event)
+                   (keyboard-event-modifiers event)))
        ((text-input-event? event)
-        (run-hook text-input-hook (text-input-event-text event)))
+        (run-hook* text-input-hook (text-input-event-text event)))
        ((mouse-button-down-event? event)
-        (run-hook mouse-press-hook
-                  (mouse-button-event-button event)
-                  (mouse-button-event-clicks event)
-                  (mouse-button-event-x event)
-                  (invert-y (mouse-button-event-y event))))
+        (run-hook* mouse-press-hook
+                   (mouse-button-event-button event)
+                   (mouse-button-event-clicks event)
+                   (mouse-button-event-x event)
+                   (invert-y (mouse-button-event-y event))))
        ((mouse-button-up-event? event)
-        (run-hook mouse-release-hook
-                  (mouse-button-event-button event)
-                  (mouse-button-event-x event)
-                  (invert-y (mouse-button-event-y event))))
+        (run-hook* mouse-release-hook
+                   (mouse-button-event-button event)
+                   (mouse-button-event-x event)
+                   (invert-y (mouse-button-event-y event))))
        ((mouse-motion-event? event)
-        (run-hook mouse-move-hook
-                  (mouse-motion-event-x event)
-                  (invert-y (mouse-motion-event-y event))
-                  (mouse-motion-event-x-rel event)
-                  (- (mouse-motion-event-y-rel event))
-                  (mouse-motion-event-buttons event)))
+        (run-hook* mouse-move-hook
+                   (mouse-motion-event-x event)
+                   (invert-y (mouse-motion-event-y event))
+                   (mouse-motion-event-x-rel event)
+                   (- (mouse-motion-event-y-rel event))
+                   (mouse-motion-event-buttons event)))
        ((and (controller-device-event? event)
              (eq? (controller-device-event-action event) 'added))
-        (run-hook controller-add-hook
-                  (open-controller (controller-device-event-which event))))
+        (run-hook* controller-add-hook
+                   (open-controller (controller-device-event-which event))))
        ((and (controller-device-event? event)
              (eq? (controller-device-event-action event) 'removed))
         (let ((controller (lookup-controller
                            (controller-device-event-which event))))
-          (run-hook controller-remove-hook controller)
+          (run-hook* controller-remove-hook controller)
           (close-controller controller)))
        ((controller-button-down-event? event)
-        (run-hook controller-press-hook
-                  (lookup-controller
-                   (controller-button-event-which event))
-                  (controller-button-event-button event)))
+        (run-hook* controller-press-hook
+                   (lookup-controller
+                    (controller-button-event-which event))
+                   (controller-button-event-button event)))
        ((controller-button-up-event? event)
-        (run-hook controller-release-hook
-                  (lookup-controller
-                   (controller-button-event-which event))
-                  (controller-button-event-button event)))
+        (run-hook* controller-release-hook
+                   (lookup-controller
+                    (controller-button-event-which event))
+                   (controller-button-event-button event)))
        ((controller-axis-event? event)
-        (run-hook controller-move-hook
-                  (lookup-controller
-                   (controller-axis-event-which event))
-                  (controller-axis-event-axis event)
-                  (/ (controller-axis-event-value event) 32768.0)))))
+        (run-hook* controller-move-hook
+                   (lookup-controller
+                    (controller-axis-event-which event))
+                   (controller-axis-event-axis event)
+                   (/ (controller-axis-event-value event) 32768.0)))))
     (with-window window
       (let ((update-interval (round (/ 1000 update-hz)))
             (default-viewport
@@ -162,7 +190,7 @@
             (sigaction SIGINT
               (lambda (signum)
                 (abort-game)))
-            (run-hook load-hook)
+            (run-hook* load-hook)
             (let loop ((previous-time (sdl-ticks))
                        (lag 0))
               (let* ((current-time (sdl-ticks))
@@ -176,22 +204,22 @@
                             (process-event event)
                             (loop (poll-event))))
                         ;; Advance the simulation.
-                        (run-hook update-hook update-interval)
+                        (run-hook* update-hook update-interval)
                         ;; Free any GPU resources that have been GC'd.
                         (gpu-reap!)
                         (update-loop (- lag update-interval)))
                       (begin
                         ;; Render a frame.
-                        (run-hook before-draw-hook)
+                        (run-hook* before-draw-hook)
                         ;; Switch to the null viewport to ensure that
                         ;; the default viewport will be re-applied and
                         ;; clear the screen.
                         (gpu-state-set! *viewport-state* null-viewport)
                         (with-viewport default-viewport
                           (with-projection default-projection
-                            (run-hook draw-hook (/ lag update-interval))))
+                            (run-hook* draw-hook (/ lag update-interval))))
                         (swap-buffers window)
-                        (run-hook after-draw-hook)
+                        (run-hook* after-draw-hook)
                         (loop current-time lag)))))))
           (lambda (cont callback)
             #f))))))