From 5fff1bdf055f08d69691da55f0b119a8a53708cf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Nov 2008 15:03:05 -0600 Subject: [PATCH] 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 | 2 + basis/ui/gadgets/editors/editors-docs.factor | 10 ---- basis/ui/gadgets/editors/editors.factor | 10 +++- basis/ui/gadgets/menus/menus-docs.factor | 19 ++++++-- basis/ui/gadgets/menus/menus.factor | 47 ++++++++++--------- basis/ui/gadgets/panes/panes.factor | 11 +++-- .../presentations/presentations.factor | 9 ++-- basis/ui/ui-docs.factor | 1 + 8 files changed, 66 insertions(+), 43 deletions(-) diff --git a/basis/ui/gadgets/buttons/buttons-docs.factor b/basis/ui/gadgets/buttons/buttons-docs.factor index 4a428404c1..086ef2ca81 100644 --- a/basis/ui/gadgets/buttons/buttons-docs.factor +++ b/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 "ui-commands" } ; + +ABOUT: "ui.gadgets.buttons" diff --git a/basis/ui/gadgets/editors/editors-docs.factor b/basis/ui/gadgets/editors/editors-docs.factor index 0cf60ff5e8..d749b8905c 100644 --- a/basis/ui/gadgets/editors/editors-docs.factor +++ b/basis/ui/gadgets/editors/editors-docs.factor @@ -20,22 +20,12 @@ HELP: { $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." } ; diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 46c2bd1d43..0aa50c6276 100644 --- a/basis/ui/gadgets/editors/editors.factor +++ b/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 ; diff --git a/basis/ui/gadgets/menus/menus-docs.factor b/basis/ui/gadgets/menus/menus-docs.factor index 303eb0a13e..7d5d1f165e 100644 --- a/basis/ui/gadgets/menus/menus-docs.factor +++ b/basis/ui/gadgets/menus/menus-docs.factor @@ -3,9 +3,22 @@ kernel ; IN: ui.gadgets.menus HELP: -{ $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 } } -{ $description "Displays a popup menu in the " { $link world } " containing " { $snippet "owner" } " at the current mouse location." } ; +{ $values { "owner" gadget } { "menu" gadget } } +{ $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 } " 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 } +{ $subsection show-menu } +{ $subsection show-commands-menu } ; + +ABOUT: "ui.gadgets.menus" diff --git a/basis/ui/gadgets/menus/menus.factor b/basis/ui/gadgets/menus/menus.factor index cbcfdb14d8..2aef0b8417 100644 --- a/basis/ui/gadgets/menus/menus.factor +++ b/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 -ui.gadgets.worlds ui.gestures generic hashtables kernel math -models namespaces opengl sequences math.vectors -ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors -math.geometry.rect ; +USING: locals accessors arrays ui.commands ui.gadgets +ui.gadgets.buttons ui.gadgets.worlds ui.gestures generic +hashtables kernel math models namespaces opengl sequences +math.vectors ui.gadgets.theme ui.gadgets.packs +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 world -- 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 -- ) - dup hide-glass - swap [ hand-clicked set-global ] [ >>glass ] bi - dup glass>> add-gadget drop ; +: show-glass ( world gadget -- ) + [ [ hide-glass ] [ hand-clicked set-global ] bi* ] + [ add-gadget drop ] + [ >>glass drop ] + 2tri ; -: show-menu ( gadget owner -- ) - find-world [ ] keep show-glass ; +: show-menu ( owner menu -- ) + [ find-world dup ] dip show-glass ; \ menu-glass H{ { T{ button-down } [ find-world [ hide-glass ] when* ] } { T{ drag } [ update-clicked drop ] } } set-gestures -: ( hook target command -- button ) - dup command-name -rot command-button-quot - swapd - [ hand-clicked get find-world hide-glass ] - 3append ; +:: ( target hook command -- button ) + command command-name [ + hook call + target command command-button-quot call + hand-clicked get find-world hide-glass + ] ; : menu-theme ( gadget -- gadget ) light-gray solid-interior faint-boundary ; -: ( hook target commands -- gadget ) +: ( target hook commands -- menu ) [ ] 3dip - [ add-gadget ] with with each + [ add-gadget ] with with each 5 menu-theme ; + +: show-commands-menu ( target commands -- ) + [ dup [ ] ] dip show-menu ; diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index 9a30cee777..79a47380b6 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/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 -kernel namespaces sequences io.styles strings quotations math -opengl combinators math.vectors sorting splitting -io.streams.nested assocs ui.gadgets.presentations +ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render +hashtables io kernel namespaces sequences io.styles strings +quotations math opengl combinators math.vectors sorting +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 diff --git a/basis/ui/gadgets/presentations/presentations.factor b/basis/ui/gadgets/presentations/presentations.factor index e39069ed7b..33ef3bbe3a 100644 --- a/basis/ui/gadgets/presentations/presentations.factor +++ b/basis/ui/gadgets/presentations/presentations.factor @@ -36,12 +36,13 @@ M: presentation ungraft* call-next-method ; : ( presentation -- menu ) - dup dup hook>> curry - swap object>> - dup object-operations ; + [ object>> ] + [ dup hook>> curry ] + [ object>> object-operations ] + tri ; : operations-menu ( presentation -- ) - dup swap show-menu ; + dup show-menu ; presentation H{ { T{ button-down f f 3 } [ operations-menu ] } diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index de2df4ee6e..738d259cad 100644 --- a/basis/ui/ui-docs.factor +++ b/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" } ;