Working on new UI

basis/help/markup/markup.factor

@@ -356,4 +356,7 @@ M: array elements*
     ] H{ } make-assoc keys ;
 
 : <$link> ( topic -- element )
-    \ $link swap 2array ;
+    1array \ $link prefix ;
+
+: <$snippet> ( str -- element )
+    1array \ $snippet prefix ;

basis/help/topics/topics.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.x
 USING: accessors arrays definitions generic assocs
 io kernel namespaces make prettyprint prettyprint.sections
@@ -21,7 +21,7 @@ PREDICATE: word-link < link name>> word? ;
 M: link summary
     [
         "Link: " %
-        name>> dup word? [ summary ] [ unparse ] if %
+        name>> dup word? [ summary ] [ unparse-short ] if %
     ] "" make ;
 
 ! Help articles

basis/prettyprint/prettyprint.factor

@@ -234,15 +234,6 @@ M: pathname synopsis* pprint* ;
 
 M: word summary synopsis ;
 
-: synopsis-alist ( definitions -- alist )
-    [ dup synopsis swap ] { } map>assoc ;
-
-: definitions. ( alist -- )
-    [ write-object nl ] assoc-each ;
-
-: sorted-definitions. ( definitions -- )
-    synopsis-alist sort-keys definitions. ;
-
 GENERIC: declarations. ( obj -- )
 
 M: object declarations. drop ;

basis/tools/apropos/apropos-docs.factor

@@ -0,0 +1,6 @@
+IN: tools.apropos
+USING: help.markup help.syntax strings ;
+
+HELP: apropos
+{ $values { "str" string } }
+{ $description "Lists all words, vocabularies and help articles whose name contains a subsequence equal to " { $snippet "str" } ". Results are ranked using a simple distance algorithm." } ;

basis/tools/apropos/apropos-tests.factor

@@ -0,0 +1,4 @@
+IN: tools.apropos.tests
+USING: tools.apropos tools.test ;
+
+[ ] [ "swp" apropos ] unit-test

basis/tools/apropos/apropos.factor

@@ -0,0 +1,72 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs fry help.markup help.topics io
+kernel make math math.parser namespaces sequences sorting
+summary tools.completion tools.vocabs tools.vocabs.browser
+vocabs words unicode.case help ;
+IN: tools.apropos
+
+: $completions ( seq -- )
+    dup [ word? ] all? [ words-table ] [
+        dup [ vocab-spec? ] all? [
+            $vocabs
+        ] [
+            [ <$link> ] map $list
+        ] if
+    ] if ;
+
+TUPLE: more-completions seq ;
+
+: max-completions 5 ;
+
+M: more-completions article-title article-name ;
+
+M: more-completions article-name
+    seq>> length max-completions - number>string " more results" append ;
+
+M: more-completions article-content
+    seq>> sort-values keys \ $completions prefix ;
+
+M: more-completions summary article-title ;
+
+: (apropos) ( str candidates title -- element )
+    [
+        [ completions ] dip '[
+            _ 1array \ $heading prefix ,
+            [ max-completions short head keys \ $completions prefix , ]
+            [ dup length max-completions > [ more-completions boa 1array \ $link prefix , ] [ drop ] if ]
+            bi
+        ] unless-empty
+    ] { } make ;
+
+: word-candidates ( words -- candidates )
+    [ dup name>> >lower ] { } map>assoc ;
+
+: vocab-candidates ( -- candidates )
+    all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;
+
+: help-candidates ( seq -- candidates )
+    [ dup >link swap article-title >lower ] { } map>assoc
+    sort-values ;
+
+: $apropos ( str -- )
+    first
+    [ all-words word-candidates "Words" (apropos) ]
+    [ vocab-candidates "Vocabularies" (apropos) ]
+    [ articles get keys help-candidates "Help articles" (apropos) ]
+    tri 3array print-element ;
+
+TUPLE: apropos search ;
+
+C: <apropos> apropos
+
+M: apropos article-title
+    search>> "Search results for ``" "''" surround ;
+
+M: apropos article-name article-title ;
+
+M: apropos article-content
+    search>> 1array \ $apropos prefix ;
+
+: apropos ( str -- )
+    <apropos> print-topic ;

