basis/help/markup/markup.factor

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