Better looking menus which also stay up if the mouse button is released

TODO.FACTOR.txt

@@ -3,8 +3,6 @@
 - "ker" C+u: for a moment, full vocab list is shown
 - some module operations don't work on module-links
 - list operations: what if nothing is selected?
-- menu should stay up if mouse button released
-
 - list usability
   - popup: -- close button
   - popup: -- pin button

library/ui/gadgets/menus.factor

@@ -16,17 +16,20 @@ C: menu-glass ( menu world -- glass )
 
 M: menu-glass layout* gadget-child prefer ;
 
-: retarget-drag ( gadget -- )
+: hide-glass ( world -- )
-    hand-gadget get-global hand-clicked get-global eq? [
+    dup world-glass [ unparent ] when*
-        drop
+    f swap set-world-glass ;
-    ] [
-        hand-loc get-global swap find-world move-hand
-    ] if ;
 
-\ menu-glass H{
+: show-glass ( gadget world -- )
-    { T{ button-up } [ find-world [ hide-glass ] when* ] }
+    over hand-clicked set-global
-    { T{ drag } [ retarget-drag ] }
+    [ hide-glass ] keep
-} set-gestures
+    [ add-gadget ] 2keep
+    set-world-glass ;
 
 : show-menu ( gadget owner -- )
     find-world [ <menu-glass> ] keep show-glass ;
+
+\ menu-glass H{
+    { T{ button-down } [ find-world [ hide-glass ] when* ] }
+    { T{ drag } [ update-clicked drop ] }
+} set-gestures

library/ui/gadgets/presentations.factor

@@ -40,19 +40,25 @@ C: presentation ( gadget object -- button )
     swap [ invoke-primary ] <roll-button>
     over set-gadget-delegate ;
 
-: <command-button> ( target command -- button )
+: (command-button) ( target command -- label quot )
     dup command-name -rot
-    [ invoke-command drop ] curry curry
+    [ invoke-command drop ] curry curry ;
-    <bevel-button> ;
+
+: <command-button> ( target command -- button )
+    (command-button) <bevel-button> ;
 
 : <menu-command> ( command -- command )
     [ hand-clicked get find-world hide-glass ]
     swap modify-command ;
 
+: <menu-item> ( target command -- button )
+    <menu-command> (command-button) <roll-button> ;
+
 : <commands-menu> ( target commands -- gadget )
-    [ <menu-command> ] map
+    [ <menu-item> ] map-with
-    [ <command-button> ] map-with
+    make-pile 1 over set-pack-fill
-    make-pile 1 over set-pack-fill ;
+    <default-border>
+    dup menu-theme ;
 
 : hooked-operations ( hook obj -- seq )
     object-operations swap modify-commands ;

library/ui/gadgets/theme.factor

@@ -72,7 +72,7 @@ USING: arrays gadgets kernel sequences styles ;
     plain-gradient over set-gadget-interior faint-boundary ;
 
 : roll-button-theme ( button -- )
-    f faint solid-black f <button-paint>
+    f solid-black solid-black f <button-paint>
     swap set-gadget-boundary ;
 
 : caret-theme ( caret -- )
@@ -106,3 +106,9 @@ USING: arrays gadgets kernel sequences styles ;
 : popup-theme ( gadget -- )
     T{ solid f { 0.95 0.95 0.95 0.95 } }
     swap set-gadget-interior ;
+
+: menu-theme ( gadget -- )
+    T{ solid f { 0.95 0.95 0.95 0.95 } }
+    over set-gadget-interior
+    T{ solid f { 0.7 0.7 0.7 1.0 } }
+    swap set-gadget-boundary ;

library/ui/gestures.factor

@@ -179,7 +179,6 @@ SYMBOL: double-click-timeout
     dup hand-world set-global
     under-hand >r over hand-loc set-global
     pick-up hand-gadget set-global
-    menu-mode? get-global [ update-clicked ] when
     under-hand r> hand-gestures ;
 
 : send-button-down ( gesture loc world -- )

library/ui/world.factor

@@ -22,8 +22,6 @@ focus focused?
 fonts handle
 loc ;
 
-SYMBOL: menu-mode?
-
 : free-fonts ( world -- )
     dup world-handle select-gl-context
     world-fonts hash-values [ second free-sprites ] each ;
@@ -78,14 +76,3 @@ M: world layout*
     ] when* drop ;
 
 M: world children-on nip gadget-children ;
-
-: hide-glass ( world -- )
-    f menu-mode? set-global
-    dup world-glass [ unparent ] when*
-    f swap set-world-glass ;
-
-: show-glass ( gadget world -- )
-    [ hide-glass ] keep
-    [ add-gadget ] 2keep
-    set-world-glass
-    t menu-mode? set-global ;