scene: Add current-scene parameter and some tests.

4 files changed, 146 insertions, 13 deletions

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 (<scene>
+            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 <scene>) args)
   (next-method)
-  (attach (major-mode scene) scene))
+  (with-scene scene
+    (attach (major-mode scene) scene)))
 
 (define-method (replace-major-mode (scene <scene>) (mode <major-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 <major-mode>))
+  (replace-major-mode (current-scene) mode))
+
 (define-method (push-major-mode (scene <scene>) (mode <major-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 <major-mode>))
+  (push-major-mode (current-scene) mode))
+
 (define-method (pop-major-mode (scene <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 <scene>) (mode <minor-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 <minor-mode>))
+  (add-minor-mode (current-scene) mode))
+
 (define-method (remove-minor-mode (scene <scene>) (mode <minor-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 <minor-mode>))
+  (remove-minor-mode (current-scene) mode))
+
 (define-method (remove-minor-mode (scene <scene>) (mode-class <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 <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 <scene>) key modifiers)
   (search-modes scene
@@ -156,9 +197,10 @@
                   (on-controller-move mode controller-id axis value))))
 
 (define-method (update (scene <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 <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 <test-mode> (<major-mode>))
+
+(with-tests "scene"
+  (test-group "$"
+    (let ((scene (make <scene>)))
+      (test-eq "no arguments"
+        (with-scene scene
+          ($))
+        scene))
+    (let ((scene (make <scene>))
+          (node (make <node> #:name 'foo)))
+      (test-eq "one argument"
+        (with-scene scene
+          (attach-to scene node)
+          ($ foo))
+        node)))
+  (let ((scene (make <scene>))
+        (node (make <node> #: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 <scene>)))
+    <nothing-mode>)
+  (test-group "replace-major-mode"
+    (test-eq "replacing does not add to the mode stack"
+      (let ((scene (make <scene>)))
+        (replace-major-mode scene (make <test-mode>))
+        (pop-major-mode scene)
+        (class-of (major-mode scene)))
+      <test-mode>)
+    (test-assert "exits previous mode, enters new one"
+      (let ((scene (make <scene>))
+            (entered? #f)
+            (exited? #f))
+        (define-class <mode1> (<major-mode>))
+        (define-class <mode2> (<major-mode>))
+        (define-method (on-exit (mode <mode1>))
+          (set! exited? #t))
+        (define-method (on-enter (mode <mode2>))
+          (set! entered? #t))
+        (replace-major-mode scene (make <mode1>))
+        (replace-major-mode scene (make <mode2>))
+        (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 <scene>)))
+        (push-major-mode scene (make <test-mode>))
+        (pop-major-mode scene)
+        (class-of (major-mode scene)))
+      <nothing-mode>)
+    (test-assert "pauses the previous mode, enters new one"
+      (let ((scene (make <scene>))
+            (paused? #f)
+            (entered? #f))
+        (define-class <mode1> (<major-mode>))
+        (define-class <mode2> (<major-mode>))
+        (define-method (on-pause (mode <mode1>))
+          (set! paused? #t))
+        (define-method (on-enter (mode <mode2>))
+          (set! entered? #t))
+        (push-major-mode scene (make <mode1>))
+        (push-major-mode scene (make <mode2>))
+        (and paused? entered?))))
+  (test-group "pop-major-mode"
+    (test-eq "does nothing when there is no previous major mode"
+      (let ((scene (make <scene>)))
+        (pop-major-mode scene)
+        (class-of (major-mode scene)))
+      <nothing-mode>)
+    (test-assert "returns to previous major mode"
+      (let ((scene (make <scene>)))
+        (push-major-mode scene (make <test-mode>))
+        (and (eq? (class-of (major-mode scene)) <test-mode>)
+             (begin
+               (pop-major-mode scene)
+               (eq? (class-of (major-mode scene)) <nothing-mode>)))))))