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 definitions generic io kernel assocs
   4 hashtables namespaces make parser prettyprint sequences strings
   5 io.styles vectors words math sorting splitting classes slots fry
   6 sets vocabs help.stylesheet help.topics vocabs.loader quotations
   7 combinators call ;
   8 IN: help.markup
   9
  10 PREDICATE: simple-element < array
  11     [ t ] [ first word? not ] if-empty ;
  12
  13 SYMBOL: last-element
  14 SYMBOL: span
  15 SYMBOL: block
  16
  17 : last-span? ( -- ? ) last-element get span eq? ;
  18 : last-block? ( -- ? ) last-element get block eq? ;
  19
  20 : ($span) ( quot -- )
  21     last-block? [ nl ] when
  22     span last-element set
  23     call ; inline
  24
  25 GENERIC: print-element ( element -- )
  26
  27 M: simple-element print-element [ print-element ] each ;
  28 M: string print-element [ write ] ($span) ;
  29 M: array print-element unclip execute( arg -- ) ;
  30 M: word print-element { } swap execute( arg -- ) ;
  31 M: f print-element drop ;
  32
  33 : print-element* ( element style -- )
  34     [ print-element ] with-style ;
  35
  36 : with-default-style ( quot -- )
  37     default-span-style get [
  38         last-element off
  39         default-block-style get swap with-nesting
  40     ] with-style ; inline
  41
  42 : print-content ( element -- )
  43     [ print-element ] with-default-style ;
  44
  45 : ($block) ( quot -- )
  46     last-element get [ nl ] when
  47     span last-element set
  48     call
  49     block last-element set ; inline
  50
  51 ! Some spans
  52
  53 : $snippet ( children -- )
  54     [ snippet-style get print-element* ] ($span) ;
  55
  56 ! for help-lint
  57 ALIAS: $slot $snippet
  58
  59 : $emphasis ( children -- )
  60     [ emphasis-style get print-element* ] ($span) ;
  61
  62 : $strong ( children -- )
  63     [ strong-style get print-element* ] ($span) ;
  64
  65 : $url ( children -- )
  66     [
  67         dup first href associate url-style get assoc-union
  68         print-element*
  69     ] ($span) ;
  70
  71 : $nl ( children -- )
  72     nl nl drop ;
  73
  74 ! Some blocks
  75 : ($heading) ( children quot -- )
  76     last-element get [ nl ] when ($block) ; inline
  77
  78 : $heading ( element -- )
  79     [ heading-style get print-element* ] ($heading) ;
  80
  81 : $subheading ( element -- )
  82     [ strong-style get print-element* ] ($heading) ;
  83
  84 : ($code-style) ( presentation -- hash )
  85     presented associate code-style get assoc-union ;
  86
  87 : ($code) ( presentation quot -- )
  88     [
  89         snippet-style get [
  90             last-element off
  91             [ ($code-style) ] dip with-nesting
  92         ] with-style
  93     ] ($block) ; inline
  94
  95 : $code ( element -- )
  96     "\n" join dup <input> [ write ] ($code) ;
  97
  98 : $syntax ( element -- ) "Syntax" $heading $code ;
  99
 100 : $description ( element -- )
 101     "Word description" $heading print-element ;
 102
 103 : $class-description ( element -- )
 104     "Class description" $heading print-element ;
 105
 106 : $error-description ( element -- )
 107     "Error description" $heading print-element ;
 108
 109 : $var-description ( element -- )
 110     "Variable description" $heading print-element ;
 111
 112 : $contract ( element -- )
 113     "Generic word contract" $heading print-element ;
 114
 115 : $examples ( element -- )
 116     "Examples" $heading print-element ;
 117
 118 : $example ( element -- )
 119     1 cut* swap "\n" join dup <input> [
 120         input-style get format nl print-element
 121     ] ($code) ;
 122
 123 : $unchecked-example ( element -- )
 124     #! help-lint ignores these.
 125     $example ;
 126
 127 : $markup-example ( element -- )
 128     first dup unparse " print-element" append 1array $code
 129     print-element ;
 130
 131 : $warning ( element -- )
 132     [
 133         warning-style get [
 134             last-element off
 135             "Warning" $heading print-element
 136         ] with-nesting
 137     ] ($heading) ;
 138
 139 ! Images
 140 : $image ( element -- )
 141     [ [ "" ] dip first image associate format ] ($span) ;
 142
 143 ! Some links
 144 : write-link ( string object -- )
 145     link-style get [ write-object ] with-style ;
 146
 147 : ($link) ( article -- )
 148     [ [ article-name ] [ >link ] bi write-link ] ($span) ;
 149
 150 : $link ( element -- )
 151     first ($link) ;
 152
 153 : ($definition-link) ( word -- )
 154     [ article-name ] keep write-link ;
 155
 156 : $definition-link ( element -- )
 157     first ($definition-link) ;
 158
 159 : ($long-link) ( object -- )
 160     [ article-title ] [ >link ] bi write-link ;
 161
 162 : $long-link ( object -- )
 163     first ($long-link) ;
 164
 165 : ($subsection) ( element quot -- )
 166     [
 167         subsection-style get [
 168             bullet get write bl
 169             call
 170         ] with-style
 171     ] ($block) ; inline
 172
 173 : $subsection ( element -- )
 174     [ first ($long-link) ] ($subsection) ;
 175
 176 : ($vocab-link) ( text vocab -- )
 177     >vocab-link write-link ;
 178
 179 : $vocab-subsection ( element -- )
 180     [
 181         first2 dup vocab-help dup [
 182             2nip ($long-link)
 183         ] [
 184             drop ($vocab-link)
 185         ] if
 186     ] ($subsection) ;
 187
 188 : $vocab-link ( element -- )
 189     first dup vocab-name swap ($vocab-link) ;
 190
 191 : $vocabulary ( element -- )
 192     first vocabulary>> [
 193         "Vocabulary" $heading nl dup ($vocab-link)
 194     ] when* ;
 195
 196 : textual-list ( seq quot -- )
 197     [ ", " print-element ] swap interleave ; inline
 198
 199 : $links ( topics -- )
 200     [ [ ($link) ] textual-list ] ($span) ;
 201
 202 : $vocab-links ( vocabs -- )
 203     [ vocab ] map $links ;
 204
 205 : $see-also ( topics -- )
 206     "See also" $heading $links ;
 207
 208 : related-words ( seq -- )
 209     dup '[ _ "related" set-word-prop ] each ;
 210
 211 : $related ( element -- )
 212     first dup "related" word-prop remove
 213     [ $see-also ] unless-empty ;
 214
 215 : ($grid) ( style quot -- )
 216     [
 217         table-content-style get [
 218             swap [ last-element off call ] tabular-output
 219         ] with-style
 220     ] ($block) ; inline
 221
 222 : $list ( element -- )
 223     list-style get [
 224         [
 225             [
 226                 bullet get write-cell
 227                 [ print-element ] with-cell
 228             ] with-row
 229         ] each
 230     ] ($grid) ;
 231
 232 : $table ( element -- )
 233     table-style get [
 234         [
 235             [
 236                 [ [ print-element ] with-cell ] each
 237             ] with-row
 238         ] each
 239     ] ($grid) ;
 240
 241 : a/an ( str -- str )
 242     [ first ] [ length ] bi 1 =
 243     "afhilmnorsx" "aeiou" ? member? "an" "a" ? ;
 244
 245 GENERIC: ($instance) ( element -- )
 246
 247 M: word ($instance)
 248     dup name>> a/an write bl ($link) ;
 249
 250 M: string ($instance)
 251     dup a/an write bl $snippet ;
 252
 253 M: f ($instance)
 254     drop { f } $link ;
 255
 256 : $instance ( element -- ) first ($instance) ;
 257
 258 : $or ( element -- )
 259     dup length {
 260         { 1 [ first ($instance) ] }
 261         { 2 [ first2 [ ($instance) " or " print-element ] [ ($instance) ] bi* ] }
 262         [
 263             drop
 264             unclip-last
 265             [ [ ($instance) ", " print-element ] each ]
 266             [ "or " print-element ($instance) ]
 267             bi*
 268         ]
 269     } case ;
 270
 271 : $maybe ( element -- )
 272     f suffix $or ;
 273
 274 : $quotation ( element -- )
 275     { "a " { $link quotation } " with stack effect " } print-element
 276     $snippet ;
 277
 278 : values-row ( seq -- seq )
 279     unclip \ $snippet swap ?word-name 2array
 280     swap dup first word? [ \ $instance prefix ] when 2array ;
 281
 282 : $values ( element -- )
 283     "Inputs and outputs" $heading
 284     [ values-row ] map $table ;
 285
 286 : $side-effects ( element -- )
 287     "Side effects" $heading "Modifies " print-element
 288     [ $snippet ] textual-list ;
 289
 290 : $errors ( element -- )
 291     "Errors" $heading print-element ;
 292
 293 : $notes ( element -- )
 294     "Notes" $heading print-element ;
 295
 296 : ($see) ( word quot -- )
 297     [
 298         snippet-style get [
 299             code-style get swap with-nesting
 300         ] with-style
 301     ] ($block) ; inline
 302
 303 : $see ( element -- ) first [ see ] ($see) ;
 304
 305 : $synopsis ( element -- ) first [ synopsis write ] ($see) ;
 306
 307 : $definition ( element -- )
 308     "Definition" $heading $see ;
 309
 310 : $methods ( element -- )
 311     first methods [
 312         "Methods" $heading
 313         [ see-all ] ($see)
 314     ] unless-empty ;
 315
 316 : $value ( object -- )
 317     "Variable value" $heading
 318     "Current value in global namespace:" print-element
 319     first dup [ pprint-short ] ($code) ;
 320
 321 : $curious ( element -- )
 322     "For the curious..." $heading print-element ;
 323
 324 : $references ( element -- )
 325     "References" $heading
 326     unclip print-element [ \ $link swap ] { } map>assoc $list ;
 327
 328 : $shuffle ( element -- )
 329     drop
 330     "Shuffle word. Re-arranges the stack according to the stack effect pattern." $description ;
 331
 332 : $low-level-note ( children -- )
 333     drop
 334     "Calling this word directly is not necessary in most cases. Higher-level words call it automatically." $notes ;
 335
 336 : $values-x/y ( children -- )
 337     drop { { "x" number } { "y" number } } $values ;
 338
 339 : $parsing-note ( children -- )
 340     drop
 341     "This word should only be called from parsing words."
 342     $notes ;
 343
 344 : $io-error ( children -- )
 345     drop
 346     "Throws an error if the I/O operation fails." $errors ;
 347
 348 : $prettyprinting-note ( children -- )
 349     drop {
 350         "This word should only be called from inside the "
 351         { $link with-pprint } " combinator."
 352     } $notes ;
 353
 354 GENERIC: elements* ( elt-type element -- )
 355
 356 M: simple-element elements*
 357     [ elements* ] with each ;
 358
 359 M: object elements* 2drop ;
 360
 361 M: array elements*
 362     [ [ elements* ] with each ] 2keep
 363     [ first eq? ] keep swap [ , ] [ drop ] if ;
 364
 365 : elements ( elt-type element -- seq ) [ elements* ] { } make ;
 366
 367 : collect-elements ( element seq -- elements )
 368     swap '[ _ elements [ rest ] map concat ] map concat prune ;
 369
 370 : <$link> ( topic -- element )
 371     1array \ $link prefix ;
 372
 373 : <$snippet> ( str -- element )
 374     1array \ $snippet prefix ;