1 ! Copyright (C) 2005, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs classes classes.tuple
4 combinators combinators.short-circuit continuations debugger
5 effects generic help.crossref help.markup help.stylesheet
6 help.topics io io.styles kernel make namespaces prettyprint
7 sequences sorting vocabs words words.symbol ;
10 GENERIC: word-help* ( word -- content )
12 : word-help ( word -- content )
13 dup "help" word-prop [ ] [
15 [ swap 2array 1array ] [ 2drop f ] if
18 : $predicate ( element -- )
19 { { "object" object } { "?" boolean } } $values
21 "Tests if the object is an instance of the " ,
22 first "predicating" word-prop <$link> ,
24 ] { } make $description ;
26 M: word word-help* drop f ;
28 M: predicate word-help* drop \ $predicate ;
30 : all-articles ( -- seq )
32 all-words [ word-help ] filter append ;
34 : orphan-articles ( -- seq )
36 [ article-parent ] reject ;
39 all-articles [ xref-article ] each ;
41 : error? ( word -- ? )
44 [ \ $error-description swap word-help elements empty? not ]
47 : sort-articles ( seq -- newseq )
48 [ dup article-title ] { } map>assoc sort-values keys ;
50 : all-errors ( -- seq )
51 all-words [ error? ] filter sort-articles ;
53 M: word valid-article? drop t ;
55 M: word article-name name>> ;
58 dup [ parsing-word? ] [ symbol? ] bi or [
62 [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
68 : (word-help) ( word -- element )
71 [ \ $vocabulary swap 2array , ]
73 [ \ $related swap 2array , ]
74 [ dup is-global [ get-global \ $value swap 2array , ] [ drop ] if ]
75 [ \ $definition swap 2array , ]
79 M: word article-content (word-help) ;
81 : word-with-methods ( word -- elements )
84 [ \ $methods swap 2array , ]
90 M: generic article-content word-with-methods ;
92 M: class article-content word-with-methods ;
94 M: word article-parent "help-parent" word-prop ;
96 M: word set-article-parent swap "help-parent" set-word-prop ;
98 : ($title) ( topic -- )
99 [ [ article-title ] [ >link ] bi write-object ] ($block) ;
101 : $navigation-row ( content element label -- )
102 [ prefix 1array ] dip prefix , ;
104 : ($navigation-table) ( element -- )
105 help-path-style get table-style [ $table ] with-variable ;
107 : $navigation-table ( topic -- )
109 [ prev-article [ 1array \ $long-link "Prev:" $navigation-row ] when* ]
110 [ next-article [ 1array \ $long-link "Next:" $navigation-row ] when* ]
112 ] { } make [ ($navigation-table) ] unless-empty ;
114 : ($navigation) ( topic -- )
115 help-path-style get [
116 [ help-path [ reverse $breadcrumbs ] unless-empty ]
117 [ $navigation-table ] bi
120 : $title ( topic -- )
123 [ ($title) ] [ ($navigation) ] bi
127 : print-topic ( topic -- )
130 [ $title ] [ ($blank-line) article-content print-content nl ] bi ;
134 help-hook [ [ print-topic ] ] initialize
137 help-hook get call( topic -- ) ;
139 : ($index) ( articles -- )
140 sort-articles [ \ $subsection swap 2array ] map print-element ;
142 : $index ( element -- )
143 first call( -- seq ) [ ($index) ] unless-empty ;
145 : $about ( element -- )
146 first vocab-help [ 1array $subsection ] when* ;
148 : :help-debugger ( -- )
150 "Debugger commands:" print
152 ":s - data stack at error time" print
153 ":r - retain stack at error time" print
154 ":c - call stack at error time" print
155 ":edit - jump to source location (parse errors only)" print
157 ":get ( var -- value ) accesses variables at time of the error" print
158 ":vars - list all variables at error time" print ;
160 : (:help) ( error -- )
161 error-help [ help ] [ "No help for this error. " print ] if*
167 : remove-article ( name -- )
168 articles get delete-at ;
170 : add-article ( article name -- )
171 [ remove-article ] keep
172 [ articles get set-at ] keep
175 : remove-word-help ( word -- )
176 f "help" set-word-prop ;
178 : set-word-help ( content word -- )
179 [ remove-word-help ] keep
180 [ swap "help" set-word-prop ] keep