diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 5e0f9b2eff..d9f3a91312 100644 --- a/library/ui/gadgets.factor +++ b/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? ; diff --git a/library/ui/gadgets/controls.factor b/library/ui/gadgets/controls.factor index 91de10c4fe..2ee4fd4d06 100644 --- a/library/ui/gadgets/controls.factor +++ b/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 -- ) diff --git a/library/ui/gadgets/panes.factor b/library/ui/gadgets/panes.factor index b3dad87493..9b62f92c1e 100644 --- a/library/ui/gadgets/panes.factor +++ b/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 diff --git a/library/ui/hierarchy.factor b/library/ui/hierarchy.factor index 56d2792971..00242c8718 100644 --- a/library/ui/hierarchy.factor +++ b/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. diff --git a/library/ui/ui.factor b/library/ui/ui.factor index 801800f56d..b8f4d6b8dd 100644 --- a/library/ui/ui.factor +++ b/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 ;