Improved UI listener and editor

library/ui/models.factor

@@ -63,8 +63,14 @@ M: model set-model ( value model -- )
 : set-model* ( value model -- )
     2dup model-value = [ 2drop ] [ set-model ] if ;
 
+: ((change-model)) ( model quot -- newvalue model )
+    over >r >r model-value r> call r> ; inline
+
 : change-model ( model quot -- )
-    over >r >r model-value r> call r> set-model ; inline
+    ((change-model)) set-model ; inline
+
+: (change-model) ( model quot -- )
+    ((change-model)) set-model-value ; inline
 
 : delegate>model ( obj -- )
     f <model> swap set-delegate ;
@@ -127,8 +133,11 @@ C: history ( value -- history )
     V{ } clone over set-history-back
     V{ } clone over set-history-forward ;
 
-: (add-history) ( history vector -- )
+G: (add-history) ( history vector -- )
-    swap model-value dup [ swap push ] [ 2drop ] if ;
+    1 standard-combination ;
+
+M: history (add-history) ( history vector -- )
+    swap model-value [ 2drop ] [ swap push ] if ;
 
 : go-back/forward ( history to from -- )
     dup empty?
@@ -141,6 +150,8 @@ C: history ( value -- history )
 : go-forward ( history -- )
     dup history-back over history-forward go-back/forward ;
 
-: add-history ( history -- )
+GENERIC: add-history ( history -- )
+
+M: history add-history ( history -- )
     0 over history-forward set-length
     dup history-back (add-history) ;

library/ui/text/commands.factor

@@ -58,7 +58,11 @@ sequences ;
     3dup next-elt >r prev-elt r>
     r> editor-select ;
 
