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