Clean up model-changed; no need for auxilliary tuples in editor and interactor

extra/color-picker/color-picker.factor

@@ -18,7 +18,7 @@ TUPLE: color-preview ;
     { 100 100 } over set-rect-dim ;
 
 M: color-preview model-changed
-    dup control-value over set-gadget-interior relayout-1 ;
+    swap model-value over set-gadget-interior relayout-1 ;
 
 : <color-model> ( model -- model )
     [ [ 256 /f ] map 1 add <solid> ] <filter> ;

extra/models/models-tests.factor

@@ -6,7 +6,7 @@ TUPLE: model-tester hit? ;
 
 : <model-tester> model-tester construct-empty ;
 
-M: model-tester model-changed t swap set-model-tester-hit? ;
+M: model-tester model-changed nip t swap set-model-tester-hit? ;
 
 [ T{ model-tester f t } ]
 [

extra/models/models.factor

@@ -3,10 +3,10 @@
 USING: generic kernel math sequences timers arrays assocs ;
 IN: models
 
-TUPLE: model value connections dependencies ref ;
+TUPLE: model value connections dependencies ref locked? ;
 
 : <model> ( value -- model )
-    V{ } clone V{ } clone 0 model construct-boa ;
+    V{ } clone V{ } clone 0 f model construct-boa ;
 
 M: model equal? 2drop f ;
 
@@ -49,7 +49,7 @@ DEFER: remove-connection
         drop
     ] if ;
 
-GENERIC: model-changed ( observer -- )
+GENERIC: model-changed ( model observer -- )
 
 : add-connection ( observer model -- )
     dup model-connections empty? [ dup activate-model ] when
@@ -60,11 +60,26 @@ GENERIC: model-changed ( observer -- )
     dup model-connections empty? [ dup deactivate-model ] when
     drop ;
 
-GENERIC: set-model ( value model -- )
+: with-locked-model ( model quot -- )
+    swap
+    t over set-model-locked?
+    slip
+    f swap set-model-locked? ; inline
 
-M: model set-model
+GENERIC: update-model ( model -- )
-    [ set-model-value ] keep
+
-    model-connections [ model-changed ] each ;
+M: model update-model drop ;
+
+: set-model ( value model -- )
+    dup model-locked? [
+        2drop
+    ] [
+        dup [
+            [ set-model-value ] keep
+            [ update-model ] keep
+            dup model-connections [ model-changed ] curry* each
+        ] with-locked-model
+    ] if ;
 
 : ((change-model)) ( model quot -- newvalue model )
     over >r >r model-value r> call r> ; inline
@@ -87,10 +102,10 @@ TUPLE: filter model quot ;
     [ add-dependency ] keep ;
 
 M: filter model-changed
-    dup filter-model model-value over filter-quot call
+    swap model-value over filter-quot call
     swap set-model ;
 
-M: filter model-activated model-changed ;
+M: filter model-activated dup filter-model swap model-changed ;
 
 TUPLE: compose ;
 
@@ -103,11 +118,13 @@ TUPLE: compose ;
 : set-composed-value >r model-dependencies r> 2each ; inline
 
 M: compose model-changed
+    nip
     dup [ model-value ] composed-value swap delegate set-model ;
 
-M: compose model-activated model-changed ;
+M: compose model-activated dup model-changed ;
 
-M: compose set-model [ set-model ] set-composed-value ;
+M: compose update-model
+    dup model-value swap [ set-model ] set-composed-value ;
 
 TUPLE: mapping assoc ;
 
@@ -117,13 +134,15 @@ TUPLE: mapping assoc ;
     tuck set-mapping-assoc ;
 
 M: mapping model-changed
+    nip
     dup mapping-assoc [ model-value ] assoc-map
     swap delegate set-model ;
 
-M: mapping model-activated model-changed ;
+M: mapping model-activated dup model-changed ;
 
