Improved UI completion

TODO.FACTOR.txt

@@ -1,17 +1,20 @@
-- print-quot -- present commands directly
 - auto-invoke code gc
 - fix alien-callback/SEH bug on win32
-
+- list mouse gestures
-+ ui:
+- search gadget should use list
-
+- maybe simplify list into displaying list a sequence of strings
 - control delegating to a pane is wrong
 - the mouse button overload sucks, use popup menus instead
 - nested presentation mouse over is not right
 - ui quick start doc
 - x11: scroll up/down wiggles caret
 - slider needs to be modelized
-- [ ] write in the UI breaks stuff
 - some way of intercepting all gestures
+- better help result ranking
+
++ ui:
+
+- [ ] write in the UI breaks stuff
 - pane output in UI should use less memory
 - variable width word wrap
   - needs layout tricks
@@ -23,12 +26,9 @@
   - modules can be (re)loaded
   - keyboard navigation
 - ui browser: show currently selected vocab & words
-  - keyboard-navigatable list gadget of some kind
 - auto-update browser and help when sources reload
 - how do we refer to command shortcuts in the docs?
 - figure out if we need both set-model and set-model*
-- full-height nodes should really be full height
-- better help result ranking
 - roundoff is still not quite right with tracks
 - fix top level window positioning
 - x11.app has a problem with A+ keys

library/tools/word-tools.factor

@@ -94,8 +94,7 @@ generic ;
     #! triple is { score indices word }
     [
         word-name [ swap fuzzy ] keep swap [ score ] keep
-    ] keep
+    ] keep 3array ;
-    3array ;
 
 : completions ( str words -- seq )
     [ completion ] map-with [ first zero? not ] subset
@@ -107,13 +106,14 @@ generic ;
         [ hilite-style >r ch>string r> format ] [ write1 ] if 
     ] 2each drop ;
 
-: (apropos) ( str words -- )
+: completion. ( completions -- )
-    completions [
     first3 dup presented associate [
         dup word-vocabulary write bl word-name fuzzy.
         " (score: " swap >fixnum number>string ")" append3
         write
-        ] with-nesting terpri
+    ] with-nesting ;
-    ] each ;
+
+: (apropos) ( str words -- )
+    completions [ completion. terpri ] each ;
 
 : apropos ( str -- ) all-words (apropos) ;

library/ui/gadgets/lists.factor

@@ -1,38 +1,56 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-lists
-USING: gadgets kernel sequences models opengl math ;
+USING: gadgets gadgets-scrolling kernel sequences models opengl
+math ;
 
-TUPLE: list index quot color ;
+TUPLE: list index presenter action color ;
 
-C: list ( model quot -- gadget )
+: list-theme ( list -- )
-    [ set-list-quot ] keep
+    { 0.8 0.8 1.0 1.0 } swap set-list-color ;
+
+C: list ( model presenter action -- gadget )
+    [ set-list-action ] keep
+    [ set-list-presenter ] keep
+    dup rot <pile> 1 over set-pack-fill delegate>control
     0 over set-list-index
-    { 0.8 0.8 1.0 1.0 } over set-list-color
+    dup list-theme ;
-    dup rot <pile> 1 over set-pack-fill delegate>control ;
 
 M: list model-changed
     dup clear-gadget
-    dup control-value over list-quot map
+    dup control-value over list-presenter map
     swap add-gadgets ;
 
+: selected-rect ( list -- rect )
+    dup list-index swap gadget-children 2dup bounds-check?
+    [ nth ] [ 2drop f ] if ;
+
 M: list draw-gadget*
     dup list-color gl-color
-    dup list-index swap gadget-children 2dup bounds-check? [
+    selected-rect [
-        nth rect-bounds swap [ gl-fill-rect ] with-translation
+        rect-bounds swap [ gl-fill-rect ] with-translation
-    ] [
+    ] when* ;
-        2drop
-    ] if ;
 
 M: list focusable-child* drop t ;
 
+: list-value ( list -- object )
+    dup control-value empty? [
+        drop f
+    ] [
+        dup list-index swap control-value nth
+    ] if ;
+
+: scroll>selected ( list -- )
+    dup selected-rect swap scroll>rect ;
+
 : select-index ( n list -- )
     dup control-value empty? [
         2drop
     ] [
         [ control-value length rem ] keep
         [ set-list-index ] keep
-        relayout-1
+        [ relayout-1 ] keep
+        scroll>selected
     ] if ;
 
 : select-prev ( list -- )
