diff options
| -rw-r--r-- | catbird/repl.scm | 101 |
1 files changed, 65 insertions, 36 deletions
diff --git a/catbird/repl.scm b/catbird/repl.scm index 3c56f35..c281411 100644 --- a/catbird/repl.scm +++ b/catbird/repl.scm @@ -114,11 +114,32 @@ (beautify-user-module! module) module)) +(define-class <repl-debug> () + (stack #:accessor stack #:init-keyword #:stack)) + +(define-class <repl-level> () + (depth #:accessor depth #:init-keyword #:depth #:init-value 0) + (language #:accessor language #:init-keyword #:language + #:init-value (lookup-language 'scheme)) + (module #:accessor module #:init-keyword #:module + #:init-thunk make-user-module) + (debug #:accessor debug #:init-keyword #:debug #:init-value #f)) + (define-class <repl> (<node-2d>) - (language #:accessor language #:init-value (lookup-language 'scheme)) - (module #:accessor module #:init-thunk make-user-module) - (max-line-length #:accessor max-line-length #:init-value 256) - (log-lines #:accessor log-lines #:init-form (make-ring-buffer 64))) + (level #:accessor level #:init-form (make <repl-level>)) + (level-stack #:accessor level-stack #:init-value '())) + +(define-method (language (repl <repl>)) + (language (level repl))) + +(define-method (module (repl <repl>)) + (module (level repl))) + +(define-method (depth (repl <repl>)) + (depth (level repl))) + +(define-method (debug (repl <repl>)) + (debug (level repl))) (define-method (initialize (repl <repl>) initargs) (next-method) @@ -134,6 +155,17 @@ (log-append repl "Enter ',help' for help.") (refresh-prompt repl)) +(define-method (push-repl-level (repl <repl>) (new-level <repl-level>)) + (set! (level-stack repl) (cons (level repl) (level-stack repl))) + (set! (level repl) new-level)) + +(define-method (pop-repl-level (repl <repl>)) + (match (level-stack repl) + (() (detach repl)) + ((prev . rest) + (set! (level repl) prev) + (set! (level-stack repl) rest)))) + (define-method (log-append (repl <repl>) node) (let ((container (make <margin-container> #:margin 2.0 @@ -154,9 +186,14 @@ (define-method (refresh-prompt (repl <repl>)) (set! (prompt (& repl editor)) - (format #f "~a@~a> " - (language-name (language repl)) - (module-name (module repl))))) + (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))) @@ -188,33 +225,25 @@ (define-method (with-error-handling (repl <repl>) thunk) (let ((stack #f)) (define (handle-error e) - (let ((frame (stack-ref stack 0))) - (log-append repl - (format #f "~a: In procedure: ~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"))) - (log-append repl - (format #f "In procedure: ~a: ~a" - (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)) - ""))) - (with-output-to-log repl - (lambda () - (display-backtrace stack - (current-output-port)))))) + (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. + *unspecified*) + (with-output-to-log repl enter-debugger))) (define (pre-unwind-handler . args) (set! stack (make-stack #t 4))) (define (throw-handler) @@ -381,7 +410,7 @@ (define-meta-command ((quit q) system repl) "- Quit program." - (abort-game)) + (pop-repl-level repl)) (define-meta-command ((import use) module repl module-name) "MODULE - Import a module." @@ -390,7 +419,7 @@ (define-meta-command ((module m) module repl #:optional module-name*) "[MODULE] - Change current module or show current module." (if module-name* - (set! (module repl) (resolve-module module-name*)) + (set! (module (level repl)) (resolve-module module-name*)) (log-append repl (format #f "~a" (module-name (module repl)))))) |