Completion overhaul in UI

TODO.FACTOR.txt

@@ -1,14 +1,13 @@
 + 0.87:
 
+- vocab links don't work
+- browse modules and vocabs by showing a new list
+- get rid of the navigator in the browser tool
+- list gadget mouse over help
 - tabs across the bottom:
   [History] [Words] [Vocabs] [Sources] [Modules] [Help]
   to show various search gadgets
-- list: primary/secondary action
+- top level window positioning on ms windows
-- search gadget: actions should 
-- fix top level window positioning when opening new windows
-  - cocoa: [center]
-  - x11: let the wm take care of it
-  - windows: ?
 - scroll>rect broken if there are gadgets in between
 - completion is not ideal: eg, C+e "buttons"
 - crashes:
@@ -17,7 +16,7 @@
   - callback scheduling issue
   - httpd crash
   - fep when closing window
-  - got a random sig11 while reloading/recompiling
+  - : foo \ each reload foo ; foo  eventually crashes
 - these things are "Too Slow":
   - all-words
   - make-image

doc/handbook/ui/tools.facts

@@ -27,7 +27,7 @@ ARTICLE: "ui-listener" "UI listener"
 { $commands interactor "interactor" }
 { $heading "Completion" }
 "Completion commands display a gadget at the bottom of the listener, known as the mini-buffer. Typing more text narrows down the list of available items. The " { $snippet "UP" } " and " { $snippet "DOWN" } " arrow keys shift the selection between listed items, and the " { $snippet "RETURN" } " key invokes a default operation for the selected item."
-{ $commands listener-gadget "completion" }
+{ $commands listener-gadget "popups" }
 { $heading "Word commands" }
 "These commands operate on the token at the caret position in the input area."
 { $commands interactor "words" }

library/tools/completion.factor

@@ -61,11 +61,7 @@ USING: kernel arrays sequences math namespaces strings io ;
 
 : completions ( str quot candidates -- seq )
     pick empty? [
-        dup length 100 > [
+        2nip
-            3drop f
-        ] [
-            2nip
-        ] if
     ] [
         [ >r 2dup r> completion ] map 2nip rank-completions
     ] if ; inline

library/ui/commands.factor

@@ -10,6 +10,8 @@ M: command equal? eq? ;
 
 GENERIC: invoke-command ( target command -- )
 
+M: f invoke-command ( target command -- ) 2drop ;
+
 M: command invoke-command ( target command -- )
     command-quot call ;
 
@@ -58,9 +60,10 @@ SYMBOL: +name+
 SYMBOL: +quot+
 SYMBOL: +listener+
 SYMBOL: +keyboard+
-SYMBOL: +default+
+SYMBOL: +primary+
+SYMBOL: +secondary+
 
-TUPLE: operation predicate listener? default? ;
+TUPLE: operation predicate listener? primary? secondary? ;
 
 : (command) ( -- command )
     +name+ get +keyboard+ get +quot+ get <command> ;
@@ -68,7 +71,8 @@ TUPLE: operation predicate listener? default? ;
 C: operation ( predicate hash -- operation )
     swap [
         (command) over set-delegate
-        +default+ get over set-operation-default?
+        +primary+ get over set-operation-primary?
+        +secondary+ get over set-operation-secondary?
         +listener+ get over set-operation-listener?
     ] bind
     [ set-operation-predicate ] keep ;
@@ -82,8 +86,11 @@ SYMBOL: operations
     "predicate" word-prop
     operations get [ operation-predicate = ] subset-with ;
 
-: default-operation ( obj -- command )
+: primary-operation ( obj -- command )
-    object-operations [ operation-default? ] find-last nip ;
+    object-operations [ operation-primary? ] find-last nip ;
+
+: secondary-operation ( obj -- command )
+    object-operations [ operation-secondary? ] find-last nip ;
 
 : modify-operation ( quot operation -- operation )
     clone

library/ui/gadgets/lists.factor

@@ -4,15 +4,15 @@ IN: gadgets-lists
 USING: gadgets gadgets-labels gadgets-scrolling kernel sequences
 models opengl math namespaces gadgets-theme ;
 
-TUPLE: list index presenter action color ;
+TUPLE: list index hook presenter color ;
 
 : list-theme ( list -- )
     { 0.8 0.8 1.0 1.0 } swap set-list-color ;
 
-C: list ( action presenter model -- gadget )
+C: list ( hook presenter model -- gadget )
     [ swap <pile> delegate>control ] keep
     [ set-list-presenter ] keep
-    [ set-list-action ] keep
+    [ set-list-hook ] keep
     0 over set-list-index
     1 over set-pack-fill
     dup list-theme ;
