models: add push-model and pop-model words

basis/models/models-docs.factor

@@ -1,5 +1,5 @@
 USING: help.syntax help.markup kernel math classes classes.tuple
-calendar ;
+calendar sequences growable ;
 IN: models
 
 HELP: model
@@ -64,17 +64,29 @@ HELP: set-model
 { $values { "value" object } { "model" model } }
 { $description "Changes the value of a model and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
 
-{ set-model change-model (change-model) } related-words
+{ set-model change-model change-model* (change-model) push-model pop-model } related-words
 
 HELP: change-model
-{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } }
+{ $values { "model" model } { "quot" { $quotation "( ..a obj -- ..b newobj )" } } }
 { $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value, and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
 
+HELP: change-model*
+{ $values { "model" model } { "quot" { $quotation "( ..a obj -- ..b )" } } }
+{ $description "Applies the quotation to the current value of the model and calls " { $link model-changed } " on all observers registered with " { $link add-connection } " without actually changing the value of the model. This is useful for notifying observers of operations that mutate a value, as in " { $link push-model } " and " { $link pop-model } "." } ;
+
 HELP: (change-model)
-{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } }
+{ $values { "model" model } { "quot" { $quotation "( ..a obj -- ..b newobj )" } } }
 { $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value without notifying any observers registered with " { $link add-connection } "." }
 { $notes "There are very few reasons for user code to call this word. Instead, call " { $link change-model } ", which notifies observers." } ;
 
+HELP: push-model
+{ $values { "value" object } { "model" model } }
+{ $description { $link push } "es " { $snippet "value" } " onto the " { $link growable } " sequence stored as the value of " { $snippet "model" } " and calls " { $link model-changed } " on all observers registered for the model with " { $link add-connection } "." } ;
+
+HELP: pop-model
+{ $values { "model" model } { "value" object } }
+{ $description { $link pop } "s the topmost " { $snippet "value" } " off of the " { $link growable } " sequence stored as the value of " { $snippet "model" } " and calls " { $link model-changed } " on all observers registered for the model with " { $link add-connection } "." } ;
+
 HELP: range-value
 { $values { "model" model } { "value" object } }
 { $contract "Outputs the current value of a range model." } ;

basis/models/models-tests.factor

@@ -10,7 +10,7 @@ M: model-tester model-changed nip t >>hit? drop ;
 
 [ T{ model-tester f t } ]
 [
-    T{ model-tester f f } 3 <model> 2dup add-connection
+    T{ model-tester f f } clone 3 <model> 2dup add-connection
     5 swap set-model
 ] unit-test
 
@@ -31,3 +31,16 @@ T{ model-tester f f } "tester" set
     "tester" get
     "model-c" get value>>
 ] unit-test
+
+[ T{ model-tester f t } V{ 5 } ]
+[
+    T{ model-tester f f } clone V{ } clone <model> 2dup add-connection
+    5 swap [ push-model ] [ value>> ] bi
+] unit-test
+
+[ T{ model-tester f t } 5 V{ }  ]
+[
+    T{ model-tester f f } clone V{ 5 } clone <model> 2dup add-connection
+    [ pop-model ] [ value>> ] bi
+] unit-test
+

basis/models/models.factor

@@ -90,10 +90,10 @@ M: model update-model drop ;
 : ((change-model)) ( model quot -- newvalue model )
     over [ [ value>> ] dip call ] dip ; inline
 
-: change-model ( model quot -- )
+: change-model ( ..a model quot: ( ..a obj -- ..b newobj ) -- ..b )
     ((change-model)) set-model ; inline
 
-: (change-model) ( model quot -- )
+: (change-model) ( ..a model quot: ( ..a obj -- ..b newobj ) -- ..b )
     ((change-model)) value<< ; inline
 
 GENERIC: range-value ( model -- value )
@@ -108,3 +108,13 @@ GENERIC: set-range-max-value ( value model -- )
 
 : clamp-value ( value range -- newvalue )
     [ range-min-value ] [ range-max-value* ] bi clamp ;
+
+: change-model* ( ..a model quot: ( ..a obj -- ..b ) -- ..b )
+    '[ _ keep ] change-model ; inline
+
+: push-model ( value model -- )
+    [ push ] change-model* ;
+
+: pop-model ( model -- value )
+    [ pop ] change-model* ;
+