UI improvements

TODO.FACTOR.txt

@@ -1,25 +1,20 @@
 + 0.84:
 
-- browser: clicking a word in the list twice does not work
-- interactor commands: don't invoke if interactor is busy
-- new browser:
-  - show currently selected vocab & words
-  - scroll to existing won't work
-  - initial scroll dim is wrong
 - RT_WORD should refer to XTs not word objects.
-- roundoff is still not quite right with tracks
 - signal 4 on datastack underflow on mac intel??
-- new section in cookbook: philosophy
 - help gadget should not re-render every time it is grafted
 - apropos and help search
+- help browser: jump to definition command when looking at a word
 - alien-indirect
-- help browser: jump to definition
-- 3 f curry ==> a vector!
 
 ========================================================================
 
 + ui:
 
+- new section in cookbook: philosophy
+- interactor commands: don't invoke if interactor is busy
+- browser: show currently selected vocab & words
+- roundoff is still not quite right with tracks
 - fix top level window positioning
 - keyboard help persists after clicking on a link
 - grouping commands into categories

library/help/stylesheet.factor

@@ -88,9 +88,9 @@ USING: styles ;
 
 : table-style
     H{
-        { table-gap { 5 5 0 } }
+        { table-gap { 5 5 } }
         { table-border { 0.8 0.8 0.8 1.0 } }
     } ;
 
 : list-style
-    H{ { table-gap { 10 2 0 } } } ;
+    H{ { table-gap { 10 2 } } } ;

library/ui/gadgets/books.factor

@@ -6,9 +6,7 @@ kernel sequences models ;
 
 TUPLE: book pages ;
 
-: get-page ( n book -- page )
-    #! page gadgets are instantiated lazily.
-    book-pages [ dup quotation? [ call ] when dup ] change-nth ;
+: get-page ( n book -- page ) book-pages nth ;
 
 M: book model-changed ( book -- )
     [ control-model model-value ] keep
@@ -28,6 +26,4 @@ M: book pref-dim* gadget-child pref-dim ;
 M: book layout*
     dup rect-dim swap gadget-child set-layout-dim ;
 
-M: book gadget-title gadget-child gadget-title ;
-
 M: book focusable-child* gadget-child ;

library/ui/gadgets/buttons.factor

@@ -90,7 +90,7 @@ M: button-paint draw-boundary
     button-paint draw-boundary ;
 
 : <radio-control> ( model value gadget -- gadget )
-    over [ swap control-model set-model ] curry <bevel-button>
+    over [ swap control-model set-model* ] curry <bevel-button>
     swap [ swap >r = r> set-button-selected? ] curry <control> ;
 
 : <radio-box> ( model assoc -- gadget )

library/ui/gadgets/presentations.factor

@@ -31,10 +31,10 @@ C: presentation ( button object commands -- button )
     ] if* ;
 
 : show-mouse-help ( presentation -- )
-    dup find-world [ world-status set-model ] [ drop ] if* ;
+    dup find-world [ world-status set-model* ] [ drop ] if* ;
 
 : hide-mouse-help ( presentation -- )
