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