basis/help/markup/markup.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators compiler.units
   4 definitions.icons effects english hashtables help.stylesheet
   5 help.topics io io.styles kernel make math namespaces present
   6 prettyprint 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     join-lines 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 [ join-lines ] 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-subsections ( element -- )
 260     [ $vocab-subsection ] each ($blank-line) ;
 261
 262 : $vocab-link ( element -- )
 263     check-first [ vocab-name ] keep ($vocab-link) ;
 264
 265 : $vocabulary ( element -- )
 266     check-first vocabulary>> [
 267         "Vocabulary" $heading nl dup ($vocab-link)
 268     ] when* ;
 269
 270 : (textual-list) ( seq quot sep -- )
 271     '[ _ print-element ] swap interleave ; inline
 272
 273 : textual-list ( seq quot -- )
 274     ", " (textual-list) ; inline
 275
 276 : $links ( topics -- )
 277     [ [ ($link) ] textual-list ] ($span) ;
 278
 279 : $vocab-links ( vocabs -- )
 280     [ lookup-vocab ] map $links ;
 281
 282 : $breadcrumbs ( topics -- )
 283     [ [ ($link) ] " » " (textual-list) ] ($span) ;
 284
 285 : $see-also ( topics -- )
 286     "See also" $heading $links ;
 287
 288 <PRIVATE
 289 :: update-related-words ( words -- affected-words )
 290     words words [| affected word |
 291         word "related" [ affected union words ] change-word-prop
 292     ] reduce ;
 293
 294 :: clear-unrelated-words ( words affected-words -- )
 295     affected-words words diff
 296     [ "related" [ words diff ] change-word-prop ] each ;
 297
 298 : notify-related-words ( affected-words -- )
 299     fast-set notify-definition-observers ;
 300
 301 PRIVATE>
 302
 303 : related-words ( seq -- )
 304     dup update-related-words
 305     [ clear-unrelated-words ] [ notify-related-words ] bi ;
 306
 307 : $related ( element -- )
 308     check-first dup "related" word-prop remove
 309     [ $see-also ] unless-empty ;
 310
 311 : ($grid) ( style content-style quot -- )
 312     '[
 313         _ [ last-element off _ tabular-output ] with-style
 314     ] ($block) ; inline
 315
 316 : $list ( element -- )
 317     list-style get list-content-style get [
 318         [
 319             [
 320                 bullet get write-cell
 321                 [ print-element ] with-cell
 322             ] with-row
 323         ] each
 324     ] ($grid) ;
 325
 326 : $table ( element -- )
 327     table-style get table-content-style get [
 328         [
 329             [
 330                 [ [ print-element ] with-cell ] each
 331             ] with-row
 332         ] each
 333     ] ($grid) ;
 334
 335 ! for help-lint
 336 ALIAS: $slot $snippet
 337
 338 : $slots ( children -- )
 339     [ unclip \ $slot swap 2array prefix ] map $table ;
 340
 341 : a/an ( str -- str )
 342     [ first ] [ length ] bi 1 =
 343     "afhilmnorsx" vowels ? member? "an" "a" ? ;
 344
 345 GENERIC: ($instance) ( element -- )
 346
 347 M: word ($instance) dup name>> a/an write bl ($link) ;
 348
 349 M: string ($instance) write ;
 350
 351 M: array ($instance) print-element ;
 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     [ [ "None" write ] ($block) ]
 401     [ [ values-row ] map $table ] if-empty ;
 402
 403 : $inputs ( element -- )
 404     "Inputs" $heading ($values) ;
 405
 406 : $outputs ( element -- )
 407     "Outputs" $heading ($values) ;
 408
 409 : $values ( element -- )
 410     "Inputs and outputs" $heading ($values) ;
 411
 412 : $side-effects ( element -- )
 413     "Side effects" $heading "Modifies " print-element
 414     [ $snippet ] textual-list ;
 415
 416 : $errors ( element -- )
 417     "Errors" $heading print-element ;
 418
 419 : $notes ( element -- )
 420     "Notes" $heading print-element ;
 421
 422 : ($see) ( word quot -- )
 423     [ code-style get swap with-nesting ] ($block) ; inline
 424
 425 : $see ( element -- ) check-first [ see* ] ($see) ;
 426
 427 : $synopsis ( element -- ) check-first [ synopsis write ] ($see) ;
 428
 429 : $definition ( element -- )
 430     "Definition" $heading $see ;
 431
 432 : $methods ( element -- )
 433     check-first methods [
 434         "Methods" $heading
 435         [ see-all ] ($see)
 436     ] unless-empty ;
 437
 438 : $value ( object -- )
 439     "Variable value" $heading
 440     "Current value in global namespace:" print-element
 441     check-first dup [ pprint-short ] ($code) ;
 442
 443 : $curious ( element -- )
 444     "For the curious..." $heading print-element ;
 445
 446 : $references ( element -- )
 447     "References" $heading
 448     unclip print-element [ \ $link swap ] { } map>assoc $list ;
 449
 450 : $shuffle ( element -- )
 451     "This is a shuffle word, rearranging the top of the datastack as indicated by the word's stack effect" swap
 452     ?first [ ": " swap "." 4array ] [ "." append ] if*
 453     $description ;
 454
 455 : $complex-shuffle ( element -- )
 456     $shuffle
 457     { "The data flow represented by this shuffle word might be more clearly expressed using " { $link "locals" } "." } $deprecated ;
 458
 459 : $low-level-note ( children -- )
 460     drop
 461     "Calling this word directly is not necessary in most cases. Higher-level words call it automatically." $notes ;
 462
 463 : $values-x/y ( children -- )
 464     drop { { "x" number } { "y" number } } $values ;
 465
 466 : $parsing-note ( children -- )
 467     drop
 468     "This word should only be called from parsing words."
 469     $notes ;
 470
 471 : $io-error ( children -- )
 472     drop
 473     "Throws an error if the I/O operation fails." $errors ;
 474
 475 : $prettyprinting-note ( children -- )
 476     drop {
 477         "This word should only be called from inside the "
 478         { $link with-pprint } " combinator."
 479     } $notes ;
 480
 481 : $content ( element -- )
 482     first article-content print-content nl ;
 483
 484 GENERIC: elements* ( elt-type element -- )
 485
 486 M: simple-element elements*
 487     [ elements* ] with each ;
 488
 489 M: object elements* 2drop ;
 490
 491 M: array elements*
 492     [ dup first \ $markup-example eq? [ 2drop ] [ [ elements* ] with each ] if ]
 493     [ [ first eq? ] keep swap [ , ] [ drop ] if ] 2bi ;
 494
 495 : elements ( elt-type element -- seq ) [ elements* ] { } make ;
 496
 497 : collect-elements ( element seq -- elements )
 498     swap '[ [ _ elements* ] each ] { } make [ rest ] map concat ;
 499
 500 : <$link> ( topic -- element )
 501     1array \ $link prefix ;
 502
 503 : <$snippet> ( str -- element )
 504     1array \ $snippet prefix ;
 505
 506 : $definition-icons ( element -- )
 507     drop
 508     icons get sort-keys
 509     [ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map
 510     { f { $strong "Definition class" } } prefix
 511     $table ;