-    find-world [ world-status f swap set-model ] when* ;
+    find-world [ world-status f swap set-model* ] when* ;
 
 presentation H{
     { T{ button-up f f 1 } [ [ 1 invoke-presentation ] if-clicked ] }
@@ -138,10 +138,10 @@ presentation H{
     >r <pane> dup r> swap <styled-paragraph>
     >r swap with-pane r> ; inline
 
-: apply-table-gap-style ( grid style -- grid style )
+: apply-table-gap-style ( style grid -- style grid )
     table-gap [ over set-grid-gap ] apply-style ;
 
-: apply-table-border-style ( grid style -- grid style )
+: apply-table-border-style ( style grid -- style grid )
     table-border [ <grid-lines> over set-gadget-boundary ]
     apply-style ;
 

library/ui/gadgets/scrolling.factor

@@ -65,7 +65,8 @@ C: scroller ( gadget -- scroller )
     ] keep dup scroller-origin rot v+ scroll ;
 
 : scroll>rect ( rect gadget -- )
-    find-scroller dup [ set-scroller-follows ] [ 2drop ] if ;
+    find-scroller dup [ [ set-scroller-follows ] 2keep ] when
+    relayout drop ;
 
 : scroll>bottom ( gadget -- )
     t swap scroll>rect ;

library/ui/text/commands.factor

@@ -52,7 +52,7 @@ sequences ;
     dupd editor-select-next mark>caret ;
 
 : editor-select ( from to editor -- )
-    tuck editor-caret set-model editor-mark set-model ;
+    tuck editor-caret set-model* editor-mark set-model* ;
 
 : select-elt ( editor elt -- )
     over >r

library/ui/text/document.factor

@@ -25,7 +25,7 @@ C: document ( -- document )
 : remove-loc document-locs delete ;
 
 : update-locs ( loc document -- )
-    document-locs [ set-model ] each-with ;
+    document-locs [ set-model* ] each-with ;
 
 : doc-line ( line# document -- str ) model-value nth ;
 

library/ui/text/editor.factor

@@ -55,10 +55,10 @@ M: editor model-changed
 : change-caret ( editor quot -- )
     over >r >r dup editor-caret* swap control-model r> call r>
     [ control-model validate-loc ] keep
-    editor-caret set-model ; inline
+    editor-caret set-model* ; inline
 
 : mark>caret ( editor -- )
-    dup editor-caret* swap editor-mark set-model ;
+    dup editor-caret* swap editor-mark set-model* ;
 
 : change-caret&mark ( editor quot -- )
     over >r change-caret r> mark>caret ; inline
@@ -92,7 +92,7 @@ M: editor model-changed
     ] keep swap 2array ;
 
 : click-loc ( editor model -- )
-    >r [ hand-rel ] keep point>loc r> set-model ;
+    >r [ hand-rel ] keep point>loc r> set-model* ;
 
 : focus-editor ( editor -- )
     t over set-editor-focused? relayout-1 ;
@@ -125,8 +125,7 @@ M: editor model-changed
     dup caret-rect swap scroll>rect ;
 
 M: loc-monitor model-changed
-    loc-monitor-editor dup scroll>caret
-    control-self relayout ;
+    loc-monitor-editor control-self scroll>caret ;
 
 : draw-caret ( -- )
     editor get editor-focused? [

library/ui/tools/browser.factor

@@ -21,6 +21,9 @@ TUPLE: definitions showing ;
     over find-definitions definitions-showing delete
     unparent ;
 
+: close-definitions ( definitions -- )
+    dup clear-gadget definitions-showing delete-all ;
+
 C: definitions ( -- gadget )
     <pile> over set-delegate
     { 2 2 } over set-pack-gap
@@ -85,11 +88,16 @@ C: browser ( -- gadget )
         { [ <definitions> ] set-browser-definitions [ <scroller> ] 3/4 }
     } { 0 1 } make-track* ;
 
-M: browser gadget-title drop "Browser" <model> ;
-
 : show-vocab ( vocab browser -- )
-    browser-navigator navigator-vocab set-model ;
+    browser-navigator navigator-vocab set-model* ;
 
 : show-word ( word browser -- )
     over word-vocabulary over show-vocab
     browser-definitions show-definition ;
+
+: clear-browser ( browser -- )
+    browser-definitions close-definitions ;
+
+browser {
+    { f "Clear" T{ key-down f f "CLEAR" } [ clear-browser ] }
+} define-commands

library/ui/tools/help.factor

@@ -27,7 +27,3 @@ C: help-gadget ( -- gadget )
     over set-help-gadget-history {
         { [ <help-pane> <scroller> ] f f @center }
     } make-frame* ;
-
-M: help-gadget gadget-title
-    help-gadget-history
-    [ "Help - " swap article-title append ] <filter> ;

library/ui/tools/listener.factor

@@ -54,8 +54,6 @@ C: listener-gadget ( -- gadget )
 M: listener-gadget focusable-child*
     listener-gadget-input ;
 
-M: listener-gadget gadget-title drop "Listener" <model> ;
-
 : listener-available? ( gadget -- ? )
     dup listener-gadget? [
         listener-gadget-input interactor-busy? not

library/ui/tools/walker.factor

@@ -67,9 +67,6 @@ walker-gadget {
     f <model> over set-walker-gadget-quot
     f <model> swap set-walker-gadget-model ;
 
-M: walker-gadget gadget-title
-    drop "Single stepper" <model> ;
-
 : (walk) ( quot continuation walker -- )
     H{ } clone over set-walker-gadget-ns [
         V{ } clone meta-history set

library/ui/tools/workspace.factor

@@ -19,8 +19,6 @@ C: tool ( gadget -- tool )
         { [ ] set-tool-gadget f @center }
     } make-frame* ;
 
-M: tool gadget-title tool-gadget gadget-title ;
-
 M: tool focusable-child* tool-gadget ;
 
 M: tool call-tool* tool-gadget call-tool* ;
@@ -29,19 +27,17 @@ TUPLE: workspace ;
 
 : workspace-tabs
     {
-        { "Listener" listener-gadget [ <listener-gadget> ] }
-        { "Walker" walker-gadget [ <walker-gadget> ] }
-        { "Definitions" browser [ <browser> ] } 
-        { "Documentation" help-gadget [ <help-gadget> ] }
+        { "Listener" <listener-gadget> }
+        { "Definitions" <browser> } 
+        { "Documentation" <help-gadget> }
+        { "Walker" <walker-gadget> }
     } ;
 
 C: workspace ( -- workspace )
-    workspace-tabs
-    [ third [ <tool> ] append ] map <book>
-    over set-gadget-delegate
-    dup dup set-control-self ;
+    workspace-tabs [ second execute <tool> ] map <book>
+    over set-gadget-delegate dup dup set-control-self ;
 
-M: workspace pref-dim* delegate pref-dim* { 500 650 } vmax ;
+M: workspace pref-dim* delegate pref-dim* { 550 650 } vmax ;
 
 : <workspace-tabs> ( book -- tabs )
     control-model
@@ -61,10 +57,8 @@ M: workspace pref-dim* delegate pref-dim* { 500 650 } vmax ;
     open-window ;
 
 : show-tool ( class workspace -- tool )
-    >r workspace-tabs [ second eq? ] find-with drop r>
-    [ get-page ] 2keep control-model set-model ;
-
-: select-tool ( workspace class -- ) swap show-tool drop ;
+    [ book-pages [ class eq? ] find-with swap ] keep
+    control-model set-model* ;
 
 : find-workspace ( -- workspace )
     [ workspace? ] find-window
@@ -77,13 +71,20 @@ M: workspace pref-dim* delegate pref-dim* { 500 650 } vmax ;
     dup find-world world-focus [ ] [ gadget-child ] ?if
     [ commands. ] "Commands" pane-window ;
 
+: select-tool ( workspace class -- ) swap show-tool drop ;
+
+: tool-window ( class -- ) workspace-window show-tool drop ;
+
 workspace {
     { f "Keyboard help" T{ key-down f f "F1" } [ commands-window ] }
     { f "Listener" T{ key-down f f "F2" } [ listener-gadget select-tool ] }
-    { f "Walker" T{ key-down f f "F3" } [ walker-gadget select-tool ] }
-    { f "Dictionary" T{ key-down f f "F4" } [ browser select-tool ] }
-    { f "Documentation" T{ key-down f f "F5" } [ help-gadget select-tool ] }
-    { f "New workspace" T{ key-down f { C+ } "n" } [ workspace-window drop ] }
+    { f "Definitions" T{ key-down f f "F3" } [ browser select-tool ] }
+    { f "Documentation" T{ key-down f f "F4" } [ help-gadget select-tool ] }
+    { f "Walker" T{ key-down f f "F5" } [ walker-gadget select-tool ] }
+
+    { f "New listener" T{ key-down f { S+ } "F2" } [ listener-gadget tool-window drop ] }
+    { f "New definitions" T{ key-down f { S+ } "F3" } [ browser tool-window drop ] }
+    { f "New documentation" T{ key-down f { S+ } "F4" } [ help-gadget tool-window drop ] }
 } define-commands
 
 ! Walker tool
@@ -258,7 +259,7 @@ quotation H{
 
 ! Tile commands
 tile
-[ tile-definition ] \ word class-operations modify-operations
+[ tile-action ] \ word class-operations modify-operations
 [ operation-tool browser eq? not ] subset
 T{ command f f "Close" f [ close-tile ] } add*
 define-commands*
@@ -266,16 +267,17 @@ define-commands*
 ! Interactor commands
 : selected-word ( editor -- string )
     dup gadget-selection?
-    [ dup T{ word-elt } select-elt ] unless ;
+    [ dup T{ word-elt } select-elt ] unless
+    gadget-selection ;
 
-: token-action ( target quot -- target quot )
-    >r selected-word r> ;
+: token-action ( quot -- quot )
+    \ selected-word add* ;
 
-: word-action ( target quot -- target quot )
-    \ search add* token-action ;
+: word-action ( quot -- quot )
+    [ selected-word search ] swap append ;
 
-: quot-action ( target quot -- target quot )
-    >r field-commit r> \ parse add* ;
+: quot-action ( quot -- quot )
+    [ field-commit parse ] swap append ;
 
 interactor [
     {
@@ -290,6 +292,6 @@ interactor [
     {
         { f "History" T{ key-down f { C+ } "h" } [ [ interactor-history. ] swap interactor-call ] }
         { f "Clear output" T{ key-down f f "CLEAR" } [ [ clear-output ] swap interactor-call ] }
-        { f "Clear stack" T{ key-down f { C+ } "CLEAR" } [ [ clear ] interactor-call ] }
+        { f "Clear stack" T{ key-down f { C+ } "CLEAR" } [ [ clear ] swap interactor-call ] }
     } <commands> %
 ] { } make define-commands*