graft*/ungraft* refactoring

extra/tools/test/ui/ui.factor

@@ -0,0 +1,16 @@
+USING: dlists ui.gadgets kernel ui namespaces io.streams.string
+io ;
+IN: tools.test.ui
+
+! We can't print to stdio here because that might be a pane
+! stream, and our graft-queue rebinding here would be captured
+! by code adding children to the pane...
+: with-grafted-gadget ( gadget quot -- )
+    [
+        <dlist> \ graft-queue [
+            over
+            graft notify-queued
+            swap slip
+            ungraft notify-queued
+        ] with-variable
+    ] string-out print ;

extra/ui/cocoa/cocoa.factor

@@ -62,7 +62,6 @@ M: cocoa-ui-backend set-title ( string world -- )
 
 M: cocoa-ui-backend (open-world-window) ( world -- )
     dup gadget-window
-    dup start-world
     dup auto-position
     world-handle second f -> makeKeyAndOrderFront: ;
 

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

@@ -1,6 +1,7 @@
 IN: temporary
 USING: ui.commands ui.gadgets.buttons ui.gadgets.labels
-ui.gadgets tools.test namespaces sequences kernel models ;
+ui.gadgets tools.test namespaces sequences kernel models
+tools.test.inference ;
 
 TUPLE: foo-gadget ;
 
@@ -27,6 +28,12 @@ T{ foo-gadget } <toolbar> "t" set
     } <radio-buttons> "religion" set
 ] unit-test
 
+{ 2 1 } [ <radio-buttons> ] unit-test-effect
+
+{ 2 1 } [ <toggle-buttons> ] unit-test-effect
+
+{ 2 1 } [ <checkbox> ] unit-test-effect
+
 [ 0 ] [
     "religion" get gadget-child radio-control-value
 ] unit-test

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

@@ -1,6 +1,7 @@
 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 ;
+ui.gadgets.grids prettyprint documents ui.gestures
+tools.test.inference ;
 
 [ t ] [
     <editor> "editor" set
@@ -36,3 +37,5 @@ ui.gadgets.grids prettyprint documents ui.gestures ;
     "editor" get position-caret
     "editor" get ungraft*
 ] unit-test
+
+{ 0 1 } [ <editor> ] unit-test-effect

extra/ui/gadgets/editors/editors.factor

@@ -2,10 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays documents ui.clipboards ui.commands ui.gadgets
 ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
-ui.gadgets.scrollers ui.gadgets.theme
+ui.gadgets.scrollers ui.gadgets.theme ui.render ui.gestures io
-ui.render ui.gestures io kernel math models namespaces opengl
+kernel math models namespaces opengl opengl.gl sequences strings
-opengl.gl sequences strings io.styles math.vectors sorting
+io.styles math.vectors sorting colors combinators ;
-colors combinators ;
 IN: ui.gadgets.editors
 
 TUPLE: editor
@@ -129,7 +128,7 @@ M: editor model-changed
     line-height 0 swap 2array ;
 
 : scroll>caret ( editor -- )
