basis/help/markup/markup.factor

   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 definitions definitions.icons effects
   5 fry generic hashtables help.stylesheet help.topics io io.styles
   6 kernel make math namespaces parser present prettyprint
   7 prettyprint.stylesheet quotations see sequences sets slots
   8 sorting splitting strings vectors vocabs vocabs.loader words
   9 words.symbol ;
  10 FROM: prettyprint.sections => with-pprint ;
  11 IN: help.markup
  12
  13 PREDICATE: simple-element < array
  14     [ t ] [ first word? not ] if-empty ;
  15
  16 SYMBOL: last-element
  17 SYMBOL: span
  18 SYMBOL: block
  19 SYMBOL: blank-line
  20
  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? ;
  24
  25 : ?nl ( -- )
  26     last-element get
  27     last-blank-line? not
  28     and [ nl ] when ;
  29
  30 : ($blank-line) ( -- )
  31     nl nl blank-line last-element set ;
  32
  33 : ($span) ( quot -- )
  34     last-block? [ nl ] when
  35     span last-element set
  36     call ; inline
  37
  38 GENERIC: print-element ( element -- )
  39
  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 ;
  45
  46 : print-element* ( element style -- )
  47     [ print-element ] with-style ;
  48
  49 : with-default-style ( quot -- )
  50     default-span-style get [
  51         default-block-style get swap with-nesting
  52     ] with-style ; inline
  53
  54 : print-content ( element -- )
  55     [ print-element ] with-default-style ;
  56
  57 : ($block) ( quot -- )
  58     ?nl
  59     span last-element set
  60     call
  61     block last-element set ; inline
  62
  63 ! Some spans
  64
  65 : $snippet ( children -- )
  66     [ snippet-style get print-element* ] ($span) ;
  67
  68 ! for help-lint
  69 ALIAS: $slot $snippet
  70
  71 : $emphasis ( children -- )
  72     [ emphasis-style get print-element* ] ($span) ;
  73
  74 : $strong ( children -- )
  75     [ strong-style get print-element* ] ($span) ;
  76
  77 : $url ( children -- )
  78     [
  79         dup first href associate url-style get assoc-union
  80         print-element*
  81     ] ($span) ;
  82
  83 : $nl ( children -- )
  84     drop nl last-element get [ nl ] when
  85     blank-line last-element set ;
  86
  87 ! Some blocks
  88 : ($heading) ( children quot -- )
  89     ?nl ($block) ; inline
  90
  91 : $heading ( element -- )
  92     [ heading-style get print-element* ] ($heading) ;
  93
  94 : $subheading ( element -- )
  95     [ strong-style get print-element* ] ($heading) ;
  96
  97 : ($code-style) ( presentation -- hash )
  98     presented associate code-style get assoc-union ;
  99
 100 : ($code) ( presentation quot -- )
 101     [
 102         code-char-style get [
 103             last-element off
 104             [ ($code-style) ] dip with-nesting
 105         ] with-style
 106     ] ($block) ; inline
 107
 108 : $code ( element -- )
 109     "\n" join dup <input> [ write ] ($code) ;
 110
 111 : $syntax ( element -- ) "Syntax" $heading $code ;
 112
 113 : $description ( element -- )
 114     "Word description" $heading print-element ;
 115
 116 : $class-description ( element -- )
 117     "Class description" $heading print-element ;
 118
 119 : $error-description ( element -- )
 120     "Error description" $heading print-element ;
 121
 122 : $var-description ( element -- )
 123     "Variable description" $heading print-element ;
 124
 125 : $contract ( element -- )
 126     "Generic word contract" $heading print-element ;
 127
 128 : $examples ( element -- )
 129     "Examples" $heading print-element ;
 130
 131 : $example ( element -- )
 132     1 cut* [ "\n" join ] bi@ over <input> [
 133         [ print ] [ output-style get format ] bi*
 134     ] ($code) ;
 135
 136 : $unchecked-example ( element -- )
 137     #! help-lint ignores these.
 138     $example ;
 139
 140 : $markup-example ( element -- )
 141     first dup unparse " print-element" append 1array $code
 142     print-element ;
 143
 144 : $warning ( element -- )
 145     [
 146         warning-style get [
 147             last-element off
 148             "Warning" $heading print-element
 149         ] with-nesting
 150     ] ($heading) ;
 151
 152 : $deprecated ( element -- )
 153     [
 154         deprecated-style get [
 155             last-element off
 156             "This word is deprecated" $heading print-element
 157         ] with-nesting
 158     ] ($heading) ;
 159
 160 ! Images
 161 : $image ( element -- )
 162     [ first write-image ] ($span) ;
 163
 164 : <$image> ( path -- element )
 165     1array \ $image prefix ;
 166
 167 ! Some links
 168
 169 <PRIVATE
 170
 171 : write-link ( string object -- )
 172     link-style get [ write-object ] with-style ;
 173
 174 : link-icon ( topic -- )
 175     definition-icon 1array $image ;
 176
 177 : link-text ( topic -- )
 178     [ article-name ] keep write-link ;
 179
 180 GENERIC: link-long-text ( topic -- )
 181
 182 M: topic link-long-text
 183     [ article-title ] keep write-link ;
 184
 185 GENERIC: link-effect? ( word -- ? )
 186
 187 M: parsing-word link-effect? drop f ;
 188 M: symbol link-effect? drop f ;
 189 M: word link-effect? drop t ;
 190
 191 : $effect ( effect -- )
 192     effect>string stack-effect-style get format ;
 193
 194 M: word link-long-text
 195     dup presented associate [
 196         [ article-name link-style get format ]
 197         [
 198             dup link-effect? [
 199                 bl stack-effect $effect
 200             ] [ drop ] if
 201         ] bi
 202     ] with-nesting ;
 203
 204 : >topic ( obj -- topic ) dup topic? [ >link ] unless ;
 205
 206 : topic-span ( topic quot -- ) [ >topic ] dip ($span) ; inline
 207
 208 PRIVATE>
 209
 210 : ($link) ( topic -- ) [ link-text ] topic-span ;
 211 : $link ( element -- ) first ($link) ;
 212
 213 : ($long-link) ( topic -- ) [ link-long-text ] topic-span ;
 214 : $long-link ( element -- ) first ($long-link) ;
 215
 216 : ($pretty-link) ( topic -- )
 217     [ [ link-icon ] [ drop bl ] [ link-text ] tri ] topic-span ;
 218 : $pretty-link ( element -- ) first ($pretty-link) ;
 219
 220 : ($long-pretty-link) ( topic -- )
 221     [ [ link-icon ] [ drop bl ] [ link-long-text ] tri ] topic-span ;
 222
 223 : <$pretty-link> ( definition -- element )
 224     1array \ $pretty-link prefix ;
 225
 226 : ($subsection) ( element quot -- )
 227     [
 228         subsection-style get [ call ] with-style
 229     ] ($block) ; inline
 230
 231 : $subsection* ( topic -- )
 232     [
 233         [ ($long-pretty-link) ] with-scope
 234     ] ($subsection) ;
 235
 236 : $subsections ( children -- )
 237     [ $subsection* ] each ($blank-line) ;
 238
 239 : $subsection ( element -- )
 240     first $subsection* ;
 241
 242 : ($vocab-link) ( text vocab -- )
 243     >vocab-link write-link ;
 244
 245 : $vocab-subsection ( element -- )
 246     [
 247         first2 dup vocab-help
 248         [ 2nip ($long-pretty-link) ]
 249         [ [ >vocab-link link-icon bl ] [ ($vocab-link) ] bi ]
 250         if*
 251     ] ($subsection) ;
 252
 253 : $vocab-link ( element -- )
 254     first dup vocab-name swap ($vocab-link) ;
 255
 256 : $vocabulary ( element -- )
 257     first vocabulary>> [
 258         "Vocabulary" $heading nl dup ($vocab-link)
 259     ] when* ;
 260
 261 : (textual-list) ( seq quot sep -- )
 262     '[ _ print-element ] swap interleave ; inline
 263
 264 : textual-list ( seq quot -- )
 265     ", " (textual-list) ; inline
 266
 267 : $links ( topics -- )
 268     [ [ ($link) ] textual-list ] ($span) ;
 269
 270 : $vocab-links ( vocabs -- )
 271     [ vocab ] map $links ;
 272
 273 : $breadcrumbs ( topics -- )
 274     [ [ ($link) ] " > " (textual-list) ] ($span) ;
 275
 276 : $see-also ( topics -- )
 277     "See also" $heading $links ;
 278
 279 : related-words ( seq -- )
 280     dup '[ _ "related" set-word-prop ] each ;
 281
 282 : $related ( element -- )
 283     first dup "related" word-prop remove
 284     [ $see-also ] unless-empty ;
 285
 286 : ($grid) ( style quot -- )
 287     [
 288         table-content-style get [
 289             swap [ last-element off call ] tabular-output
 290         ] with-style
 291     ] ($block) ; inline
 292
 293 : $list ( element -- )
 294     list-style get [
 295         [
 296             [
 297                 bullet get write-cell
 298                 [ print-element ] with-cell
 299             ] with-row
 300         ] each
 301     ] ($grid) ;
 302
 303 : $table ( element -- )
 304     table-style get [
 305         [
 306             [
 307                 [ [ print-element ] with-cell ] each
 308             ] with-row
 309         ] each
 310     ] ($grid) ;
 311
 312 : a/an ( str -- str )
 313     [ first ] [ length ] bi 1 =
 314     "afhilmnorsx" "aeiou" ? member? "an" "a" ? ;
 315
 316 GENERIC: ($instance) ( element -- )
 317
 318 M: word ($instance)
 319     dup name>> a/an write bl ($link) ;
 320
 321 M: string ($instance)
 322     write ;
 323
 324 M: f ($instance)
 325     drop { f } $link ;
 326
 327 : $instance ( element -- ) first ($instance) ;
 328
 329 : $or ( element -- )
 330     dup length {
 331         { 1 [ first ($instance) ] }
 332         { 2 [ first2 [ ($instance) " or " print-element ] [ ($instance) ] bi* ] }
 333         [
 334             drop
 335             unclip-last
 336             [ [ ($instance) ", " print-element ] each ]
 337             [ "or " print-element ($instance) ]
 338             bi*
 339         ]
 340     } case ;
 341
 342 : $maybe ( element -- )
 343     f suffix $or ;
 344
 345 : $quotation ( element -- )
 346     { "a " { $link quotation } " with stack effect " } print-element
 347     $snippet ;
 348
 349 : values-row ( seq -- seq )
 350     unclip \ $snippet swap present 2array
 351     swap dup first word? [ \ $instance prefix ] when 2array ;
 352
 353 : $values ( element -- )
 354     "Inputs and outputs" $heading
 355     [ values-row ] map $table ;
 356
 357 : $side-effects ( element -- )
 358     "Side effects" $heading "Modifies " print-element
 359     [ $snippet ] textual-list ;
 360
 361 : $errors ( element -- )
 362     "Errors" $heading print-element ;
 363
 364 : $notes ( element -- )
 365     "Notes" $heading print-element ;
 366
 367 : ($see) ( word quot -- )
 368     [
 369         code-char-style get [
 370             code-style get swap with-nesting
 371         ] with-style
 372     ] ($block) ; inline
 373
 374 : $see ( element -- ) first [ see* ] ($see) ;
 375
 376 : $synopsis ( element -- ) first [ synopsis write ] ($see) ;
 377
 378 : $definition ( element -- )
 379     "Definition" $heading $see ;
 380
 381 : $methods ( element -- )
 382     first methods [
 383         "Methods" $heading
 384         [ see-all ] ($see)
 385     ] unless-empty ;
 386
 387 : $value ( object -- )
 388     "Variable value" $heading
 389     "Current value in global namespace:" print-element
 390     first dup [ pprint-short ] ($code) ;
 391
 392 : $curious ( element -- )
 393     "For the curious..." $heading print-element ;
 394
 395 : $references ( element -- )
 396     "References" $heading
 397     unclip print-element [ \ $link swap ] { } map>assoc $list ;
 398
 399 : $shuffle ( element -- )
 400     drop
 401     "Shuffle word. Rearranges the top of the datastack as indicated in the stack effect pattern." $description ;
 402
 403 : $complex-shuffle ( element -- )
 404     drop
 405     "Shuffle word. Rearranges the top of the datastack as indicated in the stack effect pattern." $description
 406     { "The data flow represented by this shuffle word can be more clearly expressed using " { $link "locals" } "." } $deprecated ;
 407
 408 : $low-level-note ( children -- )
 409     drop
 410     "Calling this word directly is not necessary in most cases. Higher-level words call it automatically." $notes ;
 411
 412 : $values-x/y ( children -- )
 413     drop { { "x" number } { "y" number } } $values ;
 414
 415 : $parsing-note ( children -- )
 416     drop
 417     "This word should only be called from parsing words."
 418     $notes ;
 419
 420 : $io-error ( children -- )
 421     drop
 422     "Throws an error if the I/O operation fails." $errors ;
 423
 424 : $prettyprinting-note ( children -- )
 425     drop {
 426         "This word should only be called from inside the "
 427         { $link with-pprint } " combinator."
 428     } $notes ;
 429
 430 GENERIC: elements* ( elt-type element -- )
 431
 432 M: simple-element elements*
 433     [ elements* ] with each ;
 434
 435 M: object elements* 2drop ;
 436
 437 M: array elements*
 438     [ dup first \ $markup-example eq? [ 2drop ] [ [ elements* ] with each ] if ]
 439     [ [ first eq? ] keep swap [ , ] [ drop ] if ] 2bi ;
 440
 441 : elements ( elt-type element -- seq ) [ elements* ] { } make ;
 442
 443 : collect-elements ( element seq -- elements )
 444     swap '[ _ elements [ rest ] map concat ] map concat prune ;
 445
 446 : <$link> ( topic -- element )
 447     1array \ $link prefix ;
 448
 449 : <$snippet> ( str -- element )
 450     1array \ $snippet prefix ;
 451
 452 : $definition-icons ( element -- )
 453     drop
 454     icons get >alist sort-keys
 455     [ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map
 456     { "" "Definition class" } prefix
 457     $table ;