graft/ungraft protocol replaces broken add/remove-notifyy

library/ui/gadgets.factor

@@ -37,7 +37,8 @@ M: array rect-dim drop { 0 0 } ;
 
 TUPLE: gadget
     pref-dim parent children orientation
-    visible? relayout? root? clipped? interior boundary ;
+    visible? relayout? root? clipped? grafted?
+    interior boundary ;
 
 M: gadget = eq? ;
 

library/ui/gadgets/controls.factor

@@ -11,10 +11,10 @@ C: control ( model gadget quot -- gadget )
     [ set-control-model ] keep
     dup model-changed ;
 
-M: control add-notify*
+M: control graft*
     dup control-model add-connection ;
 
-M: control remove-notify*
+M: control ungraft*
     dup control-model remove-connection ;
 
 M: control model-changed ( gadget -- )

library/ui/gadgets/panes.factor

@@ -112,7 +112,9 @@ M: pane stream-flush ( pane -- ) drop ;
 M: pane stream-readln ( pane -- line )
     [ over set-pane-continuation stop ] callcc1 nip ;
 
-: scroll-pane ( pane -- ) pane-active [ scroll>gadget ] when* ;
+: scroll-pane ( pane -- )
+    #! Only input panes scroll.
+    dup pane-input [ dup pane-active scroll>gadget ] when drop ;
 
 M: pane stream-terpri ( pane -- )
     dup pane-current prepare-print

library/ui/hierarchy.factor

@@ -4,22 +4,28 @@ IN: gadgets
 USING: generic hashtables kernel math namespaces sequences
 vectors words ;
 
-GENERIC: add-notify* ( gadget -- )
+GENERIC: graft* ( gadget -- )
 
-M: gadget add-notify* drop ;
+M: gadget graft* drop ;
 
-: add-notify ( gadget -- )
-    dup [ add-notify ] each-child add-notify* ;
+: graft ( gadget -- )
+    t over set-gadget-grafted?
+    dup graft*
+    dup [ graft ] each-child ;
 
-GENERIC: remove-notify* ( gadget -- )
+GENERIC: ungraft* ( gadget -- )
 
-M: gadget remove-notify* drop ;
+M: gadget ungraft* drop ;
 
-: remove-notify ( gadget -- )
-    dup [ remove-notify* ] each-child remove-notify* ;
+: ungraft ( gadget -- )
+    dup gadget-grafted? [
+        dup [ ungraft* ] each-child
+        dup ungraft*
+        f over set-gadget-grafted?
+    ] when drop ;
 
 : (unparent) ( gadget -- )
-    dup remove-notify
+    dup ungraft
     dup forget-pref-dim f swap set-gadget-parent ;
 
 : unparent ( gadget -- )
@@ -38,11 +44,14 @@ M: gadget remove-notify* drop ;
 : clear-gadget ( gadget -- )
     dup (clear-gadget) relayout ;
 
+: ((add-gadget)) ( gadget box -- )
+    [ gadget-children ?push ] keep set-gadget-children ;
+
 : (add-gadget) ( gadget box -- )
     over unparent
     dup pick set-gadget-parent
-    [ gadget-children ?push ] 2keep swapd set-gadget-children
-    add-notify ;
+    [ ((add-gadget)) ] 2keep
+    gadget-grafted? [ graft ] [ drop ] if ;
 
 : add-gadget ( gadget parent -- )
     #! Add a gadget to a parent gadget.

library/ui/ui.factor

@@ -96,7 +96,7 @@ C: titled-gadget ( gadget title -- )
     ] if* ; inline
 
 : start-world ( world -- )
-    dup add-notify
+    dup graft
     dup gadget-title over set-title
     dup relayout
     world-gadget request-focus ;
@@ -112,12 +112,13 @@ C: titled-gadget ( gadget title -- )
     focused-ancestors f focus-gestures ;
 
 : unfocus-world ( world -- )
-    f over set-world-focused?
     #! Sent when native window loses focus.
+    f over set-world-focused?
     focused-ancestors f swap focus-gestures ;
 
 : reset-world ( world -- )
     dup unfocus-world
+    dup ungraft
     f over set-world-focus
     f over set-world-handle
     world-fonts clear-hash ;
@@ -126,7 +127,7 @@ C: titled-gadget ( gadget title -- )
     dup hand-clicked close-global
     dup hand-gadget close-global
     f over request-focus*
-    dup remove-notify
+    dup ungraft
     dup free-fonts
     reset-world ;