1 ! Copyright (C) 2005, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays definitions generic io kernel assocs hashtables
4 namespaces parser prettyprint sequences strings io.styles
5 vectors words math sorting splitting classes
6 slots vocabs help.stylesheet help.topics vocabs.loader ;
9 ! Simple markup language.
11 ! <element> ::== <string> | <simple-element> | <fancy-element>
12 ! <simple-element> ::== { <element>* }
13 ! <fancy-element> ::== { <type> <element> }
15 ! Element types are words whose name begins with $.
17 PREDICATE: simple-element < array
18 dup empty? [ drop t ] [ first word? not ] if ;
25 : last-span? ( -- ? ) last-element get span eq? ;
26 : last-block? ( -- ? ) last-element get block eq? ;
29 last-block? [ nl ] when
33 GENERIC: print-element ( element -- )
35 M: simple-element print-element [ print-element ] each ;
36 M: string print-element [ write ] ($span) ;
37 M: array print-element unclip execute ;
38 M: word print-element { } swap execute ;
39 M: f print-element drop ;
41 : print-element* ( element style -- )
42 [ print-element ] with-style ;
44 : with-default-style ( quot -- )
45 default-span-style get [
47 default-block-style get swap with-nesting
50 : print-content ( element -- )
51 [ print-element ] with-default-style ;
53 : ($block) ( quot -- )
54 last-element get { f table } member? [ nl ] unless
57 block last-element set ; inline
61 : $snippet ( children -- )
62 [ snippet-style get print-element* ] ($span) ;
64 : $emphasis ( children -- )
65 [ emphasis-style get print-element* ] ($span) ;
67 : $strong ( children -- )
68 [ strong-style get print-element* ] ($span) ;
70 : $url ( children -- )
71 [ url-style get print-element* ] ($span) ;
77 : ($heading) ( children quot -- )
78 last-element get [ nl ] when ($block) ; inline
80 : $heading ( element -- )
81 [ heading-style get print-element* ] ($heading) ;
83 : $subheading ( element -- )
84 [ strong-style get print-element* ] ($heading) ;
86 : ($code-style) ( presentation -- hash )
87 presented associate code-style get assoc-union ;
89 : ($code) ( presentation quot -- )
93 >r ($code-style) r> with-nesting
97 : $code ( element -- )
98 "\n" join dup <input> [ write ] ($code) ;
100 : $syntax ( element -- ) "Syntax" $heading $code ;
102 : $description ( element -- )
103 "Word description" $heading print-element ;
105 : $class-description ( element -- )
106 "Class description" $heading print-element ;
108 : $error-description ( element -- )
109 "Error description" $heading print-element ;
111 : $var-description ( element -- )
112 "Variable description" $heading print-element ;
114 : $contract ( element -- )
115 "Generic word contract" $heading print-element ;
117 : $examples ( element -- )
118 "Examples" $heading print-element ;
120 : $example ( element -- )
121 1 cut* swap "\n" join dup <input> [
122 input-style get format nl print-element
125 : $unchecked-example ( element -- )
126 #! help-lint ignores these.
129 : $markup-example ( element -- )
130 first dup unparse " print-element" append 1array $code
133 : $warning ( element -- )
137 "Warning" $heading print-element
142 : write-link ( string object -- )
143 link-style get [ write-object ] with-style ;
145 : ($link) ( article -- )
146 [ dup article-name swap >link write-link ] ($span) ;
148 : $link ( element -- )
151 : ($long-link) ( object -- )
152 dup article-title swap >link write-link ;
154 : ($subsection) ( element quot -- )
156 subsection-style get [
162 : $subsection ( element -- )
163 [ first ($long-link) ] ($subsection) ;
165 : ($vocab-link) ( text vocab -- )
166 >vocab-link write-link ;
168 : $vocab-subsection ( element -- )
170 first2 dup vocab-help dup [
177 : $vocab-link ( element -- )
178 first dup vocab-name swap ($vocab-link) ;
180 : $vocabulary ( element -- )
181 first word-vocabulary [
182 "Vocabulary" $heading nl dup ($vocab-link)
185 : textual-list ( seq quot -- )
186 [ ", " print-element ] swap interleave ; inline
188 : $links ( topics -- )
189 [ [ ($link) ] textual-list ] ($span) ;
191 : $see-also ( topics -- )
192 "See also" $heading $links ;
194 : related-words ( seq -- )
195 dup [ "related" set-word-prop ] curry each ;
197 : $related ( element -- )
198 first dup "related" word-prop remove dup empty?
199 [ drop ] [ $see-also ] if ;
201 : ($grid) ( style quot -- )
203 table-content-style get [
204 swap [ last-element off call ] tabular-output
206 ] ($block) table last-element set ; inline
208 : $list ( element -- )
212 bullet get write-cell
213 [ print-element ] with-cell
218 : $table ( element -- )
222 [ [ print-element ] with-cell ] each
227 : a/an ( str -- str )
228 first "aeiou" member? "an" "a" ? ;
230 GENERIC: ($instance) ( element -- )
233 dup word-name a/an write bl ($link) ;
235 M: string ($instance)
236 dup a/an write bl $snippet ;
238 : $instance ( children -- ) first ($instance) ;
240 : values-row ( seq -- seq )
241 unclip \ $snippet swap ?word-name 2array
242 swap dup first word? [ \ $instance prefix ] when 2array ;
244 : $values ( element -- )
245 "Inputs and outputs" $heading
246 [ values-row ] map $table ;
248 : $side-effects ( element -- )
249 "Side effects" $heading "Modifies " print-element
250 [ $snippet ] textual-list ;
252 : $errors ( element -- )
253 "Errors" $heading print-element ;
255 : $notes ( element -- )
256 "Notes" $heading print-element ;
261 code-style get [ see ] with-nesting
265 : $see ( element -- ) first ($see) ;
267 : $definition ( element -- )
268 "Definition" $heading $see ;
270 : $value ( object -- )
271 "Variable value" $heading
272 "Current value in global namespace:" print-element
273 first dup [ pprint-short ] ($code) ;
275 : $curious ( element -- )
276 "For the curious..." $heading print-element ;
278 : $references ( element -- )
279 "References" $heading
280 unclip print-element [ \ $link swap ] { } map>assoc $list ;
282 : $shuffle ( element -- )
284 "Shuffle word. Re-arranges the stack according to the stack effect pattern." $description ;
286 : $low-level-note ( children -- )
288 "Calling this word directly is not necessary in most cases. Higher-level words call it automatically." $notes ;
290 : $values-x/y ( children -- )
291 drop { { "x" number } { "y" number } } $values ;
293 : $parsing-note ( children -- )
295 "This word should only be called from parsing words."
298 : $io-error ( children -- )
300 "Throws an error if the I/O operation fails." $errors ;
302 : $prettyprinting-note ( children -- )
304 "This word should only be called from inside the "
305 { $link with-pprint } " combinator."
308 GENERIC: elements* ( elt-type element -- )
310 M: simple-element elements* [ elements* ] with each ;
312 M: object elements* 2drop ;
315 [ [ elements* ] with each ] 2keep
316 [ first eq? ] keep swap [ , ] [ drop ] if ;
318 : elements ( elt-type element -- seq ) [ elements* ] { } make ;
320 : collect-elements ( element seq -- elements )
324 rest [ dup set ] each
327 ] H{ } make-assoc keys ;