From af744e451180f4532ba9c7fc040a526cffd7771e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 28 Jan 2009 00:30:57 -0600 Subject: [PATCH] Use singletons instead of empty tuples, add undo/redo to editor gadgets --- basis/ui/backend/cocoa/views/views.factor | 30 ++++++++----- basis/ui/gadgets/buttons/buttons.factor | 4 +- basis/ui/gadgets/editors/editors-tests.factor | 2 +- basis/ui/gadgets/editors/editors.factor | 40 ++++++++++------- basis/ui/gadgets/panes/panes.factor | 2 +- .../presentations/presentations.factor | 6 +-- basis/ui/gadgets/scrollers/scrollers.factor | 2 +- basis/ui/gadgets/tables/tables.factor | 10 ++--- basis/ui/gadgets/worlds/worlds.factor | 10 +++-- basis/ui/gestures/gestures-docs.factor | 32 +++++++------- basis/ui/gestures/gestures.factor | 43 ++++++++----------- basis/ui/tools/browser/browser.factor | 4 +- basis/ui/tools/inspector/inspector.factor | 2 +- .../listener/completion/completion.factor | 12 +++--- basis/ui/tools/listener/listener.factor | 4 +- basis/ui/ui.factor | 4 +- 16 files changed, 110 insertions(+), 97 deletions(-) diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index 2d6e2c8155..e70172bed7 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -197,24 +197,32 @@ CLASS: { [ nip send-key-up-event ] } +{ "undo:" "id" { "id" "SEL" "id" } + [ nip undo-action send-action$ ] +} + +{ "redo:" "id" { "id" "SEL" "id" } + [ nip redo-action send-action$ ] +} + { "cut:" "id" { "id" "SEL" "id" } - [ nip T{ cut-action } send-action$ ] + [ nip cut-action send-action$ ] } { "copy:" "id" { "id" "SEL" "id" } - [ nip T{ copy-action } send-action$ ] + [ nip copy-action send-action$ ] } { "paste:" "id" { "id" "SEL" "id" } - [ nip T{ paste-action } send-action$ ] + [ nip paste-action send-action$ ] } { "delete:" "id" { "id" "SEL" "id" } - [ nip T{ delete-action } send-action$ ] + [ nip delete-action send-action$ ] } { "selectAll:" "id" { "id" "SEL" "id" } - [ nip T{ select-all-action } send-action$ ] + [ nip select-all-action send-action$ ] } ! Multi-touch gestures: this is undocumented. @@ -223,8 +231,8 @@ CLASS: { [ nip dup -> deltaZ sgn { - { 1 [ T{ zoom-in-action } send-action$ ] } - { -1 [ T{ zoom-out-action } send-action$ ] } + { 1 [ zoom-in-action send-action$ ] } + { -1 [ zoom-out-action send-action$ ] } { 0 [ 2drop ] } } case ] @@ -234,13 +242,13 @@ CLASS: { [ nip dup -> deltaX sgn { - { 1 [ T{ left-action } send-action$ ] } - { -1 [ T{ right-action } send-action$ ] } + { 1 [ left-action send-action$ ] } + { -1 [ right-action send-action$ ] } { 0 [ dup -> deltaY sgn { - { 1 [ T{ up-action } send-action$ ] } - { -1 [ T{ down-action } send-action$ ] } + { 1 [ up-action send-action$ ] } + { -1 [ down-action send-action$ ] } { 0 [ 2drop ] } } case ] diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index 660b7d1cb5..86ba579e7e 100644 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -35,8 +35,8 @@ TUPLE: button < border pressed? selected? quot ; button H{ { T{ button-up } [ button-clicked ] } { T{ button-down } [ button-update ] } - { T{ mouse-leave } [ button-update ] } - { T{ mouse-enter } [ button-update ] } + { mouse-leave [ button-update ] } + { mouse-enter [ button-update ] } } set-gestures : new-button ( label quot class -- button ) diff --git a/basis/ui/gadgets/editors/editors-tests.factor b/basis/ui/gadgets/editors/editors-tests.factor index 612f265fc7..daaacacba7 100644 --- a/basis/ui/gadgets/editors/editors-tests.factor +++ b/basis/ui/gadgets/editors/editors-tests.factor @@ -1,7 +1,7 @@ USING: accessors ui.gadgets.editors tools.test kernel io io.streams.plain definitions namespaces ui.gadgets ui.gadgets.grids prettyprint documents ui.gestures tools.test.ui -models ; +models documents.elements ; IN: ui.gadgets.editors.tests [ "foo bar" ] [ diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 4cc7c493e8..4699cdc5e6 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2006, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays documents kernel math models models.filter -namespaces locals fry make opengl opengl.gl sequences strings -math.vectors sorting colors combinators assocs math.order fry -calendar alarms continuations ui.clipboards ui.commands -ui.gadgets ui.gadgets.borders ui.gadgets.buttons -ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.theme -ui.gadgets.menus ui.gadgets.wrappers ui.render ui.text -ui.gestures math.geometry.rect splitting unicode.categories ; +USING: accessors arrays documents documents.elements kernel math +models models.filter namespaces locals fry make opengl opengl.gl +sequences strings math.vectors sorting colors combinators assocs +math.order fry calendar alarms continuations ui.clipboards ui.commands +ui.gadgets ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels +ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.menus +ui.gadgets.wrappers ui.render ui.text ui.gestures math.geometry.rect +splitting unicode.categories ; IN: ui.gadgets.editors TUPLE: editor < gadget @@ -377,7 +377,15 @@ M: editor gadget-text* editor-string % ; : delete-to-end-of-line ( editor -- ) one-line-elt editor-backspace ; -editor "general" f { +: com-undo ( editor -- ) + model>> undo ; + +: com-redo ( editor -- ) + model>> redo ; + +editor "editing" f { + { undo-action com-undo } + { redo-action com-redo } { T{ key-down f f "DELETE" } delete-next-character } { T{ key-down f { S+ } "DELETE" } delete-next-character } { T{ key-down f f "BACKSPACE" } delete-previous-character } @@ -395,11 +403,11 @@ editor "general" f { : cut ( editor -- ) clipboard get editor-cut ; editor "clipboard" f { - { T{ paste-action } paste } + { paste-action paste } + { copy-action com-copy } + { cut-action cut } { T{ button-up f f 2 } paste-selection } - { T{ copy-action } com-copy } { T{ button-up } com-copy-selection } - { T{ cut-action } cut } } define-command-map : previous-character ( editor -- ) @@ -480,10 +488,10 @@ editor "caret-motion" f { editor "selection" f { { T{ button-down f { S+ } 1 } extend-selection } { T{ drag } drag-selection } - { T{ gain-focus } focus-editor } - { T{ lose-focus } unfocus-editor } - { T{ delete-action } remove-selection } - { T{ select-all-action } select-all } + { gain-focus focus-editor } + { lose-focus unfocus-editor } + { delete-action remove-selection } + { select-all-action select-all } { T{ key-down f { C+ } "l" } select-line } { T{ key-down f { S+ } "LEFT" } select-previous-character } { T{ key-down f { S+ } "RIGHT" } select-next-character } diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index cfc19f72e2..a8ef603de3 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/basis/ui/gadgets/panes/panes.factor @@ -414,6 +414,6 @@ pane H{ { T{ button-up f { S+ } 1 } [ end-selection ] } { T{ button-up } [ end-selection ] } { T{ drag } [ extend-selection ] } - { T{ copy-action } [ com-copy ] } + { 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 9005c602c3..6cd32731be 100644 --- a/basis/ui/gadgets/presentations/presentations.factor +++ b/basis/ui/gadgets/presentations/presentations.factor @@ -40,11 +40,11 @@ M: presentation ungraft* presentation H{ { T{ button-down f f 3 } [ show-presentation-menu ] } - { T{ mouse-leave } [ [ hide-status ] [ button-update ] bi ] } - { T{ mouse-enter } [ show-mouse-help ] } + { mouse-leave [ [ hide-status ] [ button-update ] bi ] } + { mouse-enter [ show-mouse-help ] } ! Responding to motion too allows nested presentations to ! display status help properly, when the mouse leaves a ! nested presentation and is still inside the parent, the ! parent doesn't receive a mouse-enter - { T{ motion } [ show-mouse-help ] } + { motion [ show-mouse-help ] } } set-gestures diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor index 93f6b8bb40..6f744bf234 100644 --- a/basis/ui/gadgets/scrollers/scrollers.factor +++ b/basis/ui/gadgets/scrollers/scrollers.factor @@ -27,7 +27,7 @@ TUPLE: scroller < frame viewport x y follows ; 2bi ; scroller H{ - { T{ mouse-scroll } [ do-mouse-scroll ] } + { mouse-scroll [ do-mouse-scroll ] } } set-gestures : ( -- model ) diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index 0b58fe2d38..bf158ae91b 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -300,14 +300,14 @@ PRIVATE> ] [ drop ] if-mouse-row ; table H{ - { T{ mouse-enter } [ show-mouse-help ] } - { T{ mouse-leave } [ hide-mouse-help ] } - { T{ motion } [ show-mouse-help ] } + { mouse-enter [ show-mouse-help ] } + { mouse-leave [ hide-mouse-help ] } + { motion [ show-mouse-help ] } { T{ button-down } [ table-button-down ] } { T{ button-down f f 3 } [ show-table-menu ] } { T{ button-up } [ table-button-up ] } - { T{ gain-focus } [ t >>focused? drop ] } - { T{ lose-focus } [ f >>focused? drop ] } + { gain-focus [ t >>focused? drop ] } + { lose-focus [ f >>focused? drop ] } { T{ drag } [ table-button-down ] } { T{ key-down f f "RET" } [ row-action ] } { T{ key-down f f "UP" } [ prev-row ] } diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 2ce5fec4f6..dce04b040c 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -92,10 +92,12 @@ ui-error-hook global [ [ rethrow ] or ] change-at ] [ drop ] if ; world H{ - { T{ key-down f { C+ } "x" } [ T{ cut-action } send-action ] } - { T{ key-down f { C+ } "c" } [ T{ copy-action } send-action ] } - { T{ key-down f { C+ } "v" } [ T{ paste-action } send-action ] } - { T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] } + { T{ key-down f { C+ } "z" } [ undo-action send-action ] } + { T{ key-down f { C+ } "Z" } [ redo-action send-action ] } + { T{ key-down f { C+ } "x" } [ cut-action send-action ] } + { T{ key-down f { C+ } "c" } [ copy-action send-action ] } + { T{ key-down f { C+ } "v" } [ paste-action send-action ] } + { T{ key-down f { C+ } "a" } [ select-all-action send-action ] } { T{ button-down f { C+ } 1 } [ drop T{ button-down f f 3 } button-gesture ] } { T{ button-down f { A+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] } { T{ button-down f { M+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] } diff --git a/basis/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor index f6495a14c3..d1fab23f04 100644 --- a/basis/ui/gestures/gestures-docs.factor +++ b/basis/ui/gestures/gestures-docs.factor @@ -23,7 +23,7 @@ HELP: propagate-gesture HELP: motion { $class-description "Mouse motion gesture." } -{ $examples { $code "T{ motion }" } } ; +{ $examples { $code "motion" } } ; HELP: drag { $class-description "Mouse drag gesture. The " { $snippet "#" } " slot is either set to a mouse button number, or " { $link f } " indicating no specific button is expected." } ; @@ -48,43 +48,43 @@ HELP: button-down HELP: mouse-scroll { $class-description "Scroll wheel motion gesture. When this gesture is sent, the " { $link scroll-direction } " global variable is set to a direction vector." } -{ $examples { $code "T{ mouse-scroll }" } } ; +{ $examples { $code "mouse-scroll" } } ; HELP: mouse-enter { $class-description "Gesture sent when the mouse enters the bounds of a gadget." } -{ $examples { $code "T{ mouse-enter }" } } ; +{ $examples { $code "mouse-enter" } } ; HELP: mouse-leave { $class-description "Gesture sent when the mouse leaves the bounds of a gadget." } -{ $examples { $code "T{ mouse-leave }" } } ; +{ $examples { $code "mouse-leave" } } ; HELP: gain-focus { $class-description "Gesture sent when a gadget gains keyboard focus." } -{ $examples { $code "T{ gain-focus }" } } ; +{ $examples { $code "gain-focus" } } ; HELP: lose-focus { $class-description "Gesture sent when a gadget loses keyboard focus." } -{ $examples { $code "T{ lose-focus }" } } ; +{ $examples { $code "lose-focus" } } ; HELP: cut-action { $class-description "Gesture sent when the " { $emphasis "cut" } " standard window system action is invoked." } -{ $examples { $code "T{ cut-action }" } } ; +{ $examples { $code "cut-action" } } ; HELP: copy-action { $class-description "Gesture sent when the " { $emphasis "copy" } " standard window system action is invoked." } -{ $examples { $code "T{ copy-action }" } } ; +{ $examples { $code "copy-action" } } ; HELP: paste-action { $class-description "Gesture sent when the " { $emphasis "paste" } " standard window system action is invoked." } -{ $examples { $code "T{ paste-action }" } } ; +{ $examples { $code "paste-action" } } ; HELP: delete-action { $class-description "Gesture sent when the " { $emphasis "delete" } " standard window system action is invoked." } -{ $examples { $code "T{ delete-action }" } } ; +{ $examples { $code "delete-action" } } ; HELP: select-all-action { $class-description "Gesture sent when the " { $emphasis "select all" } " standard window system action is invoked." } -{ $examples { $code "T{ select-all-action }" } } ; +{ $examples { $code "select-all-action" } } ; HELP: C+ { $description "Control key modifier." } ; @@ -359,10 +359,12 @@ ARTICLE: "action-gestures" "Action gestures" "The following keyboard gestures, if not handled directly, send action gestures:" { $table { { $strong "Keyboard gesture" } { $strong "Action gesture" } } - { { $snippet "T{ key-down f { C+ } \"x\" }" } { $snippet "T{ cut-action }" } } - { { $snippet "T{ key-down f { C+ } \"c\" }" } { $snippet "T{ copy-action }" } } - { { $snippet "T{ key-down f { C+ } \"v\" }" } { $snippet "T{ paste-action }" } } - { { $snippet "T{ key-down f { C+ } \"a\" }" } { $snippet "T{ select-all }" } } + { { $snippet "T{ key-down f { C+ } \"z\" }" } { $snippet "undo-action" } } + { { $snippet "T{ key-down f { C+ } \"Z\" }" } { $snippet "redo-action" } } + { { $snippet "T{ key-down f { C+ } \"x\" }" } { $snippet "cut-action" } } + { { $snippet "T{ key-down f { C+ } \"c\" }" } { $snippet "copy-action" } } + { { $snippet "T{ key-down f { C+ } \"v\" }" } { $snippet "paste-action" } } + { { $snippet "T{ key-down f { C+ } \"a\" }" } { $snippet "select-all-action" } } } "Action gestures should be used in place of the above keyboard gestures if possible. For example, on Mac OS X, the standard " { $strong "Edit" } " menu items send action gestures." ; diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index 3ac793636e..77809efafd 100644 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -66,30 +66,23 @@ M: user-input send-queued-gesture '[ _ \ user-input queue-gesture ] unless-empty ; ! Gesture objects -TUPLE: motion ; C: motion TUPLE: drag # ; C: drag TUPLE: button-up mods # ; C: button-up TUPLE: button-down mods # ; C: button-down -TUPLE: mouse-scroll ; C: mouse-scroll -TUPLE: mouse-enter ; C: mouse-enter -TUPLE: mouse-leave ; C: mouse-leave -TUPLE: lose-focus ; C: lose-focus -TUPLE: gain-focus ; C: gain-focus + +SYMBOLS: +motion +mouse-scroll +mouse-enter mouse-leave +lose-focus gain-focus ; ! Higher-level actions -TUPLE: cut-action ; C: cut-action -TUPLE: copy-action ; C: copy-action -TUPLE: paste-action ; C: paste-action -TUPLE: delete-action ; C: delete-action -TUPLE: select-all-action ; C: select-all-action - -TUPLE: left-action ; C: left-action -TUPLE: right-action ; C: right-action -TUPLE: up-action ; C: up-action -TUPLE: down-action ; C: down-action - -TUPLE: zoom-in-action ; C: zoom-in-action -TUPLE: zoom-out-action ; C: zoom-out-action +SYMBOLS: +undo-action redo-action +cut-action copy-action paste-action +delete-action select-all-action +left-action right-action up-action down-action +zoom-in-action zoom-out-action ; ! Modifiers SYMBOLS: C+ A+ M+ S+ ; @@ -165,15 +158,15 @@ SYMBOL: drag-timer : fire-motion ( -- ) hand-buttons get-global empty? [ - T{ motion } hand-gadget get-global propagate-gesture + motion hand-gadget get-global propagate-gesture ] [ drag-gesture ] if ; : hand-gestures ( new old -- ) drop-prefix - T{ mouse-leave } swap each-gesture - T{ mouse-enter } swap each-gesture ; + mouse-leave swap each-gesture + mouse-enter swap each-gesture ; : forget-rollover ( -- ) f hand-world set-global @@ -182,10 +175,10 @@ SYMBOL: drag-timer parents hand-gestures ; : send-lose-focus ( gadget -- ) - T{ lose-focus } swap send-gesture ; + lose-focus swap send-gesture ; : send-gain-focus ( gadget -- ) - T{ gain-focus } swap send-gesture ; + gain-focus swap send-gesture ; : focus-child ( child gadget ? -- ) [ @@ -274,7 +267,7 @@ SYMBOL: drag-timer : send-wheel ( direction loc world -- ) move-hand scroll-direction set-global - T{ mouse-scroll } hand-gadget get-global propagate-gesture ; + mouse-scroll hand-gadget get-global propagate-gesture ; : send-action ( world gesture -- ) swap world-focus propagate-gesture ; diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index a74ac9c1ad..0c88f7b81b 100644 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -116,8 +116,8 @@ browser-gadget "navigation" "Commands for navigating in the article hierarchy" { } define-command-map browser-gadget "multi-touch" f { - { T{ left-action } com-back } - { T{ right-action } com-forward } + { left-action com-back } + { right-action com-forward } } define-command-map browser-gadget "scrolling" diff --git a/basis/ui/tools/inspector/inspector.factor b/basis/ui/tools/inspector/inspector.factor index 4b4355f4c9..bf6ac03b55 100644 --- a/basis/ui/tools/inspector/inspector.factor +++ b/basis/ui/tools/inspector/inspector.factor @@ -109,7 +109,7 @@ inspector-gadget "toolbar" f { } define-command-map inspector-gadget "multi-touch" f { - { T{ up-action } com-refresh } + { up-action com-refresh } } define-command-map : inspector ( obj -- ) diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor index 85d2e0d8b7..5287416aeb 100644 --- a/basis/ui/tools/listener/completion/completion.factor +++ b/basis/ui/tools/listener/completion/completion.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs calendar colors documents fry kernel -words sets splitting math math.vectors models.delay models.filter -combinators.short-circuit parser present sequences tools.completion -generic generic.standard.engines.tuple +USING: accessors arrays assocs calendar colors documents +documents.elements fry kernel words sets splitting math math.vectors +models.delay models.filter combinators.short-circuit parser present +sequences tools.completion generic generic.standard.engines.tuple ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.glass ui.gadgets.scrollers ui.gadgets.tables ui.gadgets.theme -ui.gadgets.worlds ui.gadgets.wrappers ui.gestures -ui.render ui.tools.listener.history ; +ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.render +ui.tools.listener.history ; IN: ui.tools.listener.completion : complete-IN:/USE:? ( tokens -- ? ) diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 145c8cec6e..9996b615f6 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -3,7 +3,7 @@ USING: accessors arrays assocs calendar combinators combinators.short-circuit compiler.units concurrency.flags concurrency.mailboxes continuations destructors documents -fry hashtables help help.markup io +documents.elements fry hashtables help help.markup io io.styles kernel lexer listener math models models.delay models.filter namespaces parser prettyprint quotations sequences strings threads tools.vocabs ui ui.commands ui.gadgets ui.gadgets.buttons @@ -406,7 +406,7 @@ listener-gadget "scrolling" } define-command-map listener-gadget "multi-touch" f { - { T{ up-action } refresh-all } + { up-action refresh-all } } define-command-map listener-gadget "other" f { diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 213431fdb0..b0ce6d82bc 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -35,8 +35,8 @@ SYMBOL: windows : focus-gestures ( new old -- ) drop-prefix - T{ lose-focus } swap each-gesture - T{ gain-focus } swap each-gesture ; + lose-focus swap each-gesture + gain-focus swap each-gesture ; : focus-world ( world -- ) t >>focused?