Field gadget adds history to multi-line editor, better handling of gestures

library/bootstrap/boot-stage1.factor

@@ -202,6 +202,8 @@ sequences vectors words ;
         "/library/ui/gadgets/outliner.factor"
         "/library/ui/text/document.factor"
         "/library/ui/text/editor.factor"
+        "/library/ui/text/commands.factor"
+        "/library/ui/text/field.factor"
         "/library/ui/ui.factor"
         "/library/ui/gadgets/presentations.factor"
         "/library/ui/tools/listener.factor"

library/ui/gadgets/buttons.factor

@@ -3,7 +3,7 @@
 IN: gadgets-buttons
 USING: gadgets gadgets-borders gadgets-controls gadgets-labels
 gadgets-theme generic io kernel math models namespaces sequences
-strings styles threads ;
+strings styles threads words ;
 
 TUPLE: button rollover? pressed? selected? quot ;
 
@@ -28,13 +28,12 @@ TUPLE: button rollover? pressed? selected? quot ;
 : button-clicked ( button -- )
     dup button-quot if-clicked ;
 
-M: button gadget-gestures
+button H{
-    drop H{
     { T{ button-up } [ button-clicked ] }
     { T{ button-down } [ button-update ] }
     { T{ mouse-leave } [ button-update ] }
     { T{ mouse-enter } [ button-update ] }
-    } ;
+} set-gestures
 
 GENERIC: >label ( obj -- gadget )
 M: string >label <label> ;
@@ -61,13 +60,10 @@ C: button ( gadget quot -- button )
 
 TUPLE: repeat-button ;
 
-M: repeat-button gadget-gestures
+repeat-button H{
-    drop H{
     { T{ button-down } [ repeat-button-down ] }
     { T{ button-up } [ repeat-button-up ] }
-        { T{ mouse-leave } [ button-update ] }
+} set-gestures
-        { T{ mouse-enter } [ button-update ] }
-    } ;
 
 C: repeat-button ( gadget quot -- button )
     #! Button that calls the quotation every 100ms as long as

library/ui/gadgets/editors.factor

@@ -55,8 +55,7 @@ TUPLE: editor line caret font color ;
 : click-editor ( editor -- )
     dup hand-click-rel first over set-caret-x request-focus ;
 
-M: editor gadget-gestures
+editor H{
-    drop H{
     { T{ button-down } [ click-editor ] }
     { T{ gain-focus } [ editor-caret show-gadget ] }
     { T{ lose-focus } [ editor-caret hide-gadget ] }
@@ -75,7 +74,7 @@ M: editor gadget-gestures
     { T{ key-down f { C+ } "k" } [ [ line-clear ] with-editor ] }
     { T{ button-up f 2 } [ dup click-editor selection get paste-clipboard ] }
     { T{ paste-action } [ clipboard get paste-clipboard ] }
-    } ;
+} set-gestures
 
 : add-editor-caret 2dup set-editor-caret add-gadget ;
 

library/ui/gadgets/panes.factor

@@ -61,17 +61,13 @@ C: pane ( -- pane )
     <pile> <incremental> over add-output
     dup prepare-line ;
 
-M: pane gadget-gestures
+pane H{
-    pane-input
-    H{
     { T{ button-down } [ pane-input click-editor ] }
     { T{ key-down f f "RETURN" } [ pane-commit ] }
     { T{ key-down f f "UP" } [ pane-input [ history-prev ] with-editor ] }
     { T{ key-down f f "DOWN" } [ pane-input [ history-next ] with-editor ] }
     { T{ key-down f { C+ } "l" } [ pane-clear ] }
-    }
+} set-gestures
-    H{ }
-    ? ;
 
 : <input-pane> ( -- pane )
     <pane> "" <editor> over set-pane-input ;

library/ui/gadgets/scrolling.factor

@@ -25,12 +25,11 @@ TUPLE: scroller viewport x y follows ;
 
 : scroll-down-line scroller-y 1 swap slide-by-line ;
 