basis/tools/completion/completion.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays sequences math namespaces strings io
+USING: kernel arrays sequences math namespaces strings io fry
 vectors words assocs combinators sorting unicode.case
 unicode.categories math.order ;
 IN: tools.completion
@@ -61,18 +61,12 @@ IN: tools.completion
     dupd fuzzy score max ;
 
 : completion ( short candidate -- result )
-    [ second >lower swap complete ] keep first 2array ;
+    [ second >lower swap complete ] keep 2array ;
 
 : completions ( short candidates -- seq )
-    over empty? [
+    [ '[ _ ] ]
-        nip [ first ] map
+    [ '[ >lower _ [ completion ] with map rank-completions ] ] bi
-    ] [
+    if-empty ;
-        [ >lower ] dip [ completion ] with map
-        rank-completions
-    ] if ;
-
-: string-completions ( short strs -- seq )
-    dup zip completions ;
 
 : limited-completions ( short candidates -- seq )
     [ completions ] [ drop ] 2bi

basis/tools/crossref/crossref-docs.factor

@@ -3,7 +3,6 @@ IN: tools.crossref
 
 ARTICLE: "tools.crossref" "Cross-referencing tools" 
 { $subsection usage. }
-{ $subsection apropos }
 { $see-also "definitions" "words" see see-methods } ;
 
 ABOUT: "tools.crossref"
@@ -14,7 +13,3 @@ HELP: usage.
 { $examples { $code "\\ reverse usage." } } ;
 
 { usage usage. } related-words
-
-HELP: apropos
-{ $values { "str" "a string" } }
-{ $description "Lists all words whose name contains a subsequence equal to " { $snippet "str" } ". Results are ranked using a simple distance algorithm." } ;

basis/tools/crossref/crossref.factor

@@ -1,16 +1,17 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays definitions assocs io kernel
+USING: assocs definitions io io.styles kernel prettyprint
-math namespaces prettyprint sequences strings io.styles words
+sorting ;
-generic tools.completion quotations parser summary
-sorting hashtables vocabs parser source-files ;
 IN: tools.crossref
 
+: synopsis-alist ( definitions -- alist )
+    [ dup synopsis swap ] { } map>assoc ;
+
+: definitions. ( alist -- )
+    [ write-object nl ] assoc-each ;
+
+: sorted-definitions. ( definitions -- )
+    synopsis-alist sort-keys definitions. ;
+
 : usage. ( word -- )
     smart-usage sorted-definitions. ;
-
-: words-matching ( str -- seq )
-    all-words [ dup name>> ] { } map>assoc completions ;
-
-: apropos ( str -- )
-    words-matching synopsis-alist reverse definitions. ;

basis/tools/test/tools.factor

@@ -1,5 +0,0 @@
-IN: tools.test.tests
-USING: completion words sequences test ;
-
-[ ] [ "swp" apropos ] unit-test
-[ f ] [ "swp" words-matching empty? ] unit-test

basis/tools/vocabs/browser/browser.factor

@@ -11,42 +11,32 @@ IN: tools.vocabs.browser
 
 : vocab-status-string ( vocab -- string )
     {
-        { [ dup not ] [ drop "" ] }
+        { [ dup vocab not ] [ drop "" ] }
         { [ dup vocab-main ] [ drop "[Runnable]" ] }
         [ drop "[Loaded]" ]
     } cond ;
 
-: write-status ( vocab -- )
+: vocab-row ( vocab -- row )
-    vocab vocab-status-string write ;
+    [ <$link> ] [ vocab-status-string ] [ vocab-summary ] tri
+    3array ;
 
-: vocab. ( vocab -- )
+: vocab-headings ( -- headings )
-    [
+    {
-        [ [ write-status ] with-cell ]
+        { $strong "Vocabulary" }
-        [ [ ($link) ] with-cell ]
+        { $strong "State" }
-        [ [ vocab-summary write ] with-cell ] tri
+        { $strong "Summary" }
-    ] with-row ;
+    } ;
 
-: vocab-headings. ( -- )
+: root-heading ( root -- )
-    [
-        [ "State" write ] with-cell
-        [ "Vocabulary" write ] with-cell
-        [ "Summary" write ] with-cell
-    ] with-row ;
-
-: root-heading. ( root -- )
     [ "Children from " prepend ] [ "Children" ] if*
     $heading ;
 
-: $vocabs ( assoc -- )
+: $vocabs ( seq -- )
+    [ vocab-row ] map vocab-headings prefix $table ;
+
+: $vocab-roots ( assoc -- )
     [
-        [ drop ] [
+        [ drop ] [ [ root-heading ] [ $vocabs ] bi* ] if-empty
-            [ root-heading. ]
-            [
-                standard-table-style [
-                    vocab-headings. [ vocab. ] each
-                ] ($grid)
-            ] bi*
-        ] if-empty
     ] assoc-each ;
 
 TUPLE: vocab-tag name ;
@@ -74,7 +64,7 @@ C: <vocab-author> vocab-author
     ] unless-empty ;
 
 : describe-children ( vocab -- )
-    vocab-name all-child-vocabs $vocabs ;
+    vocab-name all-child-vocabs $vocab-roots ;
 
 : describe-files ( vocab -- )
     vocab-files [ <pathname> ] map [
@@ -94,7 +84,7 @@ C: <vocab-author> vocab-author
         [
             [ <$link> ]
             [ superclass <$link> ]
-            [ "slots" word-prop [ name>> ] map " " join \ $snippet swap 2array ]
+            [ "slots" word-prop [ name>> ] map " " join <$snippet> ]
             tri 3array
         ] map
         { { $strong "Class" } { $strong "Superclass" } { $strong "Slots" } } prefix
@@ -161,24 +151,24 @@ C: <vocab-author> vocab-author
         "Parsing words" $subheading
         [
             [ <$link> ]
-            [ word-syntax dup [ \ $snippet swap 2array ] when ]
+            [ word-syntax dup [ <$snippet> ] when ]
             bi 2array
         ] map
         { { $strong "Word" } { $strong "Syntax" } } prefix
         $table
     ] unless-empty ;
 
-: (describe-words) ( words heading -- )
+: words-table ( words -- )
-    '[
-        _ $subheading
     [
         [ <$link> ]
-            [ stack-effect dup [ effect>string \ $snippet swap 2array ] when ]
+        [ stack-effect dup [ effect>string <$snippet> ] when ]
         bi 2array
     ] map
     { { $strong "Word" } { $strong "Stack effect" } } prefix
-        $table
+    $table ;
-    ] unless-empty ;
+
+: (describe-words) ( words heading -- )
+    '[ _ $subheading words-table ] unless-empty ;
 
 : describe-generics ( words -- )
     "Generic words" (describe-words) ;
