] H{ } make-assoc keys ;
: <$link> ( topic -- element )
- \ $link swap 2array ;
+ 1array \ $link prefix ;
+
+: <$snippet> ( str -- element )
+ 1array \ $snippet prefix ;
-! 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
M: link summary
[
"Link: " %
- name>> dup word? [ summary ] [ unparse ] if %
+ name>> dup word? [ summary ] [ unparse-short ] if %
] "" make ;
! Help articles
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 ;
--- /dev/null
+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." } ;
--- /dev/null
+IN: tools.apropos.tests
+USING: tools.apropos tools.test ;
+
+[ ] [ "swp" apropos ] unit-test
--- /dev/null
+! 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 ;
! 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
: (fuzzy) ( accum ch i full -- accum i ? )
- index-from
+ index-from
[
[ swap push ] 2keep 1+ t
] [
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 ] dip [ completion ] with map
- rank-completions
- ] if ;
-
-: string-completions ( short strs -- seq )
- dup zip completions ;
+ [ '[ _ ] ]
+ [ '[ >lower _ [ completion ] with map rank-completions ] ] bi
+ if-empty ;
: limited-completions ( short candidates -- seq )
[ completions ] [ drop ] 2bi
ARTICLE: "tools.crossref" "Cross-referencing tools"
{ $subsection usage. }
-{ $subsection apropos }
{ $see-also "definitions" "words" see see-methods } ;
ABOUT: "tools.crossref"
{ $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." } ;
-! 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
-math namespaces prettyprint sequences strings io.styles words
-generic tools.completion quotations parser summary
-sorting hashtables vocabs parser source-files ;
+USING: assocs definitions io io.styles kernel prettyprint
+sorting ;
IN: tools.crossref
-: usage. ( word -- )
- smart-usage sorted-definitions. ;
+: synopsis-alist ( definitions -- alist )
+ [ dup synopsis swap ] { } map>assoc ;
+
+: definitions. ( alist -- )
+ [ write-object nl ] assoc-each ;
-: words-matching ( str -- seq )
- all-words [ dup name>> ] { } map>assoc completions ;
+: sorted-definitions. ( definitions -- )
+ synopsis-alist sort-keys definitions. ;
-: apropos ( str -- )
- words-matching synopsis-alist reverse definitions. ;
+: usage. ( word -- )
+ smart-usage sorted-definitions. ;
+++ /dev/null
-IN: tools.test.tests
-USING: completion words sequences test ;
-
-[ ] [ "swp" apropos ] unit-test
-[ f ] [ "swp" words-matching empty? ] unit-test
: vocab-status-string ( vocab -- string )
{
- { [ dup not ] [ drop "" ] }
+ { [ dup vocab not ] [ drop "" ] }
{ [ dup vocab-main ] [ drop "[Runnable]" ] }
[ drop "[Loaded]" ]
} cond ;
-: write-status ( vocab -- )
- vocab vocab-status-string write ;
+: vocab-row ( vocab -- row )
+ [ <$link> ] [ vocab-status-string ] [ vocab-summary ] tri
+ 3array ;
-: vocab. ( vocab -- )
- [
- [ [ write-status ] with-cell ]
- [ [ ($link) ] with-cell ]
- [ [ vocab-summary write ] with-cell ] tri
- ] with-row ;
-
-: vocab-headings. ( -- )
- [
- [ "State" write ] with-cell
- [ "Vocabulary" write ] with-cell
- [ "Summary" write ] with-cell
- ] with-row ;
+: vocab-headings ( -- headings )
+ {
+ { $strong "Vocabulary" }
+ { $strong "State" }
+ { $strong "Summary" }
+ } ;
-: root-heading. ( root -- )
+: root-heading ( root -- )
[ "Children from " prepend ] [ "Children" ] if*
$heading ;
-: $vocabs ( assoc -- )
+: $vocabs ( seq -- )
+ [ vocab-row ] map vocab-headings prefix $table ;
+
+: $vocab-roots ( assoc -- )
[
- [ drop ] [
- [ root-heading. ]
- [
- standard-table-style [
- vocab-headings. [ vocab. ] each
- ] ($grid)
- ] bi*
- ] if-empty
+ [ drop ] [ [ root-heading ] [ $vocabs ] bi* ] if-empty
] assoc-each ;
TUPLE: vocab-tag name ;
] 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 [
[
[ <$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
"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 ;
+: words-table ( words -- )
+ [
+ [ <$link> ]
+ [ stack-effect dup [ effect>string <$snippet> ] when ]
+ bi 2array
+ ] map
+ { { $strong "Word" } { $strong "Stack effect" } } prefix
+ $table ;
+
: (describe-words) ( words heading -- )
- '[
- _ $subheading
- [
- [ <$link> ]
- [ stack-effect dup [ effect>string \ $snippet swap 2array ] when ]
- bi 2array
- ] map
- { { $strong "Word" } { $strong "Stack effect" } } prefix
- $table
- ] unless-empty ;
+ '[ _ $subheading words-table ] unless-empty ;
: describe-generics ( words -- )
"Generic words" (describe-words) ;
[ <$link> 1array ] map $table
] unless-empty ;
-: describe-words ( vocab -- )
- words [
+: $words ( words -- )
+ [
"Words" $heading
natural-sort
: words. ( vocab -- )
last-element off
- vocab-name describe-words ;
+ words $words ;
: describe-metadata ( vocab -- )
[
] { } 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 ;
[ 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 ;
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" ;
\ <editor> must-infer
-"hello" <model> <field> "field" set
+"hello" <model> <model-field> "field" set
"field" get [
[ "hello" ] [ "field" get field-model>> value>> ] unit-test
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays documents kernel math models
-namespaces locals fry make opengl opengl.gl sequences strings
-io.styles math.vectors sorting colors combinators assocs
-math.order fry calendar alarms ui.clipboards ui.commands
+USING: accessors arrays documents kernel math models namespaces
+locals fry make opengl opengl.gl sequences strings io.styles
+math.vectors sorting colors combinators assocs math.order fry
+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
{ 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 ;
: <source-editor> ( -- editor )
source-editor new-editor ;
-! Fields wrap an editor and edit an external model
-TUPLE: field < wrapper field-model editor ;
+! Fields wrap an editor
+TUPLE: field < wrapper editor min-width max-width ;
: field-theme ( gadget -- gadget )
gray <solid> >>boundary ; inline
{ 1 0 } >>fill
field-theme ;
-: <field> ( model -- gadget )
- <editor> dup <field-border> field new-wrapper
- swap >>editor
- swap >>field-model ;
+: new-field ( class -- gadget )
+ [ <editor> dup <field-border> ] dip new-wrapper swap >>editor ; inline
+
+: 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: field graft*
+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
! 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
-ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
-ui.gadgets.buttons compiler.units assocs words vocabs
-accessors fry combinators.short-circuit ;
+models models.history tools.apropos ui.commands ui.gadgets
+ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
+ui.gestures ui.gadgets.buttons ui.gadgets.packs
+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 ;
: 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 ;
: 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
{ 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
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 )
: 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? [
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
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
-vocabs.loader tools.vocabs unicode.case calendar locals
-ui.tools.interactor ui.tools.listener ui.tools.workspace
-ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.lists
-ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.borders
-ui.gestures ui.operations ui ;
+tools.completion tools.apropos tools.crossref classes.tuple
+vocabs words vocabs.loader tools.vocabs unicode.case calendar
+locals fry ui.tools.interactor ui.tools.listener
+ui.tools.workspace ui.commands ui.gadgets ui.gadgets.editors
+ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
+ui.gadgets.borders ui.gestures ui.operations ui ;
IN: ui.tools.search
TUPLE: live-search < track field list ;
: 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 )
: <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> ;
[ "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> ;
[ "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> ;
"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
"strings"
"syntax"
"tools.annotations"
+ "tools.apropos"
"tools.crossref"
+ "tools.disassembler"
"tools.memory"
"tools.profiler"
"tools.test"
projects / factor.git / commitdiff