-M: scroller gadget-gestures
+scroller H{
-    drop H{
     { T{ wheel-up } [ scroll-up-line ] }
     { T{ wheel-down } [ scroll-down-line ] }
     { T{ slider-changed } [ relayout-1 ] }
-    } ;
+} set-gestures
 
 C: scroller ( gadget -- scroller )
     #! Wrap a scrolling pane around the gadget.

library/ui/gadgets/sliders.factor

@@ -62,12 +62,11 @@ TUPLE: thumb ;
     over screen>slider swap [ slider-saved + ] keep
     set-slider-value* ;
 
-M: thumb gadget-gestures
+thumb H{
-    drop H{
     { T{ button-down } [ begin-drag ] }
     { T{ button-up } [ drop ] }
     { T{ drag } [ do-drag ] }
-    } ;
+} set-gestures
 
 C: thumb ( vector -- thumb )
     dup delegate>gadget
@@ -88,8 +87,8 @@ C: thumb ( vector -- thumb )
     over screen>slider over slider-value - sgn
     swap slide-by-page ;
 
-M: elevator gadget-gestures
+elevator H{ { T{ button-down } [ elevator-click ] } }
-    drop H{ { T{ button-down } [ elevator-click ] } } ;
+set-gestures
 
 C: elevator ( vector -- elevator )
     dup delegate>gadget

library/ui/gadgets/tracks.factor

@@ -93,12 +93,11 @@ M: track pref-dim* ( track -- dim )
     dup gadget-parent divider-delta
     over divider-# rot gadget-parent change-divider ;
 
-M: divider gadget-gestures
+divider H{
-    drop H{
     { T{ button-down } [ gadget-parent save-sizes ] }
     { T{ button-up } [ drop ] }
     { T{ drag } [ divider-motion ] }
-    } ;
+} set-gestures
 
 C: divider ( -- divider )
     dup delegate>gadget dup reverse-video-theme ;

library/ui/gestures.factor

@@ -1,15 +1,20 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets
-USING: hashtables kernel math models namespaces queues sequences
+USING: generic hashtables kernel math models namespaces queues
-words ;
+sequences words ;
 
-GENERIC: gadget-gestures ( gadget -- hash )
+: (gestures) ( gadget -- )
+    [
+        dup "gestures" word-prop [ , ] when* delegate (gestures)
+    ] when* ;
 
-M: gadget gadget-gestures drop H{ } ;
+: gestures ( gadget -- seq ) [ (gestures) ] { } make ;
+
+: set-gestures ( class hash -- ) "gestures" set-word-prop ;
 
 : handle-gesture* ( gesture gadget -- )
-    tuck gadget-gestures hash [ call f ] [ drop t ] if* ;
+    tuck gestures hash-stack [ call f ] [ drop t ] if* ;
 
 : handle-gesture ( gesture gadget -- ? )
     #! If a gadget's handle-gesture* generic returns t, the
@@ -185,10 +190,9 @@ V{ } clone hand-buttons set-global
 : send-action ( world gesture -- ? )
     swap world-focus handle-gesture ;
 
-M: world gadget-gestures
+world H{
-    drop 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 ] }
-    } ;
+} set-gestures

library/ui/models.factor

@@ -119,8 +119,8 @@ M: compose set-model ( value compose -- )
 
 TUPLE: history back forward ;
 
-C: history ( -- history )
+C: history ( value -- history )
-    dup delegate>model
+    [ >r <model> r> set-delegate ] keep
     V{ } clone over set-history-back
     V{ } clone over set-history-forward ;
 

library/ui/text/document.factor

@@ -17,18 +17,15 @@ test ;
 TUPLE: document locs ;
 
 C: document ( -- document )
-    { "" } <model> over set-delegate
+    { "" } <history> over set-delegate
     V{ } clone over set-document-locs ;
 
 : add-loc document-locs push ;
 
 : remove-loc document-locs delete ;
 
