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 combinators.smart compiler.units definitions
5 definitions.icons effects fry generic hash-sets hashtables
6 help.stylesheet help.topics io io.styles kernel locals make math
7 namespaces parser present prettyprint prettyprint.stylesheet
8 quotations see sequences sequences.private sets slots sorting
9 splitting strings urls vectors vocabs vocabs.loader words
11 FROM: prettyprint.sections => with-pprint ;
12 FROM: namespaces => set ;
15 PREDICATE: simple-element < array
16 [ t ] [ first word? not ] if-empty ;
23 : last-span? ( -- ? ) last-element get span eq? ;
24 : last-block? ( -- ? ) last-element get block eq? ;
25 : last-blank-line? ( -- ? ) last-element get blank-line eq? ;
32 : ($blank-line) ( -- )
33 nl nl blank-line last-element set ;
36 last-block? [ nl ] when
40 GENERIC: print-element ( element -- )
42 M: simple-element print-element [ print-element ] each ;
43 M: string print-element [ write ] ($span) ;
44 M: array print-element unclip execute( arg -- ) ;
45 M: word print-element { } swap execute( arg -- ) ;
46 M: effect print-element effect>string print-element ;
47 M: f print-element drop ;
49 : print-element* ( element style -- )
50 [ print-element ] with-style ;
52 : with-default-style ( quot -- )
53 default-span-style get [
54 default-block-style get swap with-nesting
57 : print-content ( element -- )
58 [ print-element ] with-default-style ;
60 : ($block) ( quot -- )
64 block last-element set ; inline
68 : $snippet ( children -- )
69 [ snippet-style get print-element* ] ($span) ;
74 : $emphasis ( children -- )
75 [ emphasis-style get print-element* ] ($span) ;
77 : $strong ( children -- )
78 [ strong-style get print-element* ] ($span) ;
80 : $url ( children -- )
82 dup present href associate url-style get assoc-union
83 [ write-object ] with-style
87 drop nl last-element get [ nl ] when
88 blank-line last-element set ;
91 : ($heading) ( children quot -- )
94 : $heading ( element -- )
95 [ heading-style get print-element* ] ($heading) ;
97 : $subheading ( element -- )
98 [ strong-style get print-element* ] ($heading) ;
100 : ($code-style) ( presentation -- hash )
101 presented associate code-style get assoc-union ;
103 : ($code) ( presentation quot -- )
105 code-char-style get [
107 [ ($code-style) ] dip with-nesting
111 : $code ( element -- )
112 "\n" join dup <input> [ write ] ($code) ;
114 : $syntax ( element -- ) "Syntax" $heading $code ;
116 : $description ( element -- )
117 "Word description" $heading print-element ;
119 : $class-description ( element -- )
120 "Class description" $heading print-element ;
122 : $error-description ( element -- )
123 "Error description" $heading print-element ;
125 : $var-description ( element -- )
126 "Variable description" $heading print-element ;
128 : $contract ( element -- )
129 "Generic word contract" $heading print-element ;
131 : $examples ( element -- )
132 "Examples" $heading print-element ;
134 : $example ( element -- )
135 1 cut* [ "\n" join ] bi@ over <input> [
136 [ print ] [ output-style get format ] bi*
139 : $unchecked-example ( element -- )
140 #! help-lint ignores these.
143 : $markup-example ( element -- )
144 first dup unparse " print-element" append 1array $code
147 : $warning ( element -- )
151 "Warning" $heading print-element
155 : $deprecated ( element -- )
157 deprecated-style get [
159 "This word is deprecated" $heading print-element
164 : $image ( element -- )
165 [ first write-image ] ($span) ;
167 : <$image> ( path -- element )
168 1array \ $image prefix ;
174 : write-link ( string object -- )
175 link-style get [ write-object ] with-style ;
177 : link-icon ( topic -- )
178 definition-icon 1array $image ;
180 : link-text ( topic -- )
181 [ article-name ] keep write-link ;
183 GENERIC: link-long-text ( topic -- )
185 M: topic link-long-text
186 [ article-title ] keep write-link ;
188 GENERIC: link-effect? ( word -- ? )
190 M: parsing-word link-effect? drop f ;
191 M: symbol link-effect? drop f ;
192 M: word link-effect? drop t ;
194 : $effect ( effect -- )
195 effect>string stack-effect-style get format ;
197 M: word link-long-text
198 dup presented associate [
199 [ article-name link-style get format ]
202 bl stack-effect $effect
207 : >topic ( obj -- topic ) dup topic? [ >link ] unless ;
209 : topic-span ( topic quot -- ) [ >topic ] dip ($span) ; inline
211 ERROR: number-of-arguments found required ;
213 : check-first ( seq -- first )
214 dup length 1 = [ length 1 number-of-arguments ] unless
217 : check-first2 ( seq -- first second )
218 dup length 2 = [ length 2 number-of-arguments ] unless
223 : ($link) ( topic -- ) [ link-text ] topic-span ;
225 : $link ( element -- ) check-first ($link) ;
227 : ($long-link) ( topic -- ) [ link-long-text ] topic-span ;
229 : $long-link ( element -- ) check-first ($long-link) ;
231 : ($pretty-link) ( topic -- )
232 [ [ link-icon ] [ drop bl ] [ link-text ] tri ] topic-span ;
234 : $pretty-link ( element -- ) check-first ($pretty-link) ;
236 : ($long-pretty-link) ( topic -- )
237 [ [ link-icon ] [ drop bl ] [ link-long-text ] tri ] topic-span ;
239 : <$pretty-link> ( definition -- element )
240 1array \ $pretty-link prefix ;
242 : ($subsection) ( element quot -- )
244 subsection-style get [ call ] with-style
247 : $subsection* ( topic -- )
249 [ ($long-pretty-link) ] with-scope
252 : $subsections ( children -- )
253 [ $subsection* ] each ($blank-line) ;
255 : $subsection ( element -- )
256 check-first $subsection* ;
258 : ($vocab-link) ( text vocab -- )
259 >vocab-link write-link ;
261 : $vocab-subsection ( element -- )
263 check-first2 dup vocab-help
264 [ 2nip ($long-pretty-link) ]
265 [ [ >vocab-link link-icon bl ] [ ($vocab-link) ] bi ]
269 : $vocab-link ( element -- )
270 check-first dup vocab-name swap ($vocab-link) ;
272 : $vocabulary ( element -- )
273 check-first vocabulary>> [
274 "Vocabulary" $heading nl dup ($vocab-link)
277 : (textual-list) ( seq quot sep -- )
278 '[ _ print-element ] swap interleave ; inline
280 : textual-list ( seq quot -- )
281 ", " (textual-list) ; inline
283 : $links ( topics -- )
284 [ [ ($link) ] textual-list ] ($span) ;
286 : $vocab-links ( vocabs -- )
287 [ lookup-vocab ] map $links ;
289 : $breadcrumbs ( topics -- )
290 [ [ ($link) ] " > " (textual-list) ] ($span) ;
292 : $see-also ( topics -- )
293 "See also" $heading $links ;
296 :: update-related-words ( words -- affected-words )
297 words words [| affected word |
298 word "related" [ affected union words ] change-word-prop
301 :: clear-unrelated-words ( words affected-words -- )
302 affected-words words diff
303 [ "related" [ words diff ] change-word-prop ] each ;
305 : notify-related-words ( affected-words -- )
306 fast-set notify-definition-observers ;
310 : related-words ( seq -- )
311 dup update-related-words
312 [ clear-unrelated-words ] [ notify-related-words ] bi ;
314 : $related ( element -- )
315 check-first dup "related" word-prop remove
316 [ $see-also ] unless-empty ;
318 : ($grid) ( style quot -- )
320 table-content-style get [
321 swap [ last-element off call ] tabular-output
325 : $list ( element -- )
329 bullet get write-cell
330 [ print-element ] with-cell
335 : $table ( element -- )
339 [ [ print-element ] with-cell ] each
344 : a/an ( str -- str )
345 [ first ] [ length ] bi 1 =
346 "afhilmnorsx" "aeiou" ? member? "an" "a" ? ;
348 GENERIC: ($instance) ( element -- )
351 dup name>> a/an write bl ($link) ;
353 M: string ($instance)
359 : $instance ( element -- ) first ($instance) ;
363 { 1 [ first ($instance) ] }
364 { 2 [ first2 [ ($instance) " or " print-element ] [ ($instance) ] bi* ] }
368 [ [ ($instance) ", " print-element ] each ]
369 [ "or " print-element ($instance) ]
374 : $maybe ( element -- )
377 : $quotation ( element -- )
379 { "a " { $link quotation } " with stack effect " }
380 print-element $snippet ;
382 : values-row ( seq -- seq )
383 unclip \ $snippet swap present 2array
384 swap dup first word? [ \ $instance prefix ] when 2array ;
386 : $values ( element -- )
387 "Inputs and outputs" $heading
388 [ values-row ] map $table ;
390 : $side-effects ( element -- )
391 "Side effects" $heading "Modifies " print-element
392 [ $snippet ] textual-list ;
394 : $errors ( element -- )
395 "Errors" $heading print-element ;
397 : $notes ( element -- )
398 "Notes" $heading print-element ;
400 : ($see) ( word quot -- )
402 code-char-style get [
403 code-style get swap with-nesting
407 : $see ( element -- ) check-first [ see* ] ($see) ;
409 : $synopsis ( element -- ) check-first [ synopsis write ] ($see) ;
411 : $definition ( element -- )
412 "Definition" $heading $see ;
414 : $methods ( element -- )
415 check-first methods [
420 : $value ( object -- )
421 "Variable value" $heading
422 "Current value in global namespace:" print-element
423 check-first dup [ pprint-short ] ($code) ;
425 : $curious ( element -- )
426 "For the curious..." $heading print-element ;
428 : $references ( element -- )
429 "References" $heading
430 unclip print-element [ \ $link swap ] { } map>assoc $list ;
432 : $shuffle ( element -- )
434 "Shuffle word. Rearranges the top of the datastack as indicated in the stack effect pattern." $description ;
436 : $complex-shuffle ( element -- )
438 "Shuffle word. Rearranges the top of the datastack as indicated in the stack effect pattern." $description
439 { "The data flow represented by this shuffle word can be more clearly expressed using " { $link "locals" } "." } $deprecated ;
441 : $low-level-note ( children -- )
443 "Calling this word directly is not necessary in most cases. Higher-level words call it automatically." $notes ;
445 : $values-x/y ( children -- )
446 drop { { "x" number } { "y" number } } $values ;
448 : $parsing-note ( children -- )
450 "This word should only be called from parsing words."
453 : $io-error ( children -- )
455 "Throws an error if the I/O operation fails." $errors ;
457 : $prettyprinting-note ( children -- )
459 "This word should only be called from inside the "
460 { $link with-pprint } " combinator."
463 GENERIC: elements* ( elt-type element -- )
465 M: simple-element elements*
466 [ elements* ] with each ;
468 M: object elements* 2drop ;
471 [ dup first \ $markup-example eq? [ 2drop ] [ [ elements* ] with each ] if ]
472 [ [ first eq? ] keep swap [ , ] [ drop ] if ] 2bi ;
474 : elements ( elt-type element -- seq ) [ elements* ] { } make ;
476 : collect-elements ( element seq -- elements )
477 swap '[ _ elements [ rest ] map concat ] gather ;
479 : <$link> ( topic -- element )
480 1array \ $link prefix ;
482 : <$snippet> ( str -- element )
483 1array \ $snippet prefix ;
485 : $definition-icons ( element -- )
488 [ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map
489 { "" "Definition class" } prefix