Clean up ui.gadgets.menus, improve docs, ad add right-click menus to panes and editors with clipboard commands

basis/ui/gadgets/buttons/buttons-docs.factor

@@ -71,3 +71,5 @@ ARTICLE: "ui.gadgets.buttons" "Button gadgets"
 { $subsection button-paint }
 "Button constructors take " { $emphasis "label specifiers" } " as input. A label specifier is either a string, an array of strings, a gadget or " { $link f } "."
 { $see-also <command-button> "ui-commands" } ;
+
+ABOUT: "ui.gadgets.buttons"

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

@@ -20,22 +20,12 @@ HELP: <editor>
 { $values { "editor" "a new " { $link editor } } }
 { $description "Creates a new " { $link editor } " with an empty document." } ;
 
-! 'editor-caret' is now an old accessor, but it's documented as a word here. Maybe move this description somewhere else.
-
-! HELP: editor-caret ( editor -- caret )
-! { $values { "editor" editor } { "caret" model } }
-! { $description "Outputs a " { $link model } " holding the current caret location." } ;
-
 { editor-caret* editor-mark* } related-words
 
 HELP: editor-caret*
 { $values { "editor" editor } { "loc" "a pair of integers" } }
 { $description "Outputs the current caret location as a line/column number pair." } ;
 
-! HELP: editor-mark ( editor -- mark )
-! { $values { "editor" editor } { "mark" model } }
-! { $description "Outputs a " { $link model } " holding the current mark location." } ;
-
 HELP: editor-mark*
 { $values { "editor" editor } { "loc" "a pair of integers" } }
 { $description "Outputs the current mark location as a line/column number pair." } ;

basis/ui/gadgets/editors/editors.factor

@@ -6,7 +6,8 @@ io.styles math.vectors sorting colors combinators assocs
 math.order fry calendar alarms ui.clipboards ui.commands
 ui.gadgets ui.gadgets.borders ui.gadgets.buttons
 ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.theme
-ui.gadgets.wrappers ui.render ui.gestures math.geometry.rect ;
+ui.gadgets.menus ui.gadgets.wrappers ui.render ui.gestures
+math.geometry.rect ;
 IN: ui.gadgets.editors
 
 TUPLE: editor < gadget
@@ -515,6 +516,13 @@ editor "selection" f {
     { T{ key-down f { S+ C+ } "END" } select-end-of-document }
 } define-command-map
 
+: editor-menu ( editor -- )
+    { cut com-copy paste } show-commands-menu ;
+
+editor "misc" f {
+    { T{ button-down f f 3 } editor-menu }
+} define-command-map
+
 ! Multi-line editors
 TUPLE: multiline-editor < editor ;
 

basis/ui/gadgets/menus/menus-docs.factor

@@ -3,9 +3,22 @@ kernel ;
 IN: ui.gadgets.menus
 
 HELP: <commands-menu>
-{ $values { "hook" { $quotation "( button -- )" } } { "target" object } { "commands" "a sequence of commands" } { "gadget" "a new " { $link gadget } } }
+{ $values { "target" object } { "commands" "a sequence of commands" } { "hook" { $quotation "( button -- )" } }  { "menu" "a new " { $link gadget } } }
 { $description "Creates a popup menu of commands which are to be invoked on " { $snippet "target" } ". The " { $snippet "hook" } " quotation is run before a command is invoked." } ;
 
 HELP: show-menu
-{ $values { "gadget" gadget } { "owner" gadget } }
+{ $values { "owner" gadget } { "menu" gadget } }
-{ $description "Displays a popup menu in the " { $link world } " containing " { $snippet "owner" } " at the current mouse location." } ;
+{ $description "Displays a popup menu in the " { $link world } " containing " { $snippet "owner" } " at the current mouse location. The popup menu can be any gadget." } ;
+
+HELP: show-commands-menu
+{ $values { "owner" gadget } { "commands" "a sequence of commands" } }
+{ $description "Displays a popup menu with the given commands. This is just a convenience word that combines " { $link <commands-menu> } " with " { $link show-menu } "." }
+{ $notes "Useful for right-click context menus." } ;
+
+ARTICLE: "ui.gadgets.menus" "Popup menus"
+"The " { $vocab-link "ui.gadgets.menus" } " vocabulary implements popup menus."
+{ $subsection <commands-menu> }
+{ $subsection show-menu }
+{ $subsection show-commands-menu } ;
+
+ABOUT: "ui.gadgets.menus"

basis/ui/gadgets/menus/menus.factor

@@ -1,10 +1,10 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays ui.commands ui.gadgets ui.gadgets.buttons
+USING: locals accessors arrays ui.commands ui.gadgets
-ui.gadgets.worlds ui.gestures generic hashtables kernel math
+ui.gadgets.buttons ui.gadgets.worlds ui.gestures generic
-models namespaces opengl sequences math.vectors
+hashtables kernel math models namespaces opengl sequences
-ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors
+math.vectors ui.gadgets.theme ui.gadgets.packs
-math.geometry.rect ;
+ui.gadgets.borders colors math.geometry.rect ;
 IN: ui.gadgets.menus
 
 : menu-loc ( world menu -- loc )