-M: mapping set-model
+M: mapping update-model
-    mapping-assoc [ swapd at set-model ] curry assoc-each ;
+    dup model-value swap mapping-assoc
+    [ swapd at set-model ] curry assoc-each ;
 
 TUPLE: history back forward ;
 
@@ -161,10 +180,9 @@ TUPLE: delay model timeout ;
     f delay construct-model
     [ set-delay-timeout ] keep
     [ set-delay-model ] 2keep
-    [ add-dependency ] keep
+    [ add-dependency ] keep ;
-    dup update-delay-model ;
 
-M: delay model-changed 0 over delay-timeout add-timer ;
+M: delay model-changed nip 0 over delay-timeout add-timer ;
 
 M: delay model-activated update-delay-model ;
 

extra/ui/gadgets/books/books-tests.factor

@@ -0,0 +1,4 @@
+IN: temporary
+USING: tools.test.inference ui.gadgets.books ;
+
+{ 2 1 } [ <book> ] unit-test-effect

extra/ui/gadgets/books/books.factor

@@ -10,15 +10,14 @@ TUPLE: book ;
 : current-page ( book -- gadget )
     [ control-value ] keep nth-gadget ;
 
-M: book model-changed ( book -- )
+M: book model-changed
+    nip
     dup hide-all
     dup current-page show-gadget
     relayout ;
 
 : <book> ( pages model -- book )
-    <gadget> book construct-control
+    <gadget> book construct-control [ add-gadgets ] keep ;
-    [ add-gadgets ] keep
-    [ model-changed ] keep ;
 
 M: book pref-dim* gadget-children pref-dims max-dim ;
 

extra/ui/gadgets/buttons/buttons.factor

@@ -141,7 +141,7 @@ TUPLE: checkbox ;
     dup checkbox-theme ;
 
 M: checkbox model-changed
-    dup control-value over set-button-selected? relayout-1 ;
+    swap model-value over set-button-selected? relayout-1 ;
 
 TUPLE: radio-paint color ;
 
@@ -178,7 +178,7 @@ TUPLE: radio-control value ;
     tuck set-radio-control-value ; inline
 
 M: radio-control model-changed
-    dup control-value
+    swap model-value
     over radio-control-value =
     over set-button-selected?
     relayout-1 ;

extra/ui/gadgets/editors/editors-docs.factor

@@ -16,9 +16,6 @@ $nl
     { { $link editor-focused? } " - a boolean." }
 } } ;
 
-HELP: loc-monitor
-{ $class-description "Instances of this class are used internally by " { $link editor } " controls to redraw the editor when the caret or mark is moved by calling " { $link set-model } " on " { $link editor-caret } " or " { $link editor-mark } "." } ;
-
 HELP: <editor>
 { $values { "editor" "a new " { $link editor } } }
 { $description "Creates a new " { $link editor } " with an empty document." } ;

extra/ui/gadgets/editors/editors-tests.factor

@@ -1,41 +1,41 @@
 USING: ui.gadgets.editors tools.test kernel io io.streams.plain
 io.streams.string definitions namespaces ui.gadgets
 ui.gadgets.grids prettyprint documents ui.gestures