@@ -201,8 +191,8 @@ C: <vocab-author> vocab-author
         [ <$link> 1array ] map $table
     ] unless-empty ;
 
-: describe-words ( vocab -- )
+: $words ( words -- )
-    words [
+    [
         "Words" $heading
 
         natural-sort
@@ -229,7 +219,7 @@ C: <vocab-author> vocab-author
 
 : words. ( vocab -- )
     last-element off
-    vocab-name describe-words ;
+    words $words ;
 
 : describe-metadata ( vocab -- )
     [
@@ -239,11 +229,11 @@ C: <vocab-author> vocab-author
     ] { } make
     [ "Meta-data" $heading $table ] unless-empty ;
 
-: $describe-vocab ( element -- )
+: $vocab ( element -- )
     first {
         [ describe-help ]
         [ describe-metadata ]
-        [ describe-words ]
+        [ words $words ]
         [ describe-files ]
         [ describe-children ]
     } cleave ;
@@ -262,10 +252,10 @@ C: <vocab-author> vocab-author
     [ vocab-authors ] keyed-vocabs ;
 
 : $tagged-vocabs ( element -- )
-    first tagged $vocabs ;
+    first tagged $vocab-roots ;
 
 : $authored-vocabs ( element -- )
-    first authored $vocabs ;
+    first authored $vocab-roots ;
 
 : $all-tags ( element -- )
     drop "Tags" $heading all-tags $tags ;
@@ -282,7 +272,7 @@ M: vocab-spec article-title vocab-name " vocabulary" append ;
 M: vocab-spec article-name vocab-name ;
 
 M: vocab-spec article-content
-    vocab-name \ $describe-vocab swap 2array ;
+    vocab-name \ $vocab swap 2array ;
 
 M: vocab-spec article-parent drop "vocab-index" ;
 

basis/ui/gadgets/editors/editors-tests.factor

@@ -43,7 +43,7 @@ IN: ui.gadgets.editors.tests
 
 \ <editor> must-infer
 
-"hello" <model> <field> "field" set
+"hello" <model> <model-field> "field" set
 
 "field" get [
     [ "hello" ] [ "field" get field-model>> value>> ] unit-test

basis/ui/gadgets/editors/editors.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays documents kernel math models
+USING: accessors arrays documents kernel math models namespaces
-namespaces locals fry make opengl opengl.gl sequences strings
+locals fry make opengl opengl.gl sequences strings io.styles
-io.styles math.vectors sorting colors combinators assocs
+math.vectors sorting colors combinators assocs math.order fry
-math.order fry calendar alarms ui.clipboards ui.commands
+calendar alarms continuations ui.clipboards ui.commands
 ui.gadgets ui.gadgets.borders ui.gadgets.buttons
 ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.theme
 ui.gadgets.menus ui.gadgets.wrappers ui.render ui.gestures
@@ -452,6 +452,10 @@ editor "caret-motion" f {
     { T{ key-down f { C+ } "END" } end-of-document }
 } define-command-map
 
+: clear-editor ( editor -- )
+    #! The with-datastack is a kludge to make it infer. Stupid.
+    model>> 1array [ clear-doc ] with-datastack drop ;
+
 : select-all ( editor -- ) T{ doc-elt } select-elt ;
 
 : select-line ( editor -- ) T{ one-line-elt } select-elt ;
@@ -537,8 +541,8 @@ TUPLE: source-editor < multiline-editor ;
 : <source-editor> ( -- editor )
     source-editor new-editor ;
 
-! Fields wrap an editor and edit an external model
+! Fields wrap an editor
-TUPLE: field < wrapper field-model editor ;
+TUPLE: field < wrapper editor min-width max-width ;
 
 : field-theme ( gadget -- gadget )
     gray <solid> >>boundary ; inline
@@ -548,18 +552,45 @@ TUPLE: field < wrapper field-model editor ;
         { 1 0 } >>fill
         field-theme ;
 
-: <field> ( model -- gadget )
+: new-field ( class -- gadget )
-    <editor> dup <field-border> field new-wrapper
+    [ <editor> dup <field-border> ] dip new-wrapper swap >>editor ; inline
-        swap >>editor
-        swap >>field-model ;
 
-M: field graft*
+: column-width ( editor n -- width )
+    [ editor>> editor-font* ] dip CHAR: \s <string> string-width ;
+
+M: field pref-dim*
+    [ call-next-method ]
+    [ dup min-width>> dup [ column-width 0 2array vmax ] [ 2drop ] if ]
+    [ dup max-width>> dup [ column-width 1/0. 2array vmin ] [ 2drop ] if ]
+    tri ;
+
+TUPLE: model-field < field field-model ;
+
+: <model-field> ( model -- gadget )
+    model-field new-field swap >>field-model ;
+
+M: model-field graft*
     [ [ field-model>> value>> ] [ editor>> ] bi set-editor-string ]
     [ dup editor>> model>> add-connection ]
     bi ;
 
-M: field ungraft*
+M: model-field ungraft*
     dup editor>> model>> remove-connection ;
 
-M: field model-changed
+M: model-field model-changed
     nip [ editor>> editor-string ] [ field-model>> ] bi set-model ;
+
+TUPLE: action-field < field quot ;
+
+: <action-field> ( quot -- gadget )
+    action-field new-field swap >>quot ;
+
+: invoke-action-field ( field -- )
+    [ editor>> editor-string ]
+    [ editor>> clear-editor ]
+    [ quot>> ]
+    tri call ;
+
+action-field H{
+    { T{ key-down f f "RET" } [ invoke-action-field ] }
+} set-gestures

basis/ui/tools/browser/browser.factor

@@ -1,15 +1,16 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: debugger ui.tools.workspace help help.topics kernel
-models models.history ui.commands ui.gadgets ui.gadgets.panes
+models models.history tools.apropos ui.commands ui.gadgets
-ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
+ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
-ui.gadgets.buttons compiler.units assocs words vocabs
+ui.gestures ui.gadgets.buttons ui.gadgets.packs
-accessors fry combinators.short-circuit ;
+ui.gadgets.editors ui.gadgets.labels models compiler.units
+assocs words vocabs accessors fry combinators.short-circuit ;
 IN: ui.tools.browser
 
 TUPLE: browser-gadget < track pane history ;
 
-: show-help ( link help -- )
+: show-help ( link browser-gadget -- )
     history>> dup add-history
     [ >link ] dip set-model ;
 
@@ -19,10 +20,23 @@ TUPLE: browser-gadget < track pane history ;
 : init-history ( browser-gadget -- )
     "handbook" >link <history> >>history drop ;
 
+: search-browser ( string browser -- )
+    [ <apropos> ] dip show-help ;
+
+: <search-field> ( browser -- field )
+    '[ _ search-browser ] <action-field> 10 >>min-width 10 >>max-width ;
+
+: <browser-toolbar> ( browser -- toolbar )
+    <shelf>
+        { 5 5 } >>gap
+        over <toolbar> add-gadget
+        "Search:" <label> add-gadget
+        swap <search-field> add-gadget ;
+
 : <browser-gadget> ( -- gadget )
     { 0 1 } browser-gadget new-track
         dup init-history
-        add-toolbar
+        dup <browser-toolbar> f track-add
         dup <help-pane> >>pane
         dup pane>> <scroller> 1 track-add ;
 
@@ -60,8 +74,6 @@ M: browser-gadget definitions-changed ( assoc browser -- )
 
 : com-documentation ( browser -- ) "handbook" swap show-help ;
 
-: com-vocabularies ( browser -- ) "vocab-index" swap show-help ;
-
 : browser-help ( -- ) "ui-browser" help-window ;
 
 \ browser-help H{ { +nullary+ t } } define-command
@@ -70,7 +82,6 @@ browser-gadget "toolbar" f {
     { T{ key-down f { A+ } "LEFT" } com-back }
     { T{ key-down f { A+ } "RIGHT" } com-forward }
     { f com-documentation }
-    { f com-vocabularies }
     { T{ key-down f f "F1" } browser-help }
 } define-command-map
 

basis/ui/tools/deploy/deploy.factor

@@ -11,7 +11,7 @@ IN: ui.tools.deploy
 TUPLE: deploy-gadget < pack vocab settings ;
 
 : bundle-name ( parent -- parent )
-    deploy-name get <field>
+    deploy-name get <model-field>
     "Executable name:" label-on-left add-gadget ;
 
 : deploy-ui ( parent -- parent )

basis/ui/tools/interactor/interactor.factor

@@ -81,15 +81,11 @@ M: interactor model-changed
 : interactor-continue ( obj interactor -- )
     mailbox>> mailbox-put ;
 
-: clear-input ( interactor -- )
-    #! The with-datastack is a kludge to make it infer. Stupid.
-    model>> 1array [ clear-doc ] with-datastack drop ;
-
 : interactor-finish ( interactor -- )
     [ editor-string ] keep
     [ interactor-input. ] 2keep
     [ add-interactor-history ] keep
-    clear-input ;
+    clear-editor ;
 
 : interactor-eof ( interactor -- )
     dup interactor-busy? [
@@ -181,5 +177,5 @@ M: interactor stream-read-quot
 
 interactor "interactor" f {
     { T{ key-down f f "RET" } evaluate-input }
-    { T{ key-down f { C+ } "k" } clear-input }
+    { T{ key-down f { C+ } "k" } clear-editor }
 } define-command-map

basis/ui/tools/search/search.factor

@@ -3,12 +3,12 @@
 USING: accessors assocs help help.topics io.files io.styles
 kernel models models.delay models.filter namespaces prettyprint
 quotations sequences sorting source-files definitions strings
-tools.completion tools.crossref classes.tuple vocabs words
+tools.completion tools.apropos tools.crossref classes.tuple
-vocabs.loader tools.vocabs unicode.case calendar locals
+vocabs words vocabs.loader tools.vocabs unicode.case calendar
-ui.tools.interactor ui.tools.listener ui.tools.workspace
+locals fry ui.tools.interactor ui.tools.listener
-ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.lists
+ui.tools.workspace ui.commands ui.gadgets ui.gadgets.editors
-ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.borders
+ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
-ui.gestures ui.operations ui ;
+ui.gadgets.borders ui.gestures ui.operations ui ;
 IN: ui.tools.search
 
 TUPLE: live-search < track field list ;
@@ -55,7 +55,10 @@ search-field H{
 
 : init-search-model ( live-search seq limited? -- live-search )
     [ 2drop ]
-    [ [ limited-completions ] [ completions ] ? curry <search-model> ] 3bi
+    [
+        [ limited-completions ] [ completions ] ?
+        '[ _ @ [ first ] map ] <search-model>
+    ] 3bi
     >>model ; inline
 
 : <search-list> ( presenter live-search -- list )
@@ -84,9 +87,6 @@ M: live-search pref-dim* drop { 400 200 } ;
 : <definition-search> ( string words limited? -- gadget )
     [ definition-candidates ] dip [ synopsis ] <live-search> ;
 
-: word-candidates ( words -- candidates )
-    [ dup name>> >lower ] { } map>assoc ;
-
 : <word-search> ( string words limited? -- gadget )
     [ word-candidates ] dip [ synopsis ] <live-search> ;
 
@@ -104,10 +104,6 @@ M: live-search pref-dim* drop { 400 200 } ;
     [ "Words and methods using " swap name>> append ]
     bi show-titled-popup ;
 
-: help-candidates ( seq -- candidates )
-    [ dup >link swap article-title >lower ] { } map>assoc
-    sort-values ;
-
 : <help-search> ( string -- gadget )
     all-articles help-candidates
     f [ article-title ] <live-search> ;
@@ -134,9 +130,6 @@ M: live-search pref-dim* drop { 400 200 } ;
     [ "Source files in " swap vocab-name append ]
     bi show-titled-popup ;
 
-: vocab-candidates ( -- candidates )
-    all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;
-
 : <vocab-search> ( string -- gadget )
     vocab-candidates f [ vocab-name ] <live-search> ;
 
@@ -145,7 +138,7 @@ M: live-search pref-dim* drop { 400 200 } ;
     "Vocabulary search" show-titled-popup ;
 
 : history-candidates ( seq -- candidates )
-    [ dup <input> swap >lower ] { } map>assoc ;
+    [ [ <input> ] [ >lower ] bi ] { } map>assoc ;
 
 : <history-search> ( string seq -- gadget )
     history-candidates

core/parser/parser.factor

@@ -209,7 +209,9 @@ SYMBOL: interactive-vocabs
     "strings"
     "syntax"
     "tools.annotations"
+    "tools.apropos"
     "tools.crossref"
+    "tools.disassembler"
     "tools.memory"
     "tools.profiler"
     "tools.test"