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