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