1 ! Copyright (C) 2005, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs classes colors colors.constants
4 combinators definitions definitions.icons effects fry generic
5 hashtables help.stylesheet help.topics io io.styles kernel make
6 math namespaces parser present prettyprint
7 prettyprint.stylesheet quotations see sequences sets slots
8 sorting splitting strings vectors vocabs vocabs.loader words
10 FROM: prettyprint.sections => with-pprint ;
13 PREDICATE: simple-element < array
14 [ t ] [ first word? not ] if-empty ;
21 : last-span? ( -- ? ) last-element get span eq? ;
22 : last-block? ( -- ? ) last-element get block eq? ;
23 : last-blank-line? ( -- ? ) last-element get blank-line eq? ;
30 : ($blank-line) ( -- )
31 nl nl blank-line last-element set ;
34 last-block? [ nl ] when
38 GENERIC: print-element ( element -- )
40 M: simple-element print-element [ print-element ] each ;
41 M: string print-element [ write ] ($span) ;
42 M: array print-element unclip execute( arg -- ) ;
43 M: word print-element { } swap execute( arg -- ) ;
44 M: f print-element drop ;
46 : print-element* ( element style -- )
47 [ print-element ] with-style ;
49 : with-default-style ( quot -- )
50 default-span-style get [
51 default-block-style get swap with-nesting
54 : print-content ( element -- )
55 [ print-element ] with-default-style ;
57 : ($block) ( quot -- )
61 block last-element set ; inline
65 : $snippet ( children -- )
66 [ snippet-style get print-element* ] ($span) ;
71 : $emphasis ( children -- )
72 [ emphasis-style get print-element* ] ($span) ;
74 : $strong ( children -- )
75 [ strong-style get print-element* ] ($span) ;
77 : $url ( children -- )
79 dup first href associate url-style get assoc-union
84 drop nl last-element get [ nl ] when
85 blank-line last-element set ;
88 : ($heading) ( children quot -- )
91 : $heading ( element -- )
92 [ heading-style get print-element* ] ($heading) ;
94 : $subheading ( element -- )
95 [ strong-style get print-element* ] ($heading) ;
97 : ($code-style) ( presentation -- hash )
98 presented associate code-style get assoc-union ;
100 : ($code) ( presentation quot -- )
102 code-char-style get [
104 [ ($code-style) ] dip with-nesting
108 : $code ( element -- )
109 "\n" join dup <input> [ write ] ($code) ;
111 : $syntax ( element -- ) "Syntax" $heading $code ;
113 : $description ( element -- )
114 "Word description" $heading print-element ;
116 : $class-description ( element -- )
117 "Class description" $heading print-element ;
119 : $error-description ( element -- )
120 "Error description" $heading print-element ;
122 : $var-description ( element -- )
123 "Variable description" $heading print-element ;
125 : $contract ( element -- )
126 "Generic word contract" $heading print-element ;
128 : $examples ( element -- )
129 "Examples" $heading print-element ;
131 : $example ( element -- )
132 1 cut* swap "\n" join dup <input> [
133 input-style get format nl print-element
136 : $unchecked-example ( element -- )
137 #! help-lint ignores these.
140 : $markup-example ( element -- )
141 first dup unparse " print-element" append 1array $code
144 : $warning ( element -- )
148 "Warning" $heading print-element
152 : $deprecated ( element -- )
154 deprecated-style get [
156 "This word is deprecated" $heading print-element
161 : $image ( element -- )
162 [ first write-image ] ($span) ;
164 : <$image> ( path -- element )
165 1array \ $image prefix ;
171 : write-link ( string object -- )
172 link-style get [ write-object ] with-style ;
174 : link-icon ( topic -- )
175 definition-icon 1array $image ;
177 : link-text ( topic -- )
178 [ article-name ] keep write-link ;
180 GENERIC: link-long-text ( topic -- )
182 M: topic link-long-text
183 [ article-title ] keep write-link ;
185 GENERIC: link-effect? ( word -- ? )
187 M: parsing-word link-effect? drop f ;
188 M: symbol link-effect? drop f ;
189 M: word link-effect? drop t ;
191 : $effect ( effect -- )
192 effect>string stack-effect-style get format ;
194 M: word link-long-text
195 dup presented associate [
196 [ article-name link-style get format ]
199 bl stack-effect $effect
204 : >topic ( obj -- topic ) dup topic? [ >link ] unless ;
206 : topic-span ( topic quot -- ) [ >topic ] dip ($span) ; inline
210 : ($link) ( topic -- ) [ link-text ] topic-span ;
211 : $link ( element -- ) first ($link) ;
213 : ($long-link) ( topic -- ) [ link-long-text ] topic-span ;
214 : $long-link ( element -- ) first ($long-link) ;
216 : ($pretty-link) ( topic -- )
217 [ [ link-icon ] [ drop bl ] [ link-text ] tri ] topic-span ;
218 : $pretty-link ( element -- ) first ($pretty-link) ;
220 : ($long-pretty-link) ( topic -- )
221 [ [ link-icon ] [ drop bl ] [ link-long-text ] tri ] topic-span ;
223 : <$pretty-link> ( definition -- element )
224 1array \ $pretty-link prefix ;
226 : ($subsection) ( element quot -- )
228 subsection-style get [ call ] with-style
231 : $subsection* ( topic -- )
233 [ ($long-pretty-link) ] with-scope
236 : $subsections ( children -- )
237 [ $subsection* ] each ($blank-line) ;
239 : $subsection ( element -- )
242 : ($vocab-link) ( text vocab -- )
243 >vocab-link write-link ;
245 : $vocab-subsection ( element -- )
247 first2 dup vocab-help
248 [ 2nip ($long-pretty-link) ]
249 [ [ >vocab-link link-icon bl ] [ ($vocab-link) ] bi ]
253 : $vocab-link ( element -- )
254 first dup vocab-name swap ($vocab-link) ;
256 : $vocabulary ( element -- )
258 "Vocabulary" $heading nl dup ($vocab-link)
261 : (textual-list) ( seq quot sep -- )
262 '[ _ print-element ] swap interleave ; inline
264 : textual-list ( seq quot -- )
265 ", " (textual-list) ; inline
267 : $links ( topics -- )
268 [ [ ($link) ] textual-list ] ($span) ;
270 : $vocab-links ( vocabs -- )
271 [ vocab ] map $links ;
273 : $breadcrumbs ( topics -- )
274 [ [ ($link) ] " > " (textual-list) ] ($span) ;
276 : $see-also ( topics -- )
277 "See also" $heading $links ;
279 : related-words ( seq -- )
280 dup '[ _ "related" set-word-prop ] each ;
282 : $related ( element -- )
283 first dup "related" word-prop remove
284 [ $see-also ] unless-empty ;
286 : ($grid) ( style quot -- )
288 table-content-style get [
289 swap [ last-element off call ] tabular-output
293 : $list ( element -- )
297 bullet get write-cell
298 [ print-element ] with-cell
303 : $table ( element -- )
307 [ [ print-element ] with-cell ] each
312 : a/an ( str -- str )
313 [ first ] [ length ] bi 1 =
314 "afhilmnorsx" "aeiou" ? member? "an" "a" ? ;
316 GENERIC: ($instance) ( element -- )
319 dup name>> a/an write bl ($link) ;
321 M: string ($instance)
327 : $instance ( element -- ) first ($instance) ;
331 { 1 [ first ($instance) ] }
332 { 2 [ first2 [ ($instance) " or " print-element ] [ ($instance) ] bi* ] }
336 [ [ ($instance) ", " print-element ] each ]
337 [ "or " print-element ($instance) ]
342 : $maybe ( element -- )
345 : $quotation ( element -- )
346 { "a " { $link quotation } " with stack effect " } print-element
349 : values-row ( seq -- seq )
350 unclip \ $snippet swap present 2array
351 swap dup first word? [ \ $instance prefix ] when 2array ;
353 : $values ( element -- )
354 "Inputs and outputs" $heading
355 [ values-row ] map $table ;
357 : $side-effects ( element -- )
358 "Side effects" $heading "Modifies " print-element
359 [ $snippet ] textual-list ;
361 : $errors ( element -- )
362 "Errors" $heading print-element ;
364 : $notes ( element -- )
365 "Notes" $heading print-element ;
367 : ($see) ( word quot -- )
369 code-char-style get [
370 code-style get swap with-nesting
374 : $see ( element -- ) first [ see* ] ($see) ;
376 : $synopsis ( element -- ) first [ synopsis write ] ($see) ;
378 : $definition ( element -- )
379 "Definition" $heading $see ;
381 : $methods ( element -- )
387 : $value ( object -- )
388 "Variable value" $heading
389 "Current value in global namespace:" print-element
390 first dup [ pprint-short ] ($code) ;
392 : $curious ( element -- )
393 "For the curious..." $heading print-element ;
395 : $references ( element -- )
396 "References" $heading
397 unclip print-element [ \ $link swap ] { } map>assoc $list ;
399 : $shuffle ( element -- )
401 "Shuffle word. Re-arranges the stack according to the stack effect pattern." $description ;
403 : $low-level-note ( children -- )
405 "Calling this word directly is not necessary in most cases. Higher-level words call it automatically." $notes ;
407 : $values-x/y ( children -- )
408 drop { { "x" number } { "y" number } } $values ;
410 : $parsing-note ( children -- )
412 "This word should only be called from parsing words."
415 : $io-error ( children -- )
417 "Throws an error if the I/O operation fails." $errors ;
419 : $prettyprinting-note ( children -- )
421 "This word should only be called from inside the "
422 { $link with-pprint } " combinator."
425 GENERIC: elements* ( elt-type element -- )
427 M: simple-element elements*
428 [ elements* ] with each ;
430 M: object elements* 2drop ;
433 [ [ elements* ] with each ] 2keep
434 [ first eq? ] keep swap [ , ] [ drop ] if ;
436 : elements ( elt-type element -- seq ) [ elements* ] { } make ;
438 : collect-elements ( element seq -- elements )
439 swap '[ _ elements [ rest ] map concat ] map concat prune ;
441 : <$link> ( topic -- element )
442 1array \ $link prefix ;
444 : <$snippet> ( str -- element )
445 1array \ $snippet prefix ;
447 : $definition-icons ( element -- )
449 icons get >alist sort-keys
450 [ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map
451 { "" "Definition class" } prefix