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