summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2023-04-18 08:55:18 -0400
committerDavid Thompson <dthompson2@worcester.edu>2023-04-18 08:55:18 -0400
commit0c1a2f1f7d230104b6a1d011bf70c65e82ca119f (patch)
tree7ef0950863bb9b4dbce3ee72c7c3eb51214cb5b1
parent6a13abba62cbdccb862d6aab519f9b22d4b337dd (diff)
repl: Use pushdown state.
-rw-r--r--catbird/repl.scm19
1 files changed, 10 insertions, 9 deletions
diff --git a/catbird/repl.scm b/catbird/repl.scm
index c30a51f..5619c9a 100644
--- a/catbird/repl.scm
+++ b/catbird/repl.scm
@@ -25,6 +25,7 @@
#:use-module (catbird mode)
#:use-module (catbird node)
#:use-module (catbird node-2d)
+ #:use-module (catbird pushdown)
#:use-module (catbird region)
#:use-module (catbird ring-buffer)
#:use-module (catbird scene)
@@ -129,8 +130,10 @@
(debug #:accessor debug #:init-keyword #:debug #:init-value #f))
(define-class <repl> (<node-2d>)
- (level #:accessor level #:init-form (make <repl-level>))
- (level-stack #:accessor level-stack #:init-value '()))
+ (level-state #:getter level-state #:init-thunk make-pushdown-state))
+
+(define-method (level (repl <repl>))
+ (state-current (level-state repl)))
(define-method (language (repl <repl>))
(language (level repl)))
@@ -146,6 +149,7 @@
(define-method (initialize (repl <repl>) initargs)
(next-method)
+ (state-push! (level-state repl) (make <repl-level>))
(attach-to repl
(make <canvas>
#:name 'background)
@@ -159,15 +163,12 @@
(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))
+ (state-push! (level-state 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))))
+ (state-pop! (level-state repl))
+ (unless (state-current (level-state repl))
+ (detach repl)))
(define-method (log-append (repl <repl>) node)
(let ((container (make <margin-container>