-    dup gadget-grafted? [
+    dup gadget-status second [
         dup caret-loc over caret-dim { 1 0 } v+ <rect>
         over scroll>rect
     ] when drop ;

extra/ui/gadgets/gadgets-tests.factor

@@ -1,6 +1,8 @@
 IN: temporary
 USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
-namespaces models kernel ;
+namespaces models kernel tools.test.inference dlists math
+math.parser ui sequences hashtables assocs io arrays
+prettyprint io.streams.string ;
 
 [ T{ rect f { 10 10 } { 20 20 } } ]
 [
@@ -49,11 +51,11 @@ C: <fooey> fooey
     "a" get "b" get add-gadget
     <gadget> "c" set
     "b" get "c" get add-gadget
-    
+
     ! position a and b
     { 100 200 } "a" get set-rect-loc
     { 200 100 } "b" get set-rect-loc
-    
+
     ! give c a loc, it doesn't matter
     { -1000 23 } "c" get set-rect-loc
 
@@ -108,3 +110,95 @@ C: <fooey> fooey
 { 1 1 } "g4" get set-rect-dim
 
 [ t ] [ { 25 25 } "g1" get pick-up "g4" get eq? ] unit-test
+
+TUPLE: mock-gadget graft-called ungraft-called ;
+
+: <mock-gadget>
+    0 0 mock-gadget construct-boa <gadget> over set-delegate ;
+
+M: mock-gadget graft*
+    dup mock-gadget-graft-called 1+
+    swap set-mock-gadget-graft-called ;
+
+M: mock-gadget ungraft*
+    dup mock-gadget-ungraft-called 1+
+    swap set-mock-gadget-ungraft-called ;
+
+! We can't print to stdio here because that might be a pane
+! stream, and our graft-queue rebinding here would be captured
+! by code adding children to the pane...
+[
+    <dlist> \ graft-queue [
+        [ ] [ <mock-gadget> dup queue-graft unqueue-graft ] unit-test
+        [ t ] [ graft-queue dlist-empty? ] unit-test
+    ] with-variable
+
+    <dlist> \ graft-queue [
+        [ t ] [ graft-queue dlist-empty? ] unit-test
+
+        <mock-gadget> "g" set
+        [ ] [ "g" get queue-graft ] unit-test
+        [ f ] [ graft-queue dlist-empty? ] unit-test
+        [ { f t } ] [ "g" get gadget-status ] unit-test
+        [ ] [ "g" get graft-later ] unit-test
+        [ { f t } ] [ "g" get gadget-status ] unit-test
+        [ ] [ "g" get ungraft-later ] unit-test
+        [ { f f } ] [ "g" get gadget-status ] unit-test
+        [ t ] [ graft-queue dlist-empty? ] unit-test
+        [ ] [ "g" get ungraft-later ] unit-test
+        [ ] [ "g" get graft-later ] unit-test
+        [ ] [ notify-queued ] unit-test
+        [ { t t } ] [ "g" get gadget-status ] unit-test
+        [ t ] [ graft-queue dlist-empty? ] unit-test
+        [ ] [ "g" get graft-later ] unit-test
+        [ 1 ] [ "g" get mock-gadget-graft-called ] unit-test
+        [ ] [ "g" get ungraft-later ] unit-test
+        [ { t f } ] [ "g" get gadget-status ] unit-test
+        [ ] [ notify-queued ] unit-test
+        [ 1 ] [ "g" get mock-gadget-ungraft-called ] unit-test
+        [ { f f } ] [ "g" get gadget-status ] unit-test
+    ] with-variable
+
+    : add-some-children
+        3 [
+            <mock-gadget> over <model> over set-gadget-model
+            dup "g" get add-gadget
+            swap 1+ number>string set
+        ] each ;
+
+    : status-flags
+        { "g" "1" "2" "3" } [ get gadget-status ] map prune ;
+
+    : notify-combo ( ? ? -- )
+        nl "===== Combo: " write 2dup 2array . nl
+        <dlist> \ graft-queue [
+            <mock-gadget> "g" set
+            [ ] [ add-some-children ] unit-test
+            [ V{ { f f } } ] [ status-flags ] unit-test
+            [ ] [ "g" get graft ] unit-test
+            [ V{ { f t } } ] [ status-flags ] unit-test
+            dup [ [ ] [ notify-queued ] unit-test ] when
+            [ ] [ "g" get clear-gadget ] unit-test
+            [ [ 1 ] [ graft-queue dlist-length ] unit-test ] unless
+            [ [ ] [ notify-queued ] unit-test ] when
+            [ ] [ add-some-children ] unit-test
+            [ { f t } ] [ "1" get gadget-status ] unit-test
+            [ { f t } ] [ "2" get gadget-status ] unit-test
+            [ { f t } ] [ "3" get gadget-status ] unit-test
+            [ ] [ [ "x" print notify ] graft-queue swap dlist-slurp ] unit-test
+            [ ] [ notify-queued ] unit-test
+            [ V{ { t t } } ] [ status-flags ] unit-test
+        ] with-variable ;
+
+    { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
+] string-out print
+
+{ 0 1 } [ <gadget> ] unit-test-effect
+{ 1 0 } [ unparent ] unit-test-effect
+{ 2 0 } [ add-gadget ] unit-test-effect
+{ 2 0 } [ add-gadgets ] unit-test-effect
+{ 1 0 } [ clear-gadget ] unit-test-effect
+
+{ 1 0 } [ relayout ] unit-test-effect
+{ 1 0 } [ relayout-1 ] unit-test-effect
+{ 1 1 } [ pref-dim ] unit-test-effect

extra/ui/gadgets/gadgets.factor

@@ -42,7 +42,7 @@ M: array rect-dim drop { 0 0 } ;
 
 TUPLE: gadget
 pref-dim parent children orientation state focus
-visible? root? clipped? grafted?
+visible? root? clipped? status
 interior boundary
 model ;
 
@@ -59,10 +59,11 @@ M: gadget model-changed drop ;
 : <zero-rect> ( -- rect ) { 0 0 } dup <rect> ;
 
 : <gadget> ( -- gadget )
-    <zero-rect> { 0 1 } t {
+    <zero-rect> { 0 1 } t { f f } {
         set-delegate
         set-gadget-orientation
         set-gadget-visible?
+        set-gadget-status
     } gadget construct ;
 
 : construct-gadget ( class -- tuple )
@@ -173,13 +174,13 @@ M: array gadget-text*
 
 : forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ;
 
-: invalid ( -- queue ) \ invalid get-global ;
+: layout-queue ( -- queue ) \ layout-queue get ;
 
-: add-invalid ( gadget -- )
+: layout-later ( gadget -- )
     #! When unit testing gadgets without the UI running, the
     #! invalid queue is not initialized and we simply ignore
     #! invalidation requests.
-    invalid [ push-front ] [ drop ] if* ;
+    layout-queue [ push-front ] [ drop ] if* ;
 
 DEFER: relayout
 
@@ -187,7 +188,7 @@ DEFER: relayout
     \ invalidate* over set-gadget-state
     dup forget-pref-dim
     dup gadget-root?
-    [ add-invalid ] [ gadget-parent [ relayout ] when* ] if ;
+    [ layout-later ] [ gadget-parent [ relayout ] when* ] if ;
 
 : relayout ( gadget -- )
     dup gadget-state \ invalidate* eq?
@@ -195,7 +196,7 @@ DEFER: relayout
 
 : relayout-1 ( gadget -- )
     dup gadget-state
-    [ drop ] [ dup invalidate add-invalid ] if ;
+    [ drop ] [ dup invalidate layout-later ] if ;
 
 : show-gadget t swap set-gadget-visible? ;
 
@@ -241,27 +242,70 @@ M: gadget layout* drop ;
         dup [ layout ] each-child
     ] when drop ;
 
+: graft-queue \ graft-queue get ;
+
+: unqueue-graft ( gadget -- )
+    dup graft-queue dlist-delete [ "Not queued" throw ] unless
+    dup gadget-status first { t t } { f f } ?
+    swap set-gadget-status ;
+
+: queue-graft ( gadget -- )
+    { f t } over set-gadget-status
+    graft-queue push-front ;
+
+: queue-ungraft ( gadget -- )
+    { t f } over set-gadget-status
+    graft-queue push-front ;
+
+: graft-later ( gadget -- )
+    dup gadget-status {
+        { { f t } [ drop ] }
+        { { t t } [ drop ] }
+        { { t f } [ unqueue-graft ] }
+        { { f f } [ queue-graft ] }
+    } case ;
+
+: ungraft-later ( gadget -- )
+    dup gadget-status {
+        { { f f } [ drop ] }
+        { { t f } [ drop ] }
+        { { f t } [ unqueue-graft ] }
+        { { t t } [ queue-ungraft ] }
+    } case ;
+
 GENERIC: graft* ( gadget -- )
 
 M: gadget graft* drop ;
 
+! : graft ( gadget -- )
+!     dup gadget-grafted? [
+!         drop
+!     ] [
+!         t over set-gadget-grafted?
+!         dup graft*
+!         dup activate-control
+!         [ graft ] each-child
+!     ] if ;
+
 : graft ( gadget -- )
-    t over set-gadget-grafted?
+    dup graft-later [ graft ] each-child ;
-    dup graft*
-    dup activate-control
-    [ graft ] each-child ;
 
 GENERIC: ungraft* ( gadget -- )
 
 M: gadget ungraft* drop ;
 
+! : ungraft ( gadget -- )
+!     dup gadget-grafted? [
+!         dup [ ungraft ] each-child
+!         dup deactivate-control
+!         dup ungraft*
+!         f swap set-gadget-grafted?
+!     ] [
+!         drop ! "Fuck you" throw
+!     ] if ;
+
 : ungraft ( gadget -- )
-    dup gadget-grafted? [
+    dup [ ungraft ] each-child ungraft-later ;
-        dup [ ungraft ] each-child
-        dup deactivate-control
-        dup ungraft*
-        f over set-gadget-grafted?
-    ] when drop ;
 
 : (unparent) ( gadget -- )
     dup ungraft
@@ -272,7 +316,14 @@ M: gadget ungraft* drop ;
     tuck gadget-focus eq?
     [ f swap set-gadget-focus ] [ drop ] if ;
 
+SYMBOL: in-layout?
+
+: not-in-layout
+    in-layout? get
+    [ "Cannot add/remove gadgets in layout*" throw ] when ;
+
 : unparent ( gadget -- )
+    not-in-layout
     [
         dup gadget-parent dup [
             over (unparent)
@@ -290,6 +341,7 @@ M: gadget ungraft* drop ;
     f swap set-gadget-children ;
 
 : clear-gadget ( gadget -- )
+    not-in-layout
     dup (clear-gadget) relayout ;
 
 : ((add-gadget)) ( gadget box -- )
@@ -299,12 +351,14 @@ M: gadget ungraft* drop ;
     over unparent
     dup pick set-gadget-parent
     [ ((add-gadget)) ] 2keep
-    gadget-grafted? [ graft ] [ drop ] if ;
+    gadget-status second [ graft ] [ drop ] if ;
 
 : add-gadget ( gadget parent -- )
+    not-in-layout
     [ (add-gadget) ] keep relayout ;
 
 : add-gadgets ( seq parent -- )
+    not-in-layout
     swap [ over (add-gadget) ] each relayout ;
 
 : parents ( gadget -- seq )

extra/ui/gadgets/incremental/incremental.factor

@@ -42,6 +42,7 @@ M: incremental pref-dim*
     dup forget-pref-dim dup pref-dim over set-rect-dim layout ;
 
 : add-incremental ( gadget incremental -- )
+    not-in-layout
     2dup (add-gadget)
     over prefer-incremental
     2dup incremental-loc
@@ -50,6 +51,7 @@ M: incremental pref-dim*
     gadget-parent [ invalidate* ] when* ;
 
 : clear-incremental ( incremental -- )
+    not-in-layout
     dup (clear-gadget) dup forget-pref-dim
     { 0 0 } over set-incremental-cursor
     gadget-parent [ relayout ] when* ;

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

@@ -1,7 +1,8 @@
 IN: temporary
 USING: alien ui.gadgets.panes ui.gadgets namespaces
 kernel sequences io io.streams.string tools.test prettyprint
-definitions help help.syntax help.markup splitting ;
+definitions help help.syntax help.markup splitting
+tools.test.ui models ;
 
 : #children "pane" get gadget-children length ;
 
@@ -33,3 +34,7 @@ ARTICLE: "test-article" "This is a test article"
 
 <pane> [ \ = see ] with-pane
 <pane> [ \ = help ] with-pane
+
+[ ] [
+    \ = <model> [ see ] <pane-control> [ ] with-grafted-gadget
+] unit-test

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

@@ -2,7 +2,8 @@ IN: temporary
 USING: ui.gadgets ui.gadgets.scrollers
 namespaces tools.test kernel models ui.gadgets.viewports
 ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
-ui.gadgets.sliders math math.vectors arrays sequences ;
+ui.gadgets.sliders math math.vectors arrays sequences
+tools.test.inference tools.test.ui ;
 
 [ ] [
     <gadget> "g" set
@@ -20,12 +21,14 @@ ui.gadgets.sliders math math.vectors arrays sequences ;
 [ ] [
     <gadget> dup "g" set
     10 1 0 100 <range> 20 1 0 100 <range> 2array <compose>
-    <viewport> "v" set 
+    <viewport> "v" set
 ] unit-test
 
-[ { 10 20 } ] [ "v" get gadget-model range-value ] unit-test
+"v" get [
+    [ { 10 20 } ] [ "v" get gadget-model range-value ] unit-test
 
-[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
+    [ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
+] with-grafted-gadget
 
 [ ] [
     <gadget> { 100 100 } over set-rect-dim
@@ -36,27 +39,25 @@ ui.gadgets.sliders math math.vectors arrays sequences ;
 
 [ ] [ "s" get layout ] unit-test
 
-[ ] [ "s" get graft ] unit-test
+"s" get [
+    [ { 34 34 } ] [ "s" get scroller-viewport rect-dim ] unit-test
 
-[ { 34 34 } ] [ "s" get scroller-viewport rect-dim ] unit-test
+    [ { 106 106 } ] [ "s" get scroller-viewport viewport-dim ] unit-test
 
-[ { 106 106 } ] [ "s" get scroller-viewport viewport-dim ] unit-test
+    [ ] [ { 0 0 } "s" get scroll ] unit-test
 
-[ ] [ { 0 0 } "s" get scroll ] unit-test
+    [ { 0 0 } ] [ "s" get gadget-model range-min-value ] unit-test
 
-[ { 0 0 } ] [ "s" get gadget-model range-min-value ] unit-test
+    [ { 106 106 } ] [ "s" get gadget-model range-max-value ] unit-test
 
-[ { 106 106 } ] [ "s" get gadget-model range-max-value ] unit-test
+    [ ] [ { 10 20 } "s" get scroll ] unit-test
 
-[ ] [ { 10 20 } "s" get scroll ] unit-test
+    [ { 10 20 } ] [ "s" get gadget-model range-value ] unit-test
 
-[ { 10 20 } ] [ "s" get gadget-model range-value ] unit-test
+    [ { 10 20 } ] [ "s" get scroller-viewport gadget-model range-value ] unit-test
 
-[ { 10 20 } ] [ "s" get scroller-viewport gadget-model range-value ] unit-test
+    [ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
-
+] with-grafted-gadget
-[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
-
-[ ] [ "s" get ungraft ] unit-test
 
 <gadget> { 600 400 } over set-rect-dim "g1" set
 <gadget> { 600 10 } over set-rect-dim "g2" set
@@ -84,3 +85,5 @@ dup layout
 [ f ] [ "s" get scroller-viewport find-scroller* ] unit-test
 [ t ] [ "s" get @right grid-child slider? ] unit-test
 [ f ] [ "s" get @right grid-child find-scroller* ] unit-test
+
+{ 1 1 } [ <scroller> ] unit-test-effect

extra/ui/gadgets/scrollers/scrollers.factor

@@ -28,7 +28,7 @@ scroller H{
     { T{ mouse-scroll } [ do-mouse-scroll ] }
 } set-gestures
 
-: viewport, ( -- )
+: viewport, ( child -- )
     g gadget-model <viewport>
     g-> set-scroller-viewport @center frame, ;
 
@@ -106,7 +106,7 @@ scroller H{
     dup scroller-viewport viewport-dim { 0 1 } v* swap scroll ;
 
 : scroll>bottom ( gadget -- )
-    find-scroller* [
+    find-scroller [
         t over set-scroller-follows relayout-1
     ] when* ;
 

extra/ui/gadgets/sliders/sliders.factor

@@ -131,7 +131,7 @@ M: elevator layout*
 : slide-by-line ( amount slider -- )
     [ slider-line * ] keep slide-by ;
 
-: <slide-button> ( vector polygon amount -- )
+: <slide-button> ( vector polygon amount -- button )
     >r gray swap <polygon-gadget> r>
     [ swap find-slider slide-by-line ] curry <repeat-button>
     [ set-gadget-orientation ] keep ;
@@ -144,7 +144,7 @@ M: elevator layout*
 : <left-button> { 0 1 } arrow-left -1 <slide-button> ;
 : <right-button> { 0 1 } arrow-right 1 <slide-button> ;
 
-: build-x-slider ( slider -- slider )
+: build-x-slider ( slider -- )
     [
         <left-button> @left frame,
         { 0 1 } elevator,
@@ -154,7 +154,7 @@ M: elevator layout*
 : <up-button> { 1 0 } arrow-up -1 <slide-button> ;
 : <down-button> { 1 0 } arrow-down 1 <slide-button> ;
 
-: build-y-slider ( slider -- slider )
+: build-y-slider ( slider -- )
     [
         <up-button> @top frame,
         { 1 0 } elevator,

extra/ui/gadgets/viewports/viewports.factor

@@ -16,8 +16,7 @@ TUPLE: viewport ;
 : <viewport> ( content model -- viewport )
     <gadget> viewport construct-control
     t over set-gadget-clipped?
-    [ add-gadget ] keep
+    [ add-gadget ] keep ;
-    [ model-changed ] keep ;
 
 M: viewport layout*
     dup rect-dim viewport-gap 2 v*n v-

extra/ui/gadgets/worlds/worlds.factor

@@ -112,12 +112,6 @@ world H{
     { T{ button-up f { A+ } 1 } [ T{ button-up f f 2 } swap resend-button-up ] }
 } set-gestures
 
-: start-world ( world -- )
-    dup graft
-    dup relayout
-    dup world-title over set-title
-    request-focus ;
-
 : close-global ( world global -- )
     dup get-global find-world rot eq?
     [ f swap set-global ] [ drop ] if ;
@@ -126,3 +120,8 @@ world H{
     drop-prefix <reversed>
     T{ lose-focus } swap each-gesture
     T{ gain-focus } swap each-gesture ;
+
+M: world graft*
+    dup (open-world-window)
+    dup world-title over set-title
+    request-focus ;

extra/ui/render/render-docs.factor

@@ -13,9 +13,9 @@ HELP: gadget
         { { $link gadget-visible? } " - a boolean indicating if the gadget should display and receive user input." }
         { { $link gadget-root? } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
         { { $link gadget-clipped? } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
-        { { $link gadget-grafted? } " - if set to " { $link t } ", the gadget is parented in a native window." }
         { { $link gadget-interior } " - an object whose class implements the " { $link draw-interior } " generic word." }
         { { $link gadget-boundary } " - an object whose class implements the " { $link draw-boundary } " generic word." }
+        { { $link gadget-model } " - XXX" }
     }
 "Gadgets delegate to " { $link rect } " instances holding their location and dimensions." }
 { $notes

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

@@ -0,0 +1,6 @@
+IN: temporary
+USING: tools.test tools.test.ui ui.tools.browser
+tools.test.inference ;
+
+{ 0 1 } [ <browser-gadget> ] unit-test-effect
+[ ] [ <browser-gadget> [ ] with-grafted-gadget ] unit-test

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

@@ -1,35 +1,39 @@
 USING: continuations documents ui.tools.interactor
 ui.tools.listener hashtables kernel namespaces parser sequences
 timers tools.test ui.commands ui.gadgets ui.gadgets.editors
-ui.gadgets.panes vocabs words ;
+ui.gadgets.panes vocabs words tools.test.ui ;
 IN: temporary
 
 timers [ init-timers ] unless
 
 [ f ] [ "word" source-editor command-map empty? ] unit-test
 
-<listener-gadget> "listener" set
+[ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test
 
-{ "kernel" } [ vocab-words ] map use associate
+[ ] [ <listener-gadget> "listener" set ] unit-test
-"listener" get listener-gadget-input set-interactor-vars
 
-[ "dup" ] [ \ dup "listener" get word-completion-string ] unit-test
+"listener" get [
+    { "kernel" } [ vocab-words ] map use associate
+    "listener" get listener-gadget-input set-interactor-vars
 
-[ "USE: words word-name" ]
+    [ "dup" ] [ \ dup "listener" get word-completion-string ] unit-test
-[ \ word-name "listener" get word-completion-string ] unit-test
 
-<pane> <interactor> "i" set
+    [ "USE: words word-name" ]
-H{ } "i" get set-interactor-vars
+    [ \ word-name "listener" get word-completion-string ] unit-test
 
-[ t ] [ "i" get interactor? ] unit-test
+    <pane> <interactor> "i" set
+    H{ } "i" get set-interactor-vars
 
-[ ] [ "SYMBOL:" "i" get set-editor-string ] unit-test
+    [ t ] [ "i" get interactor? ] unit-test
 
-[ ] [
+    [ ] [ "SYMBOL:" "i" get set-editor-string ] unit-test
-    "i" get [ "SYMBOL:" parse ] catch go-to-error
-] unit-test
 
-[ t ] [
+    [ ] [
-    "i" get gadget-model doc-end
+        "i" get [ "SYMBOL:" parse ] catch go-to-error
-    "i" get editor-caret* =
+    ] unit-test
-] unit-test
+
+    [ t ] [
+        "i" get gadget-model doc-end
+        "i" get editor-caret* =
+    ] unit-test
+] with-grafted-gadget

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

@@ -1,7 +1,7 @@
 USING: assocs ui.tools.search help.topics io.files io.styles
 kernel namespaces sequences source-files threads timers
 tools.test ui.gadgets ui.gestures vocabs
-vocabs.loader words ;
+vocabs.loader words tools.test.ui debugger ;
 IN: temporary
 
 timers get [ init-timers ] unless
@@ -12,12 +12,16 @@ timers get [ init-timers ] unless
     T{ key-down f { C+ } "x" } swap search-gesture
 ] unit-test
 
+: assert-non-empty empty? f assert= ;
+
+: update-live-search ( search -- seq )
+    dup [
+        300 sleep do-timers
+        live-search-list control-value
+    ] with-grafted-gadget ;
+
 : test-live-search ( gadget quot -- ? )
-    >r dup graft 300 sleep do-timers
+   >r update-live-search dup assert-non-empty r> all? ;
-    dup live-search-list control-value
-    dup empty? [ "Empty" throw ] when
-    r> all?
-    >r ungraft r> ;
 
 [ t ] [
     "swp" all-words f <definition-search>
@@ -26,11 +30,12 @@ timers get [ init-timers ] unless
 
 [ t ] [
     "" all-words t <definition-search>
-    dup graft
+    dup [
-    { "set-word-prop" } over live-search-field set-control-value
+        { "set-word-prop" } over live-search-field set-control-value
-    300 sleep
+        300 sleep
-    do-timers
+        do-timers
-    search-value \ set-word-prop eq?
+        search-value \ set-word-prop eq?
+    ] with-grafted-gadget
 ] unit-test
 
 [ t ] [

extra/ui/tools/tools-tests.factor

@@ -2,14 +2,14 @@ USING: ui.tools ui.tools.interactor ui.tools.listener
 ui.tools.search ui.tools.workspace kernel models namespaces
 sequences timers tools.test ui.gadgets ui.gadgets.buttons
 ui.gadgets.labelled ui.gadgets.presentations
-ui.gadgets.scrollers vocabs ;
+ui.gadgets.scrollers vocabs tools.test.ui ui ;
 IN: temporary
 
 [
     [ f ] [
         0 <model> <gadget> [ set-gadget-model ] keep gadget set
         <workspace-tabs> gadget-children empty?
-    ] unit-test 
+    ] unit-test
 ] with-scope
 
 timers get [ init-timers ] unless
@@ -31,24 +31,29 @@ timers get [ init-timers ] unless
     "w" get hide-popup
 ] unit-test
 
-[ ] [
+[ ] [ <workspace> [ ] with-grafted-gadget ] unit-test
-    <workspace> "w" set
-    "w" get graft
-    "w" get "kernel" vocab show-vocab-words
-] unit-test
 
-"w" get workspace-popup closable-gadget-content
+"w" get [
-live-search-list gadget-child "p" set
 
-[ t ] [ "p" get presentation? ] unit-test
+    [ ] [ "w" get "kernel" vocab show-vocab-words ] unit-test
 
-"p" get <operations-menu> gadget-child gadget-child "c" set
+    [ ] [ notify-queued ] unit-test
 
-[ t ] [ "c" get button? ] unit-test
+    [ ] [ "w" get workspace-popup closable-gadget-content
+    live-search-list gadget-child "p" set ] unit-test
 
-[ ] [
+    [ t ] [ "p" get presentation? ] unit-test
-    "w" get workspace-listener listener-gadget-input
-    3 handle-parse-error
-] unit-test
 
-[ ] [ "w" get ungraft ] unit-test
+    [ ] [ "p" get <operations-menu> gadget-child gadget-child "c" set ] unit-test
+
+    [ ] [ notify-queued ] unit-test
+
+    [ t ] [ "c" get button? ] unit-test
+
+    [ ] [
+        "w" get workspace-listener listener-gadget-input
+        3 handle-parse-error
+    ] unit-test
+
+    [ ] [ notify-queued ] unit-test
+] with-grafted-gadget

extra/ui/tools/tools.factor

@@ -12,15 +12,6 @@ vocabs.loader tools.test ui.gadgets.buttons
 ui.gadgets.status-bar mirrors ;
 IN: ui.tools
 
-: workspace-tabs ( -- seq )
-    {
-        <stack-display>
-        <browser-gadget>
-        <inspector-gadget>
-        <walker>
-        <profiler-gadget>
-    } ;
-
 : <workspace-tabs> ( -- tabs )
     g gadget-model
     "tool-switching" workspace command-map
@@ -28,7 +19,13 @@ IN: ui.tools
     <toggle-buttons> ;
 
 : <workspace-book> ( -- gadget )
-    workspace-tabs [ execute ] map g gadget-model <book> ;
+    [
+        <stack-display> ,
+        <browser-gadget> ,
+        <inspector-gadget> ,
+        <walker> ,
+        <profiler-gadget> ,
+    ] { } make g gadget-model <book> ;
 
 : <workspace> ( -- workspace )
     0 <model> { 0 1 } <track> workspace construct-control [

extra/ui/tools/traceback/traceback.factor

@@ -5,15 +5,15 @@ ui.commands ui.gadgets ui.gadgets.labelled
 ui.gadgets.tracks ui.gestures ;
 IN: ui.tools.traceback
 
-: <callstack-display> ( model -- )
+: <callstack-display> ( model -- gadget )
     [ [ continuation-call callstack. ] when* ]
     "Call stack" <labelled-pane> ;
 
-: <datastack-display> ( model -- )
+: <datastack-display> ( model -- gadget )
     [ [ continuation-data stack. ] when* ]
     "Data stack" <labelled-pane> ;
 
-: <retainstack-display> ( model -- )
+: <retainstack-display> ( model -- gadget )
     [ [ continuation-retain stack. ] when* ]
     "Retain stack" <labelled-pane> ;
 

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

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

extra/ui/ui-docs.factor

@@ -18,11 +18,6 @@ HELP: find-window
 { $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" "a " { $link world } " or " { $link f } } }
 { $description "Finds a native window whose world satisfies the quotation, outputting " { $link f } " if no such world could be found. The front-most native window is checked first." } ;
 
-HELP: start-world
-{ $values { "world" world } }
-{ $description "Starts a world." }
-{ $notes "This word should be called by the UI backend after " { $link register-window } ", but before making the world's containing window visible on the screen." } ;
-
 HELP: register-window
 { $values { "world" world } { "handle" "a baackend-specific handle" } }
 { $description "Adds a window to the global " { $link windows } " variable." }
@@ -174,7 +169,6 @@ ARTICLE: "ui-backend-windows" "UI backend window management"
 { $subsection open-world-window }
 "This word should create a native window, store some kind of handle in the " { $link world-handle } " slot, then call two words:"
 { $subsection register-window }
-{ $subsection start-world }
 "The following words must also be implemented:"
 { $subsection set-title }
 { $subsection raise-window }

extra/ui/ui.factor

@@ -3,7 +3,8 @@
 USING: arrays assocs io kernel math models namespaces
 prettyprint dlists sequences threads sequences words timers
 debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
-ui.gestures ui.backend ui.render continuations init ;
+ui.gestures ui.backend ui.render continuations init
+combinators ;
 IN: ui
 
 ! Assoc mapping aliens to gadgets
@@ -53,25 +54,23 @@ SYMBOL: windows
     reset-world ;
 
 : open-world-window ( world -- )
-    dup pref-dim over set-gadget-dim
+    dup pref-dim over set-gadget-dim dup relayout graft ;
-    dup (open-world-window)
-    draw-world ;
 
 : open-window ( gadget title -- )
     >r [ 1 track, ] { 0 1 } make-track r>
     f <world> open-world-window ;
 
 : find-window ( quot -- world )
-    windows get 1 <column>
+    windows get values
     [ gadget-child swap call ] curry* find-last nip ; inline
 
 : restore-windows ( -- )
-    windows get [ 1 <column> >array ] keep delete-all
+    windows get [ values ] keep delete-all
     [ dup reset-world (open-world-window) ] each
     forget-rollover ;
 
 : restore-windows? ( -- ? )
-    windows get [ empty? not ] [ f ] if* ;
+    windows get empty? not ;
 
 : update-hand ( world -- )
     dup hand-world get-global eq?
@@ -79,7 +78,8 @@ SYMBOL: windows
 
 : layout-queued ( -- seq )
     [
-        invalid [
+        in-layout? on
+        layout-queue [
             dup layout find-world [ , ] when*
         ] dlist-slurp
     ] { } make ;
@@ -87,24 +87,40 @@ SYMBOL: windows
 SYMBOL: ui-hook
 
 : init-ui ( -- )
-    <dlist> \ invalid set-global
+    <dlist> \ graft-queue set-global
+    <dlist> \ layout-queue set-global
     V{ } clone windows set-global ;
 
+: redraw-worlds ( seq -- )
+    [ dup update-hand draw-world ] each ;
+
+: notify ( gadget -- )
+    dup gadget-status {
+        { { f t } [ dup activate-control dup graft* ] }
+        { { t f } [ dup activate-control dup ungraft* ] }
+    } case
+    dup gadget-status first { f f } { t t } ?
+    swap set-gadget-status ;
+
+: notify-queued ( -- )
+    graft-queue [ notify ] dlist-slurp ;
+
+: ui-step ( -- )
+    [
+        do-timers
+        notify-queued
+        layout-queued
+        redraw-worlds
+        10 sleep
+    ] assert-depth ;
+
 : start-ui ( -- )
     init-timers
     restore-windows? [
         restore-windows
     ] [
         init-ui ui-hook get call
-    ] if ;
+    ] if ui-step ;
-
-: redraw-worlds ( seq -- )
-    [ dup update-hand draw-world ] each ;
-
-: ui-step ( -- )
-    [
-        do-timers layout-queued redraw-worlds 10 sleep
-    ] assert-depth ;
 
 : ui-running ( quot -- )
     t \ ui-running set-global

extra/ui/windows/windows.factor

@@ -340,17 +340,23 @@ SYMBOL: hWnd
         ] ui-try
      ] alien-callback ;
 
-: do-events ( -- )
+: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
-    msg-obj get f 0 0 PM_REMOVE PeekMessage 
+
-    zero? not [
+: do-events ( msg -- )
-        msg-obj get MSG-message WM_QUIT = [
+    {
-            msg-obj get [ TranslateMessage drop ] keep DispatchMessage drop
+        { [ windows get empty? ] [ drop ] }
-        ] unless
+        { [ dup peek-message? ] [ >r [ ui-step ] ui-try r> do-events ] }
-    ] when ;
+        { [ dup MSG-message WM_QUIT = ] [ drop ] }
+        { [ t ] [
+            dup TranslateMessage drop
+            dup DispatchMessage drop
+            do-events
+        ] }
+    } cond ;
 
 : event-loop ( -- )
     windows get empty? [
-        [ do-events ui-step ] ui-try event-loop
+        msg-obj get do-events
     ] unless ;
 
 : register-wndclassex ( -- class )
@@ -414,8 +420,8 @@ M: windows-ui-backend (open-world-window) ( world -- )
     [ rect-dim first2 create-window dup setup-gl ] keep
     [ f <win> ] keep
     [ swap win-hWnd register-window ] 2keep
-    [ set-world-handle ] 2keep 
+    dupd set-world-handle
-    start-world win-hWnd show-window ;
+    win-hWnd show-window ;
 
 M: windows-ui-backend select-gl-context ( handle -- )
     [ win-hDC ] keep win-hRC wglMakeCurrent win32-error=0/f ;

extra/ui/x11/x11.factor

@@ -224,7 +224,6 @@ M: x11-ui-backend set-title ( string world -- )
 
 M: x11-ui-backend (open-world-window) ( world -- )
     dup gadget-window
-    dup start-world
     world-handle x11-handle-window dup set-closable map-window ;
 
 M: x11-ui-backend raise-window ( world -- )