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