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