-tools.test.inference ;
+tools.test.inference tools.test.ui ;
 
 [ t ] [
     <editor> "editor" set
-    "editor" get graft*
+    "editor" get [
-    "editor" get <plain-writer> [ \ = see ] with-stream
+        "editor" get <plain-writer> [ \ = see ] with-stream
-    "editor" get editor-string [ \ = see ] string-out =
+        "editor" get editor-string [ \ = see ] string-out =
-    "editor" get ungraft*
+    ] with-grafted-gadget
 ] unit-test
 
 [ "foo bar" ] [
     <editor> "editor" set
-    "editor" get graft*
+    "editor" get [
-    "foo bar" "editor" get set-editor-string
+        "foo bar" "editor" get set-editor-string
-    "editor" get T{ one-line-elt } select-elt
+        "editor" get T{ one-line-elt } select-elt
-    "editor" get gadget-selection
+        "editor" get gadget-selection
-    "editor" get ungraft*
+    ] with-grafted-gadget
 ] unit-test
 
 [ "baz quux" ] [
     <editor> "editor" set
-    "editor" get graft*
+    "editor" get [
-    "foo bar\nbaz quux" "editor" get set-editor-string
+        "foo bar\nbaz quux" "editor" get set-editor-string
-    "editor" get T{ one-line-elt } select-elt
+        "editor" get T{ one-line-elt } select-elt
-    "editor" get gadget-selection
+        "editor" get gadget-selection
-    "editor" get ungraft*
+    ] with-grafted-gadget
 ] unit-test
 
 [ ] [
     <editor> "editor" set
-    "editor" get graft*
+    "editor" get [
-    "foo bar\nbaz quux" "editor" get set-editor-string
+        "foo bar\nbaz quux" "editor" get set-editor-string
-    4 hand-click# set
+        4 hand-click# set
-    "editor" get position-caret
+        "editor" get position-caret
-    "editor" get ungraft*
+    ] with-grafted-gadget
 ] unit-test
 
 { 0 1 } [ <editor> ] unit-test-effect

extra/ui/gadgets/editors/editors.factor

@@ -13,15 +13,11 @@ font color caret-color selection-color
 caret mark
 focused? ;
 
-TUPLE: loc-monitor editor ;
+: <loc> ( -- loc ) { 0 0 } <model> ;
-
-: <loc> ( editor -- loc )
-    loc-monitor construct-boa
-    { 0 0 } <model> [ add-connection ] keep ;
 
 : init-editor-locs ( editor -- )
-    dup <loc> over set-editor-caret
+    <loc> over set-editor-caret
-    dup <loc> swap set-editor-mark ;
+    <loc> swap set-editor-mark ;
 
 : editor-theme ( editor -- )
     black over set-editor-color
@@ -47,10 +43,14 @@ TUPLE: source-editor ;
 : <source-editor> source-editor construct-editor ;
 
 : activate-editor-model ( editor model -- )
-    dup activate-model swap gadget-model add-loc ;
+    2dup add-connection
+    dup activate-model
+    swap gadget-model add-loc ;
 
 : deactivate-editor-model ( editor model -- )
-    dup deactivate-model swap gadget-model remove-loc ;
+    2dup remove-connection
+    dup deactivate-model
+    swap gadget-model remove-loc ;
 
 M: editor graft*
     dup
@@ -62,12 +62,6 @@ M: editor ungraft*
     dup editor-caret deactivate-editor-model
     dup editor-mark deactivate-editor-model ;
 
-M: editor model-changed
-    dup gadget-model
-    over editor-caret [ over validate-loc ] (change-model)
-    over editor-mark [ over validate-loc ] (change-model)
-    drop editor-self relayout ;
-
 : editor-caret* ( editor -- loc ) editor-caret model-value ;
 
 : editor-mark* ( editor -- loc ) editor-mark model-value ;
@@ -133,10 +127,6 @@ M: editor model-changed
         over scroll>rect
     ] when drop ;
 
