1 ! Copyright (C) 2005, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs classes classes.error combinators
4 combinators.short-circuit continuations debugger effects fry
5 generic help.crossref help.markup help.stylesheet help.topics io
6 io.styles kernel make namespaces prettyprint sequences sets
7 sorting vocabs words words.alias words.symbol ;
10 GENERIC: word-help* ( word -- content )
14 : inputs-and-outputs ( content word -- content' word )
15 over [ dup array? [ { $values } head? ] [ drop f ] if ] find drop [
16 '[ _ cut unclip rest ] dip [
17 stack-effect [ in>> ] [ out>> ] bi
18 [ [ dup pair? [ first ] when ] map ] bi@
19 [ '[ ?first _ member? ] filter ] bi-curry@
21 [ '[ @ _ prefix ] ] bi-curry@ bi* bi
26 : fix-shuffle ( content word -- content' word )
27 over [ { $shuffle $complex-shuffle } member? ] find drop [
28 '[ _ cut unclip ] dip [
29 stack-effect 2array 1array glue
35 : word-help ( word -- content )
36 [ dup "help" word-prop [ ] [ word-help* ] ?if ] keep
37 inputs-and-outputs fix-shuffle drop ;
39 : effect-help ( effect -- content )
40 [ in>> ] [ out>> ] bi [
43 first2 dup effect? [ \ $quotation swap 2array ] when
46 ] if [ effect>string ] dip
48 ] bi@ \ $inputs \ $outputs [ prefix ] bi-curry@ bi* 2array ;
50 M: word word-help* stack-effect effect-help ;
52 : $predicate ( element -- )
53 { { "object" object } { "?" boolean } } $values
55 "Tests if the object is an instance of the " ,
56 first "predicating" word-prop <$link> ,
58 ] { } make $description ;
60 M: predicate word-help* \ $predicate swap 2array 1array ;
62 M: class word-help* drop f ;
67 "An alias for " , def>> first <$link> , "." ,
70 : all-articles ( -- seq )
72 all-words [ word-help ] filter append ;
74 : orphan-articles ( -- seq )
75 articles get keys [ article-parent ] reject
76 { "help.home" "handbook" } diff ;
79 all-articles [ xref-article ] each ;
81 : error? ( word -- ? )
84 [ \ $error-description swap word-help elements empty? not ]
87 : sort-articles ( seq -- newseq )
88 [ article-title ] zip-with sort-values keys ;
90 : all-errors ( -- seq )
91 all-words [ error? ] filter sort-articles ;
93 M: word valid-article? drop t ;
95 M: word article-name name>> ;
98 dup [ parsing-word? ] [ symbol? ] bi or [
102 [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
108 : (word-help) ( word -- element )
111 [ \ $vocabulary swap 2array , ]
113 [ \ $related swap 2array , ]
114 [ dup global at [ get-global \ $value swap 2array , ] [ drop ] if ]
115 [ \ $definition swap 2array , ]
119 M: word article-content (word-help) ;
121 : word-with-methods ( word -- elements )
124 [ \ $methods swap 2array , ]
130 M: generic article-content word-with-methods ;
132 M: class article-content word-with-methods ;
134 M: word article-parent "help-parent" word-prop ;
136 M: word set-article-parent swap "help-parent" set-word-prop ;
138 : ($title) ( topic -- )
139 [ [ article-title ] [ >link ] bi write-object ] ($block) ;
141 : ($navigation-table) ( element -- )
142 help-path-style get dup [
143 table-style [ $table ] with-variable
146 : ($navigation-path) ( topic -- )
147 help-path-style get [
148 help-path [ reverse $breadcrumbs ] unless-empty
151 : ($navigation-link) ( content element label -- )
152 [ prefix 1array ] dip prefix , ;
154 : ($navigation-links) ( topic -- )
156 [ prev-article [ 1array \ $long-link "Prev:" ($navigation-link) ] when* ]
157 [ next-article [ 1array \ $long-link "Next:" ($navigation-link) ] when* ]
159 ] { } make [ ($navigation-table) ] unless-empty ;
161 : $title ( topic -- )
164 [ ($navigation-path) ]
165 [ ($navigation-links) ] tri
168 : print-topic ( topic -- )
171 [ $title ($blank-line) ]
172 [ article-content print-content nl ] bi ;
176 help-hook [ [ print-topic ] ] initialize
179 help-hook get call( topic -- ) ;
181 : ($index) ( articles -- )
182 sort-articles [ \ $subsection swap 2array ] map print-element ;
184 : $index ( element -- )
185 first call( -- seq ) [ ($index) ] unless-empty ;
187 : $about ( element -- )
188 first vocab-help [ 1array $subsection ] when* ;
190 : :help-debugger ( -- )
192 "Debugger commands:" print
194 ":s - data stack at error time" print
195 ":r - retain stack at error time" print
196 ":c - call stack at error time" print
197 ":edit - jump to source location (parse errors only)" print
199 ":get ( var -- value ) accesses variables at time of the error" print
200 ":vars - list all variables at error time" print ;
202 : (:help) ( error -- )
203 error-help [ help ] [ "No help for this error. " print ] if*
209 : remove-article ( name -- )
210 articles get delete-at ;
212 : add-article ( article name -- )
213 [ articles get set-at ] keep xref-article ;
215 : remove-word-help ( word -- )
216 "help" remove-word-prop ;
218 : set-word-help ( content word -- )
219 [ swap "help" set-word-prop ] keep xref-article ;