@@ -41,8 +59,12 @@ M: list focusable-child* drop t ;
 : select-next ( list -- )
     dup list-index 1+ swap select-index ;
 
+: call-action ( list -- )
+    dup list-value swap list-action call ;
+
 \ list H{
     { T{ button-down } [ request-focus ] }
     { T{ key-down f f "UP" } [ select-prev ] }
     { T{ key-down f f "DOWN" } [ select-next ] }
+    { T{ key-down f f "RETURN" } [ call-action ] }
 } set-gestures

library/ui/gadgets/presentations.factor

@@ -1,5 +1,8 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+IN: gadgets-listener
+DEFER: call-listener
+
 IN: gadgets-presentations
 USING: arrays definitions gadgets gadgets-borders
 gadgets-buttons gadgets-grids gadgets-labels gadgets-outliner
@@ -94,6 +97,9 @@ presentation H{
         <presentation-mouse-help> ,
     ] { } make make-pile 1 over set-pack-fill ;
 
+: <listener-button> ( gadget quot -- button )
+    [ call-listener ] curry <roll-button> ;
+
 ! Character styles
 
 : apply-style ( style gadget key quot -- style gadget )
@@ -116,12 +122,16 @@ presentation H{
 : apply-presentation-style ( style gadget -- style gadget )
     presented [ <object-presentation> ] apply-style ;
 
+: apply-quotation-style ( style gadget -- style gadget )
+    quotation [ <listener-button> ] apply-style ;
+
 : <styled-label> ( style text -- gadget )
     <label>
     apply-foreground-style
     apply-background-style
     apply-font-style
     apply-presentation-style
+    apply-quotation-style
     nip ;
 
 ! Paragraph styles
@@ -154,6 +164,7 @@ presentation H{
     apply-border-color-style
     apply-page-color-style
     apply-presentation-style
+    apply-quotation-style
     apply-outliner-style
     nip ;
 

library/ui/text/commands.factor

@@ -65,6 +65,11 @@ USING: gadgets kernel models namespaces sequences ;
 
 : editor-doc-end ( editor -- ) T{ doc-elt } editor-next ;
 
+: selected-word ( editor -- string )
+    dup gadget-selection?
+    [ dup T{ word-elt } select-elt ] unless
+    gadget-selection ;
+
 editor "Editing commands" {
     { "Insert newline" T{ key-down f f "RETURN" } [ "\n" swap user-input ] }
     { "Insert newline" T{ key-down f { S+ } "RETURN" } [ "\n" swap user-input ] }

library/ui/tools/listener.factor

@@ -2,14 +2,16 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-listener
 USING: compiler arrays gadgets gadgets-frames gadgets-labels
-gadgets-panes gadgets-scrolling gadgets-text gadgets-theme
+gadgets-panes gadgets-scrolling gadgets-text gadgets-lists
-gadgets-tracks gadgets-workspace generic hashtables tools io
+gadgets-theme gadgets-tracks gadgets-workspace generic
-kernel listener math models namespaces parser prettyprint
+hashtables tools io kernel listener math models namespaces
-sequences shells strings styles threads words memory ;
+parser prettyprint sequences shells strings styles threads words
+memory ;
 
-TUPLE: listener-gadget input output stack ;
+TUPLE: listener-gadget input output stack minibuffer use ;
 
 : ui-listener-hook ( listener -- )
+    use get over set-listener-gadget-use
     >r datastack r> listener-gadget-stack set-model ;
 
 : listener-stream ( listener -- stream )
@@ -72,16 +74,6 @@ M: listener-gadget tool-help
 : listener-eof ( listener -- )
     listener-gadget-input f swap interactor-eval ;
 
-: (listener-history) ( listener -- )
-    dup listener-gadget-output [
-        listener-gadget-input interactor-history
-        [ dup print-input ] each
-    ] with-stream* ;
-
-: listener-history ( listener -- )
-    [ [ (listener-history) ] curry ] keep
-    call-listener ;
-
 : clear-listener-output ( listener -- )
     [ listener-gadget-output [ pane-clear ] curry ] keep
     call-listener ;
@@ -89,10 +81,79 @@ M: listener-gadget tool-help
 : clear-listener-stack ( listener -- )
     [ clear ] swap call-listener ;
 
+: hide-minibuffer ( listener -- )
+    dup listener-gadget-minibuffer dup
+    [ over track-remove ] [ drop ] if
+    dup listener-gadget-input request-focus
+    f swap set-listener-gadget-minibuffer ;
+
+: show-minibuffer ( gadget listener -- )
+    [ hide-minibuffer ] keep
+    [ set-listener-gadget-minibuffer ] 2keep
+    dupd track-add request-focus ;
+
+: show-list ( seq presenter action listener -- )
+    >r >r >r <model> r> r> <list> <scroller> r>
+    show-minibuffer ;
+
+: show-history ( listener -- )
+    [
+        listener-gadget-input interactor-history <reversed>
+        [ [ dup print-input ] make-pane ]
+        [
+            find-listener
+            [ listener-gadget-input set-editor-text ] keep
+            hide-minibuffer
+        ]
+    ] keep show-list ;
+
+: insert-completion ( completion -- )
+    find-listener [
+        >r peek word-name r> listener-gadget-input user-input
+    ] keep hide-minibuffer ;
+
+: show-completions ( listener words -- )
+    over listener-gadget-input selected-word swap completions
+    over
+    >r [ [ completion. ] make-pane ] [ insert-completion ] r>
+    show-list ;
+
+: used-words ( listener -- seq )
+    listener-gadget-use
+    [ [ hash-values [ dup set ] each ] each ] make-hash
+    hash-values natural-sort ;
+
 listener-gadget "Listener commands" {
     { "Restart" T{ key-down f { C+ } "r" } [ start-listener ] }
     { "Send EOF" T{ key-down f { C+ } "d" } [ listener-eof ] }
-    { "History" T{ key-down f { C+ } "h" } [ listener-history ] }
+    {
-    { "Clear output" T{ key-down f f "CLEAR" } [ clear-listener-output ] }
+        "History"
-    { "Clear stack" T{ key-down f { C+ } "CLEAR" } [ clear-listener-stack ] }
+        T{ key-down f "UP" }
+        [ show-history ]
+    }
+    {
+        "Clear output"
+        T{ key-down f f "CLEAR" }
+        [ clear-listener-output ]
+    }
+    {
+        "Clear stack"
+        T{ key-down f { C+ } "CLEAR" }
+        [ clear-listener-stack ]
+    }
+    {
+        "Complete word (used vocabs)"
+        T{ key-down f f "TAB" }
+        [ dup used-words show-completions ]
+    }
+    {
+        "Complete word (all vocabs)"
+        T{ key-down f f "TAB" }
+        [ all-words show-completions ]
+    }
+    {
+        "Hide minibuffer"
+        T{ key-down f f "ESCAPE" }
+        [ hide-minibuffer ]
+    }
 } define-commands

library/ui/tools/operations.factor

@@ -143,26 +143,6 @@ M: operation invoke-command ( target operation -- )
     { +quot+ [ link-name browser call-tool ] }
 } define-operation
 
-! Strings
-[ string? ] H{
-    { +name+ "Apropos (all)" }
-    { +keyboard+ T{ key-down f { A+ } "a" } }
-    { +quot+ [ apropos ] }
-    { +listener+ t }
-} define-operation
-
-: usable-words ( -- seq )
-    [
-        use get [ hash-values [ dup set ] each ] each
-    ] make-hash hash-values natural-sort ;
-
-[ string? ] H{
-    { +name+ "Apropos (used)" }
-    { +keyboard+ T{ key-down f f "TAB" } }
-    { +quot+ [ usable-words (apropos) ] }
-    { +listener+ t }
-} define-operation
-
 ! Quotations
 [ quotation? ] H{
     { +name+ "Infer" }
@@ -216,13 +196,6 @@ tile "Word commands"
 define-commands
 
 ! Interactor commands
-
-! Listener commands
-: selected-word ( editor -- string )
-    dup gadget-selection?
-    [ dup T{ word-elt } select-elt ] unless
-    gadget-selection ;
-
 : word-action ( target -- quot )
     selected-word search ;
 
@@ -234,16 +207,12 @@ interactor "Word commands"
 [ word-action ] modify-listener-operations
 define-commands
 
-interactor "Word search commands"
-string class-operations
-[ selected-word ] modify-listener-operations
-define-commands
-
 interactor "Quotation commands"
 quotation class-operations
 [ quot-action ] modify-listener-operations
 define-commands
 
+! Help commands
 help-gadget "Link commands"
 link class-operations [ help-action ] modify-operations
 [ command-name "Follow" = not ] subset