-M: loc-monitor model-changed
-    loc-monitor-editor editor-self
-    dup relayout-1 scroll>caret ;
-
 : draw-caret ( -- )
     editor get editor-focused? [
         editor get
@@ -218,6 +208,22 @@ M: editor draw-gadget*
 M: editor pref-dim*
     dup editor-font* swap control-value text-dim ;
 
+: contents-changed
+    editor-self swap
+    over editor-caret [ over validate-loc ] (change-model)
+    over editor-mark [ over validate-loc ] (change-model)
+    drop relayout ;
+
+: caret/mark-changed
+    nip editor-self dup relayout-1 scroll>caret ;
+
+M: editor model-changed
+    {
+        { [ 2dup gadget-model eq? ] [ contents-changed ] }
+        { [ 2dup editor-caret eq? ] [ caret/mark-changed ] }
+        { [ 2dup editor-mark eq? ] [ caret/mark-changed ] }
+    } cond ;
+
 M: editor gadget-selection?
     selection-start/end = not ;
 
@@ -420,16 +426,6 @@ editor "selection" f {
     { T{ key-down f { S+ C+ } "END" } select-end-of-document }
 } define-command-map
 
-! Editors support the stream output protocol
-M: editor stream-write1 >r 1string r> stream-write ;
-
-M: editor stream-write
-    editor-self dup end-of-document user-input ;
-
-M: editor stream-close drop ;
-
-M: editor stream-flush drop ;
-
 ! Fields are like editors except they edit an external model
 TUPLE: field model editor ;
 
@@ -452,5 +448,6 @@ M: field ungraft*
     dup field-editor gadget-model remove-connection ;
 
 M: field model-changed
+    nip
     dup field-editor editor-string
     swap field-model set-model ;

extra/ui/gadgets/gadgets.factor

@@ -50,7 +50,7 @@ M: gadget equal? 2drop f ;
 
 M: gadget hashcode* drop gadget hashcode* ;
 
-M: gadget model-changed drop ;
+M: gadget model-changed 2drop ;
 
 : gadget-child ( gadget -- child ) gadget-children first ;
 
@@ -71,7 +71,7 @@ M: gadget model-changed drop ;
 
 : activate-control ( gadget -- )
     dup gadget-model dup [ 2dup add-connection ] when drop
-    model-changed ;
+    dup gadget-model swap model-changed ;
 
 : deactivate-control ( gadget -- )
     dup gadget-model dup [ 2dup remove-connection ] when 2drop ;

extra/ui/gadgets/incremental/incremental.factor

@@ -11,14 +11,15 @@ IN: ui.gadgets.incremental
 ! pack-gap.
 
 ! The cursor is the current size of the incremental pack.
-! New gadgets are added at cursor-cursor*gadget-orientation.
+! New gadgets are added at
+!   incremental-cursor gadget-orientation v*
 
 TUPLE: incremental cursor ;
 
 : <incremental> ( pack -- incremental )
-    incremental construct-empty
+    dup pref-dim
-    [ set-gadget-delegate ] keep
+    { set-gadget-delegate set-incremental-cursor }
-    dup delegate pref-dim over set-incremental-cursor ;
+    incremental construct ;
 
 M: incremental pref-dim*
     dup gadget-layout-state [
@@ -39,7 +40,8 @@ M: incremental pref-dim*
     swap set-rect-loc ;
 
 : prefer-incremental ( gadget -- )
-    dup forget-pref-dim dup pref-dim over set-rect-dim layout ;
+    dup forget-pref-dim dup pref-dim over set-rect-dim
+    layout ;
 
 : add-incremental ( gadget incremental -- )
     not-in-layout
@@ -52,6 +54,7 @@ M: incremental pref-dim*
 
 : clear-incremental ( incremental -- )
     not-in-layout
-    dup (clear-gadget) dup forget-pref-dim
+    dup (clear-gadget)
+    dup forget-pref-dim
     { 0 0 } over set-incremental-cursor
     gadget-parent [ relayout ] when* ;

extra/ui/gadgets/labels/labels.factor

@@ -40,7 +40,7 @@ M: label gadget-text* label-string % ;
 TUPLE: label-control ;
 
 M: label-control model-changed
-    dup control-value over set-label-text relayout ;
+    swap model-value over set-label-text relayout ;
 
 : <label-control> ( model -- gadget )
     "" <label> label-control construct-control ;

extra/ui/gadgets/lists/lists.factor

@@ -42,6 +42,7 @@ TUPLE: list index presenter color hook ;
     ] map 2nip ;
 
 M: list model-changed
+    nip
     dup clear-gadget
     dup <list-items> over add-gadgets
     bound-index ;

extra/ui/gadgets/panes/panes.factor

@@ -140,7 +140,7 @@ M: duplex-stream write-gadget
 TUPLE: pane-control quot ;
 
 M: pane-control model-changed
-    dup control-value swap dup pane-control-quot with-pane ;
+    swap model-value swap dup pane-control-quot with-pane ;
 
 : <pane-control> ( model quot -- pane )
     >r <pane> pane-control construct-control r>

extra/ui/gadgets/scrollers/scrollers.factor

@@ -131,4 +131,4 @@ M: scroller focusable-child*
     scroller-viewport ;
 
 M: scroller model-changed
-    f swap set-scroller-follows ;
+    nip f swap set-scroller-follows ;

extra/ui/gadgets/sliders/sliders.factor

@@ -47,7 +47,7 @@ TUPLE: slider elevator thumb saved line ;
 
 : screen>slider slider-scale / ;
 
-M: slider model-changed slider-elevator relayout-1 ;
+M: slider model-changed nip slider-elevator relayout-1 ;
 
 TUPLE: thumb ;
 

extra/ui/gadgets/viewports/viewports.factor

@@ -32,6 +32,7 @@ M: viewport pref-dim* viewport-dim ;
     gadget-model range-value [ >fixnum ] map ;
 
 M: viewport model-changed
+    nip
     dup relayout-1
     dup scroller-value
     vneg viewport-gap v+

extra/ui/tools/interactor/interactor-tests.factor

@@ -0,0 +1,4 @@
+IN: temporary
+USING: ui.tools.interactor tools.test.inference ;
+
+{ 1 1 } [ <interactor> ] unit-test-effect

extra/ui/tools/interactor/interactor.factor

@@ -25,19 +25,8 @@ help ;
         2drop f
     ] if ;
 
