From c4d9f14e411c2c6ec259667ac05d873986802073 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sat, 12 Nov 2022 18:23:56 -0500 Subject: scene: Add current-scene parameter and some tests. --- .dir-locals.el | 1 + Makefile.am | 3 ++ catbird/scene.scm | 68 ++++++++++++++++++++++++++++++++++--------- tests/scene.scm | 87 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 146 insertions(+), 13 deletions(-) create mode 100644 tests/scene.scm diff --git a/.dir-locals.el b/.dir-locals.el index 6b30fc9..8d14a47 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -3,4 +3,5 @@ ((eval . (put 'run-script 'scheme-indent-function 1)) (eval . (put 'test-group 'scheme-indent-function 1)) (eval . (put 'with-agenda 'scheme-indent-function 1)) + (eval . (put 'with-scene 'scheme-indent-function 1)) (eval . (put 'with-tests 'scheme-indent-function 1))))) diff --git a/Makefile.am b/Makefile.am index b044bd1..1fb5a2b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -59,6 +59,9 @@ SOURCES = \ catbird/overlay.scm \ catbird.scm +TESTS = \ + tests/scene.scm + TEST_EXTENSIONS = .scm SCM_LOG_COMPILER = $(top_builddir)/test-env $(GUILE) diff --git a/catbird/scene.scm b/catbird/scene.scm index 9197e47..7f2542d 100644 --- a/catbird/scene.scm +++ b/catbird/scene.scm @@ -26,11 +26,17 @@ #:use-module (catbird mode) #:use-module (catbird node) #:use-module (chickadee data array-list) + #:use-module (chickadee scripting) #:use-module (ice-9 exceptions) #:use-module (ice-9 format) #:use-module (oop goops) #:use-module (srfi srfi-1) #:export ( + current-scene + with-scene + add-to-scene + scene-script + $ regions major-mode minor-modes @@ -48,9 +54,27 @@ (minor-modes #:accessor minor-modes #:init-value '()) (input-map #:getter input-map #:init-value '())) +(define current-scene (make-parameter #f)) + +(define-syntax-rule (with-scene scene body ...) + (parameterize ((current-scene scene)) body ...)) + +(define-syntax $ + (syntax-rules () + ((_) (current-scene)) + ((_ names ...) + (& (current-scene) names ...)))) + +(define-method (add-to-scene . nodes) + (apply attach-to (current-scene) nodes)) + +(define-syntax-rule (scene-script body ...) + (run-script (current-scene) body ...)) + (define-method (initialize (scene ) args) (next-method) - (attach (major-mode scene) scene)) + (with-scene scene + (attach (major-mode scene) scene))) (define-method (replace-major-mode (scene ) (mode )) (let ((old-mode (major-mode scene))) @@ -59,6 +83,9 @@ (set! (major-mode scene) mode) (attach mode scene))) +(define-method (replace-major-mode (mode )) + (replace-major-mode (current-scene) mode)) + (define-method (push-major-mode (scene ) (mode )) (let ((old-mode (major-mode scene))) (array-list-push! (major-mode-stack scene) old-mode) @@ -67,6 +94,9 @@ (set! (major-mode scene) mode) (attach mode scene))) +(define-method (push-major-mode (mode )) + (push-major-mode (current-scene) mode)) + (define-method (pop-major-mode (scene )) (let ((stack (major-mode-stack scene))) (unless (array-list-empty? stack) @@ -77,6 +107,9 @@ (set! (major-mode scene) prev-mode) (resume prev-mode))))) +(define-method (pop-major-mode) + (pop-major-mode (current-scene))) + (define-method (add-minor-mode (scene ) (mode )) (when (parent mode) (raise-exception @@ -84,6 +117,9 @@ (set! (minor-modes scene) (cons mode (minor-modes scene))) (attach mode scene)) +(define-method (add-minor-mode (mode )) + (add-minor-mode (current-scene) mode)) + (define-method (remove-minor-mode (scene ) (mode )) (unless (eq? scene (parent mode)) (raise-exception @@ -92,18 +128,23 @@ (set! (minor-modes scene) (delq mode modes)) (detach mode))) +(define-method (remove-minor-mode (mode )) + (remove-minor-mode (current-scene) mode)) + (define-method (remove-minor-mode (scene ) (mode-class )) - (let ((mode (find (lambda (mode) - (eq? (class-of mode) mode-class)) - (minor-modes scene)))) - (when mode - (remove-minor-mode scene mode)))) + (with-scene scene + (let ((mode (find (lambda (mode) + (eq? (class-of mode) mode-class)) + (minor-modes scene)))) + (when mode + (remove-minor-mode scene mode))))) (define-method (search-modes (scene ) proc) - (or (proc (major-mode scene)) - (find (lambda (mode) - (proc mode)) - (minor-modes scene)))) + (with-scene scene + (or (proc (major-mode scene)) + (find (lambda (mode) + (proc mode)) + (minor-modes scene))))) (define-method (on-key-press (scene ) key modifiers) (search-modes scene @@ -156,9 +197,10 @@ (on-controller-move mode controller-id axis value)))) (define-method (update (scene ) dt) - (update (major-mode scene) dt) - (for-each (lambda (mode) (update mode dt)) - (minor-modes scene))) + (with-scene scene + (update (major-mode scene) dt) + (for-each (lambda (mode) (update mode dt)) + (minor-modes scene)))) (define-method (pause (scene )) (for-each-child pause scene) diff --git a/tests/scene.scm b/tests/scene.scm new file mode 100644 index 0000000..533c738 --- /dev/null +++ b/tests/scene.scm @@ -0,0 +1,87 @@ +(define-module (tests scene) + #:use-module (catbird mode) + #:use-module (catbird node) + #:use-module (catbird scene) + #:use-module (oop goops) + #:use-module (srfi srfi-64) + #:use-module (tests utils)) + +(define-class ()) + +(with-tests "scene" + (test-group "$" + (let ((scene (make ))) + (test-eq "no arguments" + (with-scene scene + ($)) + scene)) + (let ((scene (make )) + (node (make #:name 'foo))) + (test-eq "one argument" + (with-scene scene + (attach-to scene node) + ($ foo)) + node))) + (let ((scene (make )) + (node (make #:name 'foo))) + (test-eq "add-to-scene" + (with-scene scene + (add-to-scene node) + (child-ref scene 'foo)) + node)) + (test-eq "initial major mode" + (class-of (major-mode (make ))) + ) + (test-group "replace-major-mode" + (test-eq "replacing does not add to the mode stack" + (let ((scene (make ))) + (replace-major-mode scene (make )) + (pop-major-mode scene) + (class-of (major-mode scene))) + ) + (test-assert "exits previous mode, enters new one" + (let ((scene (make )) + (entered? #f) + (exited? #f)) + (define-class ()) + (define-class ()) + (define-method (on-exit (mode )) + (set! exited? #t)) + (define-method (on-enter (mode )) + (set! entered? #t)) + (replace-major-mode scene (make )) + (replace-major-mode scene (make )) + (and entered? exited?)))) + (test-group "push-major-mode" + (test-eq "adds previous mode to the mode stack so it can be restored" + (let ((scene (make ))) + (push-major-mode scene (make )) + (pop-major-mode scene) + (class-of (major-mode scene))) + ) + (test-assert "pauses the previous mode, enters new one" + (let ((scene (make )) + (paused? #f) + (entered? #f)) + (define-class ()) + (define-class ()) + (define-method (on-pause (mode )) + (set! paused? #t)) + (define-method (on-enter (mode )) + (set! entered? #t)) + (push-major-mode scene (make )) + (push-major-mode scene (make )) + (and paused? entered?)))) + (test-group "pop-major-mode" + (test-eq "does nothing when there is no previous major mode" + (let ((scene (make ))) + (pop-major-mode scene) + (class-of (major-mode scene))) + ) + (test-assert "returns to previous major mode" + (let ((scene (make ))) + (push-major-mode scene (make )) + (and (eq? (class-of (major-mode scene)) ) + (begin + (pop-major-mode scene) + (eq? (class-of (major-mode scene)) ))))))) -- cgit v1.2.3