-: doc-text ( document -- str )
+: update-locs ( loc document -- )
-    model-value "\n" join ;
+    document-locs [ set-model ] each-with ;
-
-: set-doc-text ( string document -- )
-    >r <string-reader> lines r> set-model ;
 
 : doc-line ( line# document -- str ) model-value nth ;
 
@@ -36,11 +33,7 @@ C: document ( -- document )
     >r 1+ r> model-value <slice> ;
 
 : start-on-line ( document from line# -- n1 )
-    >r dup first r> = [
+    >r dup first r> = [ nip second ] [ 2drop 0 ] if ;
-        nip second
-    ] [
-        2drop 0
-    ] if ;
 
 : end-on-line ( document to line# -- n2 )
     over first over = [
@@ -102,9 +95,6 @@ C: document ( -- document )
         first swap length 1- + 0
     ] if r> peek length + 2array ;
 
-: update-locs ( loc document -- )
-    document-locs [ set-model ] each-with ;
-
 : set-doc-range ( str startloc endloc document -- )
     [
         >r >r >r "\n" split r> [ text+loc ] 2keep r> r>
@@ -156,3 +146,13 @@ TUPLE: line-elt ;
 
 M: line-elt prev-elt 2drop -1 +line ;
 M: line-elt next-elt 2drop 1 +line ;
+
+: doc-text ( document -- str )
+    model-value "\n" join ;
+
+: set-doc-text ( string document -- )
+    [ >r "\n" split r> set-model ] keep
+    dup doc-end swap update-locs ;
+
+: clear-doc ( document -- )
+    "" swap set-doc-text ;

library/ui/text/editor.factor

@@ -204,99 +204,11 @@ M: editor pref-dim* ( editor -- dim )
     [ selection-start/end ] keep editor-document
     remove-doc-range ;
 
-: editor-mouse-down ( editor -- )
-    dup request-focus
-    dup
-    dup editor-caret click-loc
-    dup editor-mark click-loc ;
-
-: editor-mouse-drag ( editor -- )
-    dup editor-caret click-loc ;
-
-: editor-copy ( editor clipboard -- )
-    over editor-selection? [
-        >r editor-selection r> set-clipboard-contents
-    ] [
-        2drop
-    ] if ;
-
-: editor-cut ( editor clipboard -- )
-    dupd editor-copy remove-editor-selection ;
-
-: remove-at-caret ( editor quot -- | quot: caret editor -- from to )
-    over >r >r dup editor-caret* swap editor-document
-    r> call r> editor-document remove-doc-range ; inline
-
-: editor-delete ( editor -- )
-    dup editor-selection? [
-        remove-editor-selection
-    ] [
-        [ dupd T{ char-elt } next-elt ] remove-at-caret
-    ] if ;
-
-: editor-backspace ( editor -- )
-    dup editor-selection? [
-        remove-editor-selection
-    ] [
-        [ dupd T{ char-elt } prev-elt swap ] remove-at-caret
-    ] if ;
-
-: editor-select-prev ( editor elt -- )
-    swap [ rot prev-elt ] change-caret ;
-
-: editor-prev ( editor elt -- )
-    dupd editor-select-prev mark>caret ;
-
-: editor-select-next ( editor elt -- )
-    swap [ rot next-elt ] change-caret ;
-
-: editor-next ( editor elt -- )
-    dupd editor-select-next mark>caret ;
-
-: editor-select-home ( editor -- )
-    [ drop 0 swap =col ] change-caret ;
-
-: editor-home ( editor -- )
-    dup editor-select-home mark>caret ;
-
-: editor-select-end ( editor -- )
-    [ >r first r> line-end ] change-caret ;
-
-: editor-end ( editor -- )
-    dup editor-select-end mark>caret ;
-
-: editor-select-all ( editor -- )
-    { 0 0 } over editor-caret set-model
-    dup editor-document doc-end swap editor-mark set-model ;
-
-M: editor gadget-gestures
-    drop H{
-        { T{ button-down } [ editor-mouse-down ] }
-        { T{ drag } [ editor-mouse-drag ] }
-        { T{ gain-focus } [ focus-editor ] }
-        { T{ lose-focus } [ unfocus-editor ] }
-        { T{ paste-action } [ clipboard get paste-clipboard ] }
-        { T{ button-up f 2 } [ selection get paste-clipboard ] }
-        { T{ copy-action } [ clipboard get editor-copy ] }
-        { T{ button-up } [ selection get editor-copy ] }
-        { T{ cut-action } [ clipboard get editor-cut ] }
-        { T{ delete-action } [ remove-editor-selection ] }
-        { T{ select-all-action } [ editor-select-all ] }
-        { T{ key-down f f "LEFT" } [ T{ char-elt } editor-prev ] }
-        { T{ key-down f f "RIGHT" } [ T{ char-elt } editor-next ] }
-        { T{ key-down f f "UP" } [ T{ line-elt } editor-prev ] }
-        { T{ key-down f f "DOWN" } [ T{ line-elt } editor-next ] }
-        { T{ key-down f { S+ } "LEFT" } [ T{ char-elt } editor-select-prev ] }
-        { T{ key-down f { S+ } "RIGHT" } [ T{ char-elt } editor-select-next ] }
-        { T{ key-down f { S+ } "UP" } [ T{ line-elt } editor-select-prev ] }
-        { T{ key-down f { S+ } "DOWN" } [ T{ line-elt } editor-select-next ] }
-        { T{ key-down f f "HOME" } [ editor-home ] }
-        { T{ key-down f f "END" } [ editor-end ] }
-        { T{ key-down f { S+ } "HOME" } [ editor-select-home ] }
-        { T{ key-down f { S+ } "END" } [ editor-select-end ] }
-        { T{ key-down f f "DELETE" } [ editor-delete ] }
-        { T{ key-down f f "BACKSPACE" } [ editor-backspace ] }
-    } ;
-
 M: editor user-input* ( str editor -- ? )
     [ selection-start/end ] keep editor-document set-doc-range t ;
+
+: editor-text ( editor -- str )
+    editor-document doc-text ;
+
+: set-editor-text ( str editor -- )
+    editor-document set-doc-text ;

library/ui/text/field.factor

@@ -0,0 +1,24 @@
+! Copyright (C) 2006 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+IN: gadgets-text
+USING: gadgets generic kernel models ;
+
+TUPLE: field model ;
+
+C: field ( model -- field )
+    <editor> over set-delegate
+    [ set-field-model ] keep ;
+
+: field-prev editor-document go-back ;
+
+: field-next editor-document go-forward ;
+
+: field-commit ( field -- )
+    dup field-model [ >r editor-text r> set-model ] when*
+    editor-document dup add-history clear-doc ;
+
+field H{
+    { T{ key-down f { C+ } "p" } [ field-prev ] }
+    { T{ key-down f { C+ } "n" } [ field-next ] }
+    { T{ key-down f f "ENTER" } [ field-commit ] }
+} set-gestures

library/ui/tools/help.factor

@@ -30,7 +30,7 @@ TUPLE: help-gadget history ;
     gadget get help-gadget-history [ help ] <pane-control> ;
 
 C: help-gadget ( -- gadget )
-    <history> over set-help-gadget-history {
+    f <history> over set-help-gadget-history {
         { [ <help-toolbar> ] f f @top }
         { [ <help-pane> <scroller> ] f f @center }
     } make-frame* ;

library/ui/tools/search.factor

@@ -15,10 +15,8 @@ TUPLE: search-gadget pane input quot ;
         rot search-gadget-quot with-pane
     ] if ;
 
-M: search-gadget gadget-gestures
+search-gadget H{ { T{ key-down f f "RETURN" } [ do-search ] } }
-    drop H{
+set-gestures
-        { T{ key-down f f "RETURN" } [ do-search ] }
-    } ;
 
 C: search-gadget ( quot -- )
     [ set-search-gadget-quot ] keep {