-TUPLE: caret-help model gadget ;
-
-: <caret-help> ( interactor -- caret-help )
-    [ editor-caret 100 <delay> ] keep caret-help construct-boa
-    dup dup caret-help-model add-connection ;
-
-M: caret-help model-changed
-    dup caret-help-gadget
-    swap caret-help-model model-value over word-at-loc
-    swap show-summary ;
-
 : init-caret-help ( interactor -- )
-    dup <caret-help> swap set-interactor-help ;
+    dup editor-caret 100 <delay> swap set-interactor-help ;
 
 : init-interactor-history ( interactor -- )
     V{ } clone swap set-interactor-history ;
@@ -52,13 +41,20 @@ M: caret-help model-changed
 
 M: interactor graft*
     dup delegate graft*
-    dup interactor-help caret-help-model activate-model
+    dup dup interactor-help add-connection
     f swap set-interactor-busy? ;
 
 M: interactor ungraft*
-    dup interactor-help caret-help-model deactivate-model
+    dup dup interactor-help remove-connection
     delegate ungraft* ;
 
+M: interactor model-changed
+    2dup interactor-help eq? [
+        swap model-value over word-at-loc swap show-summary
+    ] [
+        delegate model-changed
+    ] if ;
+
 : write-input ( string input -- )
     <input> presented associate
     [ H{ { font-style bold } } format ] with-nesting ;

extra/ui/tools/tools.factor

@@ -49,6 +49,7 @@ IN: ui.tools
     ] if relayout ;
 
 M: workspace model-changed
+    nip
     dup workspace-listener listener-gadget-output scroll>bottom
     dup resize-workspace
     request-focus ;

extra/ui/tools/walker/walker-tests.factor

@@ -2,27 +2,30 @@ USING: arrays continuations ui.tools.listener ui.tools.walker
 ui.tools.workspace inspector kernel namespaces sequences threads
 listener tools.test ui ui.gadgets ui.gadgets.worlds
 ui.gadgets.packs vectors ui.tools tools.interpreter
-tools.interpreter.debug ;
+tools.interpreter.debug tools.test.inference tools.test.ui ;
 IN: temporary
 