+: select-all ( editor -- ) T{ doc-elt } select-elt ;
+
 editor H{
+    { T{ key-down f f "RETURN" } [ "\n" swap user-input ] }
+    { T{ key-down f { S+ } "RETURN" } [ "\n" swap user-input ] }
     { T{ button-down } [ editor-mouse-down ] }
     { T{ drag } [ editor-mouse-drag ] }
     { T{ gain-focus } [ focus-editor ] }

library/ui/text/document.factor

@@ -127,3 +127,14 @@ C: document ( -- document )
 
 : clear-doc ( document -- )
     "" swap set-doc-text ;
+
+M: document (add-history) ( document vector -- )
+    >r model-value dup { "" } sequence=
+    [ r> 2drop ] [ r> push-new ] if ;
+
+M: document add-history ( document -- )
+    #! Add the new entry at the end of the history, and avoid
+    #! duplicates.
+    dup history-back dup
+    pick history-forward <reversed> nappend
+    (add-history) ;

library/ui/text/editor.factor

@@ -11,16 +11,22 @@ font color caret-color selection-color
 caret mark
 focused? ;
 
-: init-editor-models ( editor -- )
+TUPLE: loc-monitor editor ;
-    dup control-self over editor-caret add-connection
+
-    dup control-self swap editor-mark add-connection ;
+M: loc-monitor model-changed ( obj -- )
+    loc-monitor-editor control-self relayout-1 ;
+
+: <loc> ( editor -- loc )
+    <loc-monitor> { 0 0 } <model> [ add-connection ] keep ;
+
+: init-editor-locs ( editor -- )
+    dup <loc> over set-editor-caret
+    dup <loc> swap set-editor-mark ;
 
 C: editor ( document -- editor )
     dup <document> delegate>control
     dup dup set-control-self
-    { 0 0 } <model> over set-editor-caret
+    dup init-editor-locs
-    { 0 0 } <model> over set-editor-mark
-    dup init-editor-models
     dup editor-theme ;
 
 : activate-editor-model ( editor model -- )
@@ -40,14 +46,16 @@ M: editor ungraft* ( editor -- )
     dup control-self swap control-model remove-connection ;
 
 M: editor model-changed ( editor -- )
-    #! Document changed
+    control-self dup control-model
-    control-self relayout ;
+    over editor-caret [ over validate-loc ] (change-model)
+    over editor-mark [ over validate-loc ] (change-model)
+    drop relayout ;
 
 : editor-caret* editor-caret model-value ;
 
 : editor-mark* editor-mark model-value ;
 
-: change-caret ( editor quot -- )
+: change-caret ( editor quot -- | quot: caret doc -- caret )
     over >r >r dup editor-caret* swap control-model r> call r>
     [ control-model validate-loc ] keep
     editor-caret set-model ; inline

library/ui/text/field.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-text
-USING: gadgets gadgets-controls generic kernel models ;
+USING: gadgets gadgets-controls generic kernel models sequences ;
 
 TUPLE: field model quot ;
 
@@ -19,7 +19,8 @@ C: field ( model quot -- field )
     [ editor-text ] keep
     dup field-model [ dupd set-model ] when*
     dup field-quot [ dupd call ] when*
-    control-model dup add-history clear-doc ;
+    dup control-model add-history
+    select-all ;
 
 field H{
     { T{ key-down f { C+ } "p" } [ field-prev ] }

library/ui/text/interactor.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-text
-USING: gadgets gadgets-controls gadgets-panes io kernel
+USING: gadgets gadgets-controls gadgets-panes hashtables help io
-namespaces prettyprint styles threads ;
+kernel namespaces prettyprint styles threads ;
 
 TUPLE: interactor output continuation ;
 
@@ -27,14 +27,15 @@ SYMBOL: structured-input
 
 : print-input ( string interactor -- )
     interactor-output [
-        dup [
+        H{ { font-style bold } } [
-            <input> presented set
+            dup <input> presented associate
-            bold font-style set
+            [ write ] with-nesting terpri
-        ] make-hash format terpri
+        ] with-style
     ] with-stream* ;
 
 : interactor-commit ( gadget -- )
     dup field-commit
+    over control-model clear-doc
     swap 2dup print-input interactor-eval ;
 
 interactor H{

library/ui/tools/listener.factor

@@ -31,34 +31,26 @@ TUPLE: listener-gadget input output stack ;
     >r <pane-control> <scroller> r> f <tile> ;
 
 : <stack-tile> ( model title -- gadget )
-    [ [ 32 margin set stack. ] with-scope ] swap <pane-tile> ;
+    [ stack. ] swap <pane-tile> ;
 
-: <listener-input> ( listener -- gadget )
+: <listener-input> ( -- gadget )
-    listener-gadget-input <scroller> "Input" f <tile> ;
+    gadget get listener-gadget-output <interactor> ;
 
-: <stack-display> ( listener -- gadget )
+: <stack-display> ( -- gadget )
-    listener-gadget-stack "Stack" <stack-tile> ;
+    gadget get listener-gadget-stack "Stack" <stack-tile> ;
-
-: <listener-bar> ( listener -- gadget )
-    dup {
-        { [ <listener-input> ] f f 2/3 }
-        { [ <stack-display> ] f f 1/3 }
-    } { 1 0 } make-track ;
 
 : init-listener ( listener -- )
-    f <model> over set-listener-gadget-stack
+    f <model> swap set-listener-gadget-stack ;
-    <scrolling-pane> over set-listener-gadget-output
-    dup listener-gadget-output <interactor>
-    swap set-listener-gadget-input ;
 
 C: listener-gadget ( -- gadget )
     dup init-listener {
-        { [ gadget get listener-gadget-output <scroller> ] f f 5/6 }
+        { [ <scrolling-pane> ] set-listener-gadget-output [ <scroller> ] 4/6 }
-        { [ gadget get <listener-bar> ] f f 1/6 }
+        { [ <stack-display> ] f f 1/6 }
+        { [ <listener-input> ] set-listener-gadget-input [ <scroller> ] 1/6 }
     } { 0 1 } make-track* dup start-listener ;
 
 M: listener-gadget pref-dim*
-    delegate pref-dim* { 700 500 } vmax ;
+    delegate pref-dim* { 500 600 } vmax ;
 
 M: listener-gadget focusable-child* ( listener -- gadget )
     listener-gadget-input ;