@@ -67,11 +67,6 @@ M: list focusable-child* drop t ;
 : select-next ( list -- )
     dup list-index 1+ swap select-index ;
 
-: call-action ( list -- )
-    dup list-empty? [
-        dup list-value over list-action call
-    ] unless drop ;
-
 : click-list ( list -- )
     hand-gadget get [ gadget-parent list? ] find-parent
     dup [
@@ -81,10 +76,19 @@ M: list focusable-child* drop t ;
         2drop
     ] if ;
 
+: list-action ( list -- )
+    dup list-empty? [
+        drop
+    ] [
+        [
+            list-value dup secondary-operation invoke-command
+        ] keep list-hook call
+    ] if ; inline
+
 list H{
     { T{ button-down } [ dup request-focus click-list ] }
     { T{ drag } [ click-list ] }
     { T{ key-down f f "UP" } [ select-prev ] }
     { T{ key-down f f "DOWN" } [ select-next ] }
-    { T{ key-down f f "RETURN" } [ call-action ] }
+    { T{ key-down f f "RETURN" } [ list-action ] }
 } set-gestures

library/ui/gadgets/presentations.factor

@@ -14,7 +14,7 @@ styles words help math models namespaces ;
 TUPLE: presentation object ;
 
 : invoke-presentation ( presentation -- )
-    presentation-object dup default-operation invoke-command ;
+    presentation-object dup primary-operation invoke-command ;
 
 : show-mouse-help ( presentation -- )
     dup find-world [ world-status set-model* ] [ drop ] if* ;

library/ui/tools/browser.factor

@@ -8,7 +8,7 @@ gadgets-workspace help gadgets-buttons
 gadgets-search tools ;
 IN: gadgets-browser
 
-TUPLE: browser navigator definitions search ;
+TUPLE: browser navigator definitions ;
 
 TUPLE: definitions showing ;
 
@@ -49,6 +49,8 @@ C: tile ( definition -- gadget )
     <tile-content> over set-gadget-delegate
     [ set-tile-definition ] keep ;
 
+tile "toolbar" { { "Close" f [ close-tile ] } } define-commands
+
 : show-definition ( definition definitions -- )
     2dup definition-index dup 0 >= [
         over nth-gadget swap scroll>rect drop
@@ -93,18 +95,10 @@ C: browser ( -- gadget )
             [ <definitions> ]
             set-browser-definitions
             [ <scroller> ]
-            3/5
+            4/5
-        }
-        {
-            [ "" [ browser call-tool ] <word-search> ]
-            set-browser-search
-            [ "Word search" <labelled-gadget> ]
-            1/5
         }
     } { 0 1 } make-track* ;
 
-M: browser focusable-child* browser-search ;
-
 : show-vocab ( vocab browser -- )
     browser-navigator navigator-vocab set-model* ;
 

library/ui/tools/help.factor

@@ -5,7 +5,7 @@ USING: gadgets gadgets-borders gadgets-buttons
 gadgets-panes gadgets-search gadgets-scrolling help kernel
 models namespaces sequences gadgets-tracks gadgets-workspace ;
 
-TUPLE: help-gadget pane history search ;
+TUPLE: help-gadget pane history ;
 
 : show-help ( link help -- )
     dup help-gadget-history add-history
@@ -26,17 +26,9 @@ C: help-gadget ( -- gadget )
             [ <help-pane> ]
             set-help-gadget-pane
             [ <scroller> ]
-            4/5
+            @center
         }
-        {
+    } make-frame* ;
-            [ "" [ help-gadget call-tool ] <help-search> ]
-            set-help-gadget-search
-            [ "Help search" <labelled-gadget> ]
-            1/5
-        }
-    } { 0 1 } make-track* ;
-
-M: help-gadget focusable-child* help-gadget-search ;
 
 M: help-gadget call-tool* show-help ;
 

library/ui/tools/listener.factor

@@ -127,27 +127,28 @@ M: listener-gadget tool-help
 : show-titled-minibuffer ( listener gadget title -- )
     <labelled-gadget> swap show-minibuffer ;
 
-: minibuffer-action ( quot -- quot )
+: show-word-search ( listener words -- )
-    [ find-listener hide-minibuffer ] swap append ;
+    >r [ find-listener hide-minibuffer ]
-
-: show-word-search ( listener action -- )
-    minibuffer-action
     >r dup listener-gadget-input selected-word r>
-    <word-search> "Word search" show-titled-minibuffer ;
+    r> <word-search> "Word search" show-titled-minibuffer ;
 
-: show-source-files-search ( listener action -- )
+: show-help-search ( listener -- )
-    minibuffer-action
+    [ find-listener hide-minibuffer ]
-    "" swap <source-files-search>
+    "" swap <help-search> "Help search" show-titled-minibuffer ;
+
+: show-source-file-search ( listener action -- )
+    [ find-listener hide-minibuffer ]
+    "" swap <source-file-search>
     "Source file search" show-titled-minibuffer ;
 
-: show-vocabs-search ( listener action -- )
+: show-vocab-search ( listener action -- )
-    minibuffer-action
+    [ find-listener hide-minibuffer ]
     >r dup listener-gadget-input selected-word r>
-    <vocabs-search> "Vocabulary search" show-titled-minibuffer ;
+    <vocab-search> "Vocabulary search" show-titled-minibuffer ;
 
-: show-modules-search ( listener action -- )
+: show-module-search ( listener action -- )
-    minibuffer-action
+    [ find-listener hide-minibuffer ]
-    "" swap <modules-search>
+    "" swap <module-search>
     "Module search" show-titled-minibuffer ;
 
 : listener-history ( listener -- seq )
@@ -158,26 +159,12 @@ M: listener-gadget tool-help
 
 : show-history ( listener -- )
     dup listener-gadget-input editor-text
-    [ input-string history-action ] minibuffer-action
+    [ find-listener hide-minibuffer ]
     pick listener-history <history-search>
     "History search" show-titled-minibuffer ;
 
-: completion-string ( word listener -- string )
-    >r dup word-name swap word-vocabulary dup vocab r>
-    listener-gadget-use memq?
-    [ drop ] [ [ "USE: " % % " " % % ] "" make ] if ;
-
-: insert-completion ( completion -- )
-    find-listener [ completion-string ] keep
-    listener-gadget-input user-input ;
-
 listener-gadget "toolbar" {
     { "Restart" f [ start-listener ] }
-    {
-        "History"
-        T{ key-down f { C+ } "h" }
-        [ show-history ]
-    }
     {
         "Clear output"
         T{ key-down f f "CLEAR" }
@@ -191,26 +178,36 @@ listener-gadget "toolbar" {
     { "Send EOF" T{ key-down f { C+ } "d" } [ listener-eof ] }
 } define-commands
 
-listener-gadget "completion" {
+listener-gadget "popups" {
     {
         "Complete word"
         T{ key-down f f "TAB" }
-        [ [ insert-completion ] show-word-search ]
+        [ all-words show-word-search ]
-    }
-    {
-        "Edit file"
-        T{ key-down f { C+ } "e" }
-        [ [ pathname-string edit-file ] show-source-files-search ]
     }
     {
         "Use vocabulary"
         T{ key-down f { C+ } "u" }
-        [ [ [ vocab-link-name use+ ] curry call-listener ] show-vocabs-search ]
+        [ show-vocab-search ]
+    }
+    {
+        "History"
+        T{ key-down f { C+ } "p" }
+        [ show-history ]
+    }
+    {
+        "Help search"
+        T{ key-down f { C+ } "h" }
+        [ show-help-search ]
     }
     {
         "Run module"
         T{ key-down f { C+ } "m" }
-        [ [ [ module-name run-module ] curry call-listener ] show-modules-search ]
+        [ show-module-search ]
+    }
+    {
+        "Edit file"
+        T{ key-down f { C+ } "e" }
+        [ show-source-file-search ]
     }
     {
         "Hide minibuffer"

library/ui/tools/operations.factor

@@ -2,10 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-workspace
 USING: definitions gadgets gadgets-browser gadgets-dataflow
-gadgets-help gadgets-listener gadgets-text gadgets-workspace
+gadgets-help gadgets-listener gadgets-search gadgets-text
-hashtables help inference kernel namespaces parser prettyprint
+gadgets-workspace hashtables help inference kernel namespaces
-scratchpad sequences strings styles syntax test tools words
+parser prettyprint scratchpad sequences strings styles syntax
-generic models io modules ;
+test tools words generic models io modules ;
 
 V{ } clone operations set-global
 
@@ -25,7 +25,7 @@ M: operation invoke-command ( target operation -- )
 
 ! Objects
 [ drop t ] H{
-    { +default+ t }
+    { +primary+ t }
     { +name+ "Inspect" }
     { +quot+ [ inspect ] }
     { +listener+ t }
@@ -45,15 +45,17 @@ M: operation invoke-command ( target operation -- )
 
 ! Input
 [ input? ] H{
-    { +default+ t }
+    { +primary+ t }
+    { +secondary+ t }
     { +name+ "Input" }
     { +quot+ [ listener-gadget call-tool ] }
 } define-operation
 
 ! Pathnames
 [ pathname? ] H{
-    { +default+ t }
+    { +primary+ t }
     { +name+ "Edit" }
+    { +keyboard+ T{ key-down f { A+ } "e" } }
     { +quot+ [ pathname-string edit-file ] }
 } define-operation