diff options
| -rw-r--r-- | catbird/kernel.scm | 88 | ||||
| -rw-r--r-- | catbird/overlay.scm | 30 | ||||
| -rw-r--r-- | 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 <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))) |