@@ -12,9 +12,9 @@ IN: ui.gadgets.menus
 
 TUPLE: menu-glass < gadget ;
 
-: <menu-glass> ( menu world -- glass )
+: <menu-glass> ( world menu -- glass )
+    tuck menu-loc >>loc
     menu-glass new-gadget
-    [ over menu-loc >>loc ] dip
     swap add-gadget ;
 
 M: menu-glass layout* gadget-child prefer ;
@@ -22,30 +22,35 @@ M: menu-glass layout* gadget-child prefer ;
 : hide-glass ( world -- )
     [ [ unparent ] when* f ] change-glass drop ;
 
-: show-glass ( gadget world -- )
+: show-glass ( world gadget -- )
-    dup hide-glass
+    [ [ hide-glass ] [ hand-clicked set-global ] bi* ]
-    swap [ hand-clicked set-global ] [ >>glass ] bi
+    [ add-gadget drop ]
-    dup glass>> add-gadget drop ;
+    [ >>glass drop ]
+    2tri ;
 
-: show-menu ( gadget owner -- )
+: show-menu ( owner menu -- )
-    find-world [ <menu-glass> ] keep show-glass ;
+    [ find-world dup ] dip <menu-glass> show-glass ;
 
 \ menu-glass H{
     { T{ button-down } [ find-world [ hide-glass ] when* ] }
     { T{ drag } [ update-clicked drop ] }
 } set-gestures
 
-: <menu-item> ( hook target command -- button )
+:: <menu-item> ( target hook command -- button )
-    dup command-name -rot command-button-quot
+    command command-name [
-    swapd
+        hook call
-    [ hand-clicked get find-world hide-glass ]
+        target command command-button-quot call
-    3append <roll-button> ;
+        hand-clicked get find-world hide-glass
+    ] <roll-button> ;
 
 : menu-theme ( gadget -- gadget )
     light-gray solid-interior
     faint-boundary ;
 
-: <commands-menu> ( hook target commands -- gadget )
+: <commands-menu> ( target hook commands -- menu )
     [ <filled-pile> ] 3dip
-        [ <menu-item> add-gadget ] with with each
+    [ <menu-item> add-gadget ] with with each
     5 <border> menu-theme ;
+
+: show-commands-menu ( target commands -- )
+    [ dup [ ] ] dip <commands-menu> show-menu ;

basis/ui/gadgets/panes/panes.factor

@@ -3,10 +3,10 @@
 USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
 ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.paragraphs
 ui.gadgets.incremental ui.gadgets.packs ui.gadgets.theme
-ui.clipboards ui.gestures ui.traverse ui.render hashtables io
+ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render
-kernel namespaces sequences io.styles strings quotations math
+hashtables io kernel namespaces sequences io.styles strings
-opengl combinators math.vectors sorting splitting
+quotations math opengl combinators math.vectors sorting
-io.streams.nested assocs ui.gadgets.presentations
+splitting io.streams.nested assocs ui.gadgets.presentations
 ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
 classes.tuple models continuations destructors accessors
 math.geometry.rect fry ;
@@ -398,6 +398,8 @@ M: f sloppy-pick-up*
     dup request-focus
     com-copy-selection ;
 
+: pane-menu ( pane -- ) { com-copy } show-commands-menu ;
+
 pane H{
     { T{ button-down } [ begin-selection ] }
     { T{ button-down f { S+ } 1 } [ select-to-caret ] }
@@ -405,4 +407,5 @@ pane H{
     { T{ button-up } [ end-selection ] }
     { T{ drag } [ extend-selection ] }
     { T{ copy-action } [ com-copy ] }
+    { T{ button-down f f 3 } [ pane-menu ] }
 } set-gestures

basis/ui/gadgets/presentations/presentations.factor

@@ -36,12 +36,13 @@ M: presentation ungraft*
     call-next-method ;
 
 : <operations-menu> ( presentation -- menu )
-    dup dup hook>> curry
+    [ object>> ]
-    swap object>>
+    [ dup hook>> curry ]
-    dup object-operations <commands-menu> ;
+    [ object>> object-operations ]
+    tri <commands-menu> ;
 
 : operations-menu ( presentation -- )
-    dup <operations-menu> swap show-menu ;
+    dup <operations-menu> show-menu ;
 
 presentation H{
     { T{ button-down f f 3 } [ operations-menu ] }

basis/ui/ui-docs.factor

@@ -95,6 +95,7 @@ ARTICLE: "gadgets" "Pre-made UI gadgets"
 { $subsection "ui.gadgets.sliders" }
 { $subsection "ui.gadgets.scrollers" }
 { $subsection "gadgets-editors" }
+{ $subsection "ui.gadgets.menus" }
 { $subsection "ui.gadgets.panes" }
 { $subsection "ui.gadgets.presentations" }
 { $subsection "ui.gadgets.lists" } ;