steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Working on new UI

db4
Slava Pestov 2008-12-11 16:47:38 -06:00
parent c679ae025b
commit da94d8afae
18 changed files with 224 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
basis/help/markup/markup.factor
View File

@ -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 ;

4
basis/help/topics/topics.factor
View File

@ -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

9
basis/prettyprint/prettyprint.factor
View File

@ -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 ;

6
basis/tools/apropos/apropos-docs.factor Normal file
View File

@ -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." } ;

4
basis/tools/apropos/apropos-tests.factor Normal file
View File

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

72
basis/tools/apropos/apropos.factor Normal file
View File

@ -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 ;

18
basis/tools/completion/completion.factor
View File

@ -1,12 +1,12 @@
! 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
] [
@ -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 ] 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

5
basis/tools/crossref/crossref-docs.factor
View File

@ -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." } ;

23
basis/tools/crossref/crossref.factor
View File

@ -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
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
: 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. ;

5
basis/tools/test/tools.factor
View File

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

84
basis/tools/vocabs/browser/browser.factor
View File

@ -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 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 ( -- headings )
{
{ $strong "Vocabulary" }
{ $strong "State" }
{ $strong "Summary" }
} ;
: vocab-headings. ( -- )
[
[ "State" write ] with-cell
[ "Vocabulary" write ] with-cell
[ "Summary" write ] with-cell
] with-row ;
: 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 ;
@ -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 ;
: 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) ;
@ -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" ;

2
basis/ui/gadgets/editors/editors-tests.factor
View File

@ -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

57
basis/ui/gadgets/editors/editors.factor
View File

@ -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
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
@ -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
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
@ -548,18 +552,45 @@ TUPLE: field < wrapper field-model editor ;
{ 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
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

29
basis/ui/tools/browser/browser.factor
View File

@ -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
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 ;
@ -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

2
basis/ui/tools/deploy/deploy.factor
View File

@ -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 )

8
basis/ui/tools/interactor/interactor.factor
View File

@ -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

29
basis/ui/tools/search/search.factor
View File

@ -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
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 ;
@ -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

2
core/parser/parser.factor
View File

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