From aa2b038dc2a03017aa045d6aa0e95d9017fac303 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sun, 30 Apr 2023 10:25:09 -0400 Subject: Open in-engine REPL upon error. --- catbird/kernel.scm | 88 +++++++++++------------------------------------------ catbird/overlay.scm | 30 ++++++++++++++++++ catbird/repl.scm | 81 +++++++++++++++++++++++++++--------------------- 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 ) 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 ) 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 )) - (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 )) - (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 #:name 'overlay)) +(define-method (open-repl (overlay )) + (unless (is-a? (major-mode overlay) ) + (push-major-mode overlay (make ))) + (open-repl (major-mode overlay))) + +(define-method (freeze-all-regions (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 ) exception stack) + (freeze-all-regions overlay) + (open-repl overlay) + (let ((repl (& overlay repl))) + (enter-debugger repl exception stack))) + +(define-method (on-enter (overlay )) + (set! (error-handler (current-kernel)) + (lambda (exception stack) + (handle-error overlay exception stack)))) + (define-method (notify (scene ) 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 ()) (define-method (on-boot (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 ( + define-meta-command + enter-debugger + open-repl resize-repl repl-print)) @@ -172,11 +175,16 @@ (refresh-prompt repl)) (define-method (push-repl-level (repl ) (new-level )) - (state-push! (level-state repl) new-level)) + (state-push! (level-state repl) new-level) + (refresh-prompt repl)) (define-method (pop-repl-level (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 handled it + ;; somehow. + (restore-keyboard-focus) (detach repl))) (define-method (log-append (repl ) node) @@ -198,15 +206,16 @@ (place-below log editor))) (define-method (refresh-prompt (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 ) w h) (let ((bg (& repl background))) @@ -240,28 +249,29 @@ (log-append repl str)) (apply values vals))) +(define-method (enter-debugger (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 + #:language (language repl) + #:module (module repl) + #:depth (+ (depth repl) 1) + #:debug (make #:stack stack))))) + (define-method (with-error-handling (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 - #:language (language repl) - #:module (module repl) - #:depth (+ (depth repl) 1) - #:debug (make - #: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 () - (prev-keyboard-focus #:accessor prev-keyboard-focus #:init-value #f)) +(define-class ()) (define (repl mode) (& (parent mode) repl)) -(define-method (on-enter (mode )) +(define-method (open-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 #:editor (& repl editor))))) +(define-method (on-enter (mode )) + (open-repl mode)) + (define-method (close-repl (mode )) (let ((scene (parent mode))) (hide (& scene repl)) - (take-keyboard-focus (prev-keyboard-focus mode)) + (restore-keyboard-focus) (remove-minor-mode (parent mode) ) (pop-major-mode scene))) -- cgit v1.2.3