+{ 0 1 } [ <walker> ] unit-test-effect
+
 [ ] [ <walker> "walker" set ] unit-test
 
-! Make sure the toolbar buttons don't throw if we're
+"walker" get [
-! not actually walking.
+    ! Make sure the toolbar buttons don't throw if we're
+    ! not actually walking.
 
-[ ] [ "walker" get com-step ] unit-test
+    [ ] [ "walker" get com-step ] unit-test
-[ ] [ "walker" get com-into ] unit-test
+    [ ] [ "walker" get com-into ] unit-test
-[ ] [ "walker" get com-out ] unit-test
+    [ ] [ "walker" get com-out ] unit-test
-[ ] [ "walker" get com-back ] unit-test
+    [ ] [ "walker" get com-back ] unit-test
-[ ] [ "walker" get com-inspect ] unit-test
+    [ ] [ "walker" get com-inspect ] unit-test
-[ ] [ "walker" get reset-walker ] unit-test
+    [ ] [ "walker" get reset-walker ] unit-test
-[ ] [ "walker" get com-continue ] unit-test
+    [ ] [ "walker" get com-continue ] unit-test
+] with-grafted-gadget
 
 : <test-world> ( gadget -- world )
     [ gadget, ] make-pile "Hi" f <world> ;
 
-[
+f <workspace> dup [
-    f <workspace>
     [ <test-world> 2array 1vector windows set ] keep
 
     "ok" off
@@ -37,38 +40,40 @@ IN: temporary
 
     [ t ] [ "ok" get ] unit-test
 
-    [ ] [ <walker> "w" set ] unit-test
+    [ ] [ walker get-tool "w" set ] unit-test
     continuation "c" set
-    
+
     [ ] [ "c" get "w" get call-tool* ] unit-test
 
     [ ] [
         [ "c" set f ] callcc1
         [ "q" set ] [ "w" get com-inspect stop ] if*
     ] unit-test
-    
+
     [ t ] [
         "q" get dup first continuation?
         swap second \ inspect eq? and
     ] unit-test
-] with-scope
+] with-grafted-gadget
 
 [
-    f <workspace> <test-world> 2array 1vector windows set
+    f <workspace> dup [
+        <test-world> 2array 1vector windows set
 
-    [ ] [
+        [ ] [
-        [ 2 3 break 4 ] quot>cont f swap 2array walker call-tool
+            [ 2 3 break 4 ] quot>cont f swap 2array walker call-tool
-    ] unit-test
+        ] unit-test
 
-    [ ] [ walker get-tool com-continue ] unit-test
+        [ ] [ walker get-tool com-continue ] unit-test
 
-    [ ] [ yield ] unit-test
+        [ ] [ yield ] unit-test
 
-    [ t ] [ walker get-tool walker-active? ] unit-test
+        [ t ] [ walker get-tool walker-active? ] unit-test
 
-    [ ] [ "walker" get com-continue ] unit-test
+        [ ] [ "walker" get com-continue ] unit-test
 
-    [ ] [ "walker" get com-continue ] unit-test
+        [ ] [ "walker" get com-continue ] unit-test
 
-    [ ] [ "walker" get com-continue ] unit-test
+        [ ] [ "walker" get com-continue ] unit-test
+    ] with-grafted-gadget
 ] with-scope

extra/ui/tools/walker/walker.factor

@@ -46,12 +46,13 @@ TUPLE: walker model interpreter history ;
     V{ } clone over set-walker-history
     update-stacks ;
 
+M: walker graft* dup delegate graft* reset-walker ;
+
 : <walker> ( -- gadget )
     f <model> f f walker construct-boa [
         toolbar,
         g walker-model <traceback-gadget> 1 track,
-    ] { 0 1 } build-track
+    ] { 0 1 } build-track ;
-    dup reset-walker ;
 
 M: walker call-tool* ( continuation walker -- )
     [ restore ] with-walker ;