Simplify completion, add module completion

doc/handbook/handbook.facts

@@ -10,7 +10,7 @@ ARTICLE: "handbook" "Factor documentation"
     { "The basic unit of code, corresponding to a \"function\" in other languages, is called a " { $emphasis "word" } " in Factor." }
     { "Word take inputs from the stack, and leave output values on the stack. This is documented in a " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that a word takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. See " { $link "effect-declaration" } " for details." }
     { "You can load source files with " { $link run-file } ":"
-    { $code "\"hello-world.factor\" run-file" } }
+    { $code "\"my-program.factor\" run-file" } }
     { { "You can load modules from " { $snippet "contrib/" } " and " { $snippet "examples/" } " with " { $link require } ":" }
     { $code "\"contrib/httpd\" require" } }
     { { "Some modules have a defined main entry point, and can be run just like applications in an operating system:" }

library/modules.factor

@@ -9,6 +9,11 @@ SYMBOL: modules
 
 TUPLE: module name loc files tests help main ;
 
+! For presentations
+TUPLE: module-link name ;
+
+M: module-link module-name module-link-name ;
+
 : module-def ( name -- path )
     "resource:" over ".factor" append3
     dup ?resource-path exists? [
@@ -17,8 +22,6 @@ TUPLE: module name loc files tests help main ;
         drop "resource:" swap "/load.factor" append3
     ] if ;
 
-M: module <=> [ module-name ] 2apply <=> ;
-
 : module modules get [ module-name = ] find-with nip ;
 
 : load-module ( name -- )
@@ -68,10 +71,6 @@ M: module <=> [ module-name ] 2apply <=> ;
 : test-modules ( -- )
     modules get [ module-tests* ] map concat run-tests ;
 
-: modules. ( -- )
-    modules get natural-sort
-    [ [ module-name ] keep write-object terpri ] each ;
-
 : reload-module ( module -- )
     dup module-name module-def source-modified? [
         module-name load-module
@@ -101,3 +100,33 @@ M: module synopsis* \ PROVIDE: pprint-word module-name text ;
 M: module definition module>alist t ;
 
 M: module where* module-loc ;
+
+: module-dir? ( path -- ? )
+    "load.factor" path+ resource-path exists? ;
+
+: (available-modules) ( path -- )
+    dup directory [ path+ ] map-with
+    dup [ module-dir? ] subset %
+    [ (available-modules) ] each ;
+
+: small-modules ( path -- seq )
+    dup resource-path directory [ path+ ] map-with
+    [ ".factor" tail? ] subset
+    [ ".factor" ?tail drop ] map ;
+
+: available-modules ( -- seq )
+    [
+        "library" (available-modules)
+        "contrib" (available-modules)
+        "contrib" small-modules %
+        "examples" (available-modules)
+        "examples" small-modules %
+    ] { } make natural-sort
+    [ dup module [ ] [ <module-link> ] ?if ] map ;
+
+: module-string ( obj -- str )
+    dup module-name swap module? [ " (loaded)" append ] when ;
+
+: modules. ( -- )
+    available-modules
+    [ [ module-string ] keep write-object terpri ] each ;

library/tools/completion.factor

@@ -50,31 +50,25 @@ USING: kernel arrays sequences math namespaces strings io ;
 
 : rank-completions ( results -- newresults )
     #! Discard results in the low 33%
-    [ [ second ] 2apply swap - ] sort
+    [ [ first ] 2apply swap - ] sort
-    [ 0 [ second max ] reduce 3 / ] keep
+    [ 0 [ first max ] reduce 3 / ] keep
-    [ second < ] subset-with ;
+    [ first < ] subset-with
+    [ second ] map ;
 
 : completion ( str quot obj -- pair )
     #! pair is { obj score }
-    pick empty? [
+    [ swap call dup rot fuzzy score ] keep 2array ; inline
-        2nip 1 2array
-    ] [
-        [ swap call dup rot fuzzy score ] keep swap 2array
-    ] if ; inline
 
 : completions ( str quot candidates -- seq )
     pick empty? [
         dup length 100 > [
             3drop f
         ] [
-            2nip [ 1 2array ] map
+            2nip
         ] if
     ] [
         [ >r 2dup r> completion ] map 2nip rank-completions
     ] if ; inline
 
-: completion>string ( score str -- newstr )
-    [ % " (score: " % >fixnum # ")" % ] "" make ;
-
 : string-completions ( str strs -- seq )
     f swap completions ;

library/tools/word-tools.factor

@@ -47,12 +47,8 @@ generic completion ;
         swap [ global [ inc ] bind ] curry swap append
     ] annotate ;
 
-: word-completion. ( pair -- )
-    first2 over summary completion>string swap write-object ;
-
 : word-completions ( str words -- seq )
     [ word-name ] swap completions ;
 
 : apropos ( str -- )
-    all-words word-completions
+    all-words word-completions [ . ] each ;
-    [ word-completion. terpri ] each ;

library/ui/gadgets/lists.factor

@@ -1,19 +1,20 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-lists
-USING: gadgets gadgets-scrolling kernel sequences models opengl
+USING: gadgets gadgets-labels gadgets-scrolling kernel sequences
-math namespaces ;
+models opengl math namespaces gadgets-theme ;
 
 TUPLE: list index presenter action color ;
 
 : list-theme ( list -- )
     { 0.8 0.8 1.0 1.0 } swap set-list-color ;
 
-C: list ( model presenter action -- gadget )
+C: list ( action presenter model -- gadget )
-    [ set-list-action ] keep
+    [ swap <pile> delegate>control ] keep
     [ set-list-presenter ] keep
-    dup rot <pile> 1 over set-pack-fill delegate>control
+    [ set-list-action ] keep
     0 over set-list-index
+    1 over set-pack-fill
     dup list-theme ;
 
 : bound-index ( list -- )
@@ -22,7 +23,9 @@ C: list ( model presenter action -- gadget )
 
 M: list model-changed
     dup clear-gadget
-    dup control-value over list-presenter map over add-gadgets
+    dup control-value
+    over list-presenter map [ <label> dup text-theme ] map
+    over add-gadgets
     bound-index ;
 
 : selected-rect ( list -- rect )

library/ui/test/lists.factor

@@ -1,4 +1,4 @@
 IN: temporary
 USING: gadgets-lists models prettyprint math test ;
 
-[ ] [ f <model> [ ] [ 3 + . ] <list> call-action ] unit-test
+[ ] [ [ ] [ 3 + . ] f <model> <list> call-action ] unit-test

library/ui/test/search.factor

@@ -5,13 +5,6 @@ sequences threads freetype timers kernel ;
 timers get [ init-timers ] unless
 
 [
-    [ "hey man (score: 123)" ]
-    [
-        [
-            { "hey man" 123 } [ <pathname> ] string-completion.
-        ] string-out
-    ] unit-test
-    
     "set-word-prop" [ ] <word-search> "search" set
     "search" get graft
     

library/ui/tools/listener.factor

@@ -6,7 +6,7 @@ gadgets-panes gadgets-scrolling gadgets-text gadgets-lists
 gadgets-search gadgets-theme gadgets-tracks gadgets-workspace
 generic hashtables tools io kernel listener math models
 namespaces parser prettyprint sequences shells strings styles
-threads words definitions help ;
+threads words definitions help modules ;
 
 TUPLE: listener-gadget input output stack use minibuffer ;
 
@@ -145,6 +145,11 @@ M: listener-gadget tool-help
     >r dup listener-gadget-input selected-word r>
     <vocabs-search> "Vocabulary search" show-titled-minibuffer ;
 
+: show-modules-search ( listener action -- )
+    minibuffer-action
+    "" swap <modules-search>
+    "Module search" show-titled-minibuffer ;
+
 : listener-history ( listener -- seq )
     listener-gadget-input interactor-history <reversed> ;
 
@@ -153,8 +158,9 @@ M: listener-gadget tool-help
 
 : show-history ( listener -- )
     dup listener-gadget-input editor-text
-    over listener-history [ history-action ] minibuffer-action
+    [ input-string history-action ] minibuffer-action
-    <history-search> "History search" show-titled-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>
@@ -166,7 +172,7 @@ M: listener-gadget tool-help
     listener-gadget-input user-input ;
 
 listener-gadget "toolbar" {
-    { "Restart" T{ key-down f { C+ } "r" } [ start-listener ] }
+    { "Restart" f [ start-listener ] }
     {
         "History"
         T{ key-down f { C+ } "h" }
@@ -194,12 +200,17 @@ listener-gadget "completion" {
     {
         "Edit file"
         T{ key-down f { C+ } "e" }
-        [ [ edit-file ] show-source-files-search ]
+        [ [ pathname-string edit-file ] show-source-files-search ]
     }
     {
         "Use vocabulary"
         T{ key-down f { C+ } "u" }
-        [ [ [ use+ ] curry call-listener ] show-vocabs-search ]
+        [ [ [ vocab-link-name use+ ] curry call-listener ] show-vocabs-search ]
+    }
+    {
+        "Run module"
+        T{ key-down f { C+ } "m" }
+        [ [ [ module-name run-module ] curry call-listener ] show-modules-search ]
     }
     {
         "Hide minibuffer"

library/ui/tools/search.factor

@@ -5,9 +5,9 @@ USING: arrays gadgets gadgets-labels gadgets-panes
 gadgets-scrolling gadgets-text gadgets-theme
 generic help tools kernel models sequences words
 gadgets-borders gadgets-lists namespaces parser hashtables io
-completion styles ;
+completion styles strings modules ;
 
-TUPLE: live-search field list producer action presenter ;
+TUPLE: live-search field list ;
 
 : find-live-search [ live-search? ] find-parent ;
 
@@ -15,10 +15,9 @@ TUPLE: live-search field list producer action presenter ;
 
 TUPLE: search-field ;
 
-C: search-field ( string -- gadget )
+C: search-field ( -- gadget )
     <editor> over set-gadget-delegate
     dup dup set-control-self
-    [ set-editor-text ] keep
     [ editor-doc-end ] keep ;
 
 search-field H{
@@ -27,22 +26,15 @@ search-field H{
     { T{ key-down f f "RETURN" } [ find-search-list call-action ] }
 } set-gestures
 
-: <search-model> ( -- model )
+: <search-model> ( producer -- model )
-    gadget get dup live-search-field control-model
+    gadget get live-search-field control-model 200 <delay>
-    200 <delay>
+    [ "\n" join ] <filter>
-    swap live-search-producer [ "\n" join ] swap append
+    swap <filter> ;
-    <filter> ;
 
-: <search-list>
+: <search-list> ( action seq producer presenter -- gadget )
-    <search-model>
+    -rot curry <search-model> <list> ;
-    gadget get live-search-presenter [ make-pane ] curry
-    gadget get live-search-action \ first add*
-    <list> ;
 
-C: live-search ( string action producer presenter -- gadget )
+C: live-search ( string action seq producer presenter -- gadget )
-    [ set-live-search-presenter ] keep
-    [ set-live-search-producer ] keep
-    [ set-live-search-action ] keep
     {
         {
             [ <search-field> ]
@@ -56,37 +48,48 @@ C: live-search ( string action producer presenter -- gadget )
             [ <scroller> ]
             @center
         }
-    } make-frame* ;
+    } make-frame*
+    [ live-search-field set-editor-text ] keep ;
 
 M: live-search focusable-child* live-search-field ;
 
 : <word-search> ( string action -- gadget )
     all-words
-    [ word-completions ] curry
+    [ word-completions ]
-    [ word-completion. ]
+    [ word-name ]
     <live-search> ;
 
+: help-completions ( str pairs -- seq )
+    >r >lower r>
+    [ second >lower ] swap completions
+    [ first <link> ] map ;
+
 : <help-search> ( string action -- gadget )
-    [ search-help ]
+    all-articles [ dup article-title 2array ] map
-    [ first ($link) ]
+    [ help-completions ]
+    [ article-title ]
     <live-search> ;
 
-: string-completion. ( pair quot -- )
-    >r first2 over completion>string swap r> call write-object ;
-    inline
-
 : <source-files-search> ( string action -- gadget )
     source-files get hash-keys natural-sort
-    [ string-completions ] curry
+    [ string-completions [ <pathname> ] map ]
-    [ [ <pathname> ] string-completion. ]
+    [ pathname-string ]
+    <live-search> ;
+
+: module-completions ( str modules -- seq )
+    [ module-name ] swap completions ;
+
+: <modules-search> ( string action -- gadget )
+    available-modules [ module-completions ]
+    [ module-name ]
     <live-search> ;
 
 : <vocabs-search> ( string action -- gadget )
-    vocabs [ string-completions ] curry
+    vocabs [ string-completions [ <vocab-link> ] map ]
-    [ [ <vocab-link> ] string-completion. ]
+    [ vocab-link-name ]
     <live-search> ;
 
-: <history-search> ( string seq action -- gadget )
+: <history-search> ( string action seq -- gadget )
-    swap [ string-completions ] curry
+    [ string-completions [ <input> ] map ]
-    [ first dup <input> write-object ]
+    [ input-string ]
     <live-search> ;

library/ui/ui.factor

@@ -148,7 +148,8 @@ C: labelled-gadget ( gadget title -- gadget )
 M: labelled-gadget focusable-child* labelled-gadget-content ;
 
 : <labelled-pane> ( model quot title -- gadget )
-    >r <pane-control> <scroller> r> <labelled-gadget> ;
+    >r <pane-control> t over set-pane-scrolls? <scroller> r>
+    <labelled-gadget> ;
 
 : pane-window ( quot title -- )
     >r make-pane <scroller> r> open-titled-window ;