extra/help/markup/markup.factor

   1 ! Copyright (C) 2005, 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays definitions generic io kernel assocs hashtables
   4 namespaces parser prettyprint sequences strings io.styles
   5 vectors words math sorting splitting classes
   6 slots vocabs help.stylesheet help.topics vocabs.loader ;
   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: array simple-element
  18     dup empty? [ drop t ] [ first word? not ] if ;
  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-style get [
  46         last-element off
  47         H{ } 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 [ snippet-style get print-element* ] ($span) ;
  62
  63 : $emphasis [ emphasis-style get print-element* ] ($span) ;
  64
  65 : $strong [ strong-style get print-element* ] ($span) ;
  66
  67 : $url [ url-style get print-element* ] ($span) ;
  68
  69 : $nl nl nl drop ;
  70
  71 ! Some blocks
  72 : ($heading)
  73     last-element get [ nl ] when ($block) ; inline
  74
  75 : $heading ( element -- )
  76     [ heading-style get print-element* ] ($heading) ;
  77
  78 : $subheading ( element -- )
  79     [ strong-style get print-element* ] ($heading) ;
  80
  81 : ($code-style) ( presentation -- hash )
  82     presented associate code-style get union ;
  83
  84 : ($code) ( presentation quot -- )
  85     [
  86         snippet-style get [
  87             last-element off
  88             >r ($code-style) r> with-nesting
  89         ] with-style
  90     ] ($block) ; inline
  91
  92 : $code ( element -- )
  93     "\n" join dup <input> [ write ] ($code) ;
  94
  95 : $syntax ( element -- ) "Syntax" $heading $code ;
  96
  97 : $description ( element -- )
  98     "Word description" $heading print-element ;
  99
 100 : $class-description ( element -- )
 101     "Class description" $heading print-element ;
 102
 103 : $error-description ( element -- )
 104     "Error description" $heading print-element ;
 105
 106 : $var-description ( element -- )
 107     "Variable description" $heading print-element ;
 108
 109 : $contract ( element -- )
 110     "Generic word contract" $heading print-element ;
 111
 112 : $examples ( element -- )
 113     "Examples" $heading print-element ;
 114
 115 : $example ( element -- )
 116     1 swap cut* swap "\n" join dup <input> [
 117         input-style get format nl print-element
 118     ] ($code) ;
 119
 120 : $unchecked-example ( element -- )
 121     #! help-lint ignores these.
 122     $example ;
 123
 124 : $markup-example ( element -- )
 125     first dup unparse " print-element" append 1array $code
 126     print-element ;
 127
 128 : $warning ( element -- )
 129     [
 130         warning-style get [
 131             last-element off
 132             "Warning" $heading print-element
 133         ] with-nesting
 134     ] ($heading) ;
 135
 136 ! Some links
 137 : write-link ( string object -- )
 138     link-style get [ write-object ] with-style ;
 139
 140 : ($link) ( article -- )
 141     dup article-name swap >link write-link
 142     span last-element set ;
 143
 144 : $link ( element -- )
 145     first ($link) ;
 146
 147 : ($subsection) ( object -- )
 148     [ article-title ] keep >link write-object ;
 149
 150 : $subsection ( element -- )
 151     [
 152         subsection-style get [
 153             bullet get write bl
 154             first ($subsection)
 155         ] with-style
 156     ] ($block) ;
 157
 158 : ($vocab-link) ( vocab -- ) dup f >vocab-link write-link ;
 159
 160 : $vocab-link ( element -- ) first ($vocab-link) ;
 161
 162 : $vocabulary ( element -- )
 163     first word-vocabulary [
 164         "Vocabulary" $heading nl ($vocab-link)
 165     ] when* ;
 166
 167 : textual-list ( seq quot -- )
 168     [ ", " print-element ] swap interleave ; inline
 169
 170 : $links ( topics -- )
 171     [ [ ($link) ] textual-list ] ($span) ;
 172
 173 : $see-also ( topics -- )
 174     "See also" $heading $links ;
 175
 176 : related-words ( seq -- )
 177     dup [ "related" set-word-prop ] curry each ;
 178
 179 : $related ( element -- )
 180     first dup "related" word-prop remove dup empty?
 181     [ drop ] [ $see-also ] if ;
 182
 183 : ($grid) ( style quot -- )
 184     [
 185         table-content-style get [
 186             swap [ last-element off call ] tabular-output
 187         ] with-style
 188     ] ($block) table last-element set ; inline
 189
 190 : $list ( element -- )
 191     list-style get [
 192         [
 193             [
 194                 bullet get write-cell
 195                 [ print-element ] with-cell
 196             ] with-row
 197         ] each
 198     ] ($grid) ;
 199
 200 : $table ( element -- )
 201     table-style get [
 202         [
 203             [
 204                 [ [ print-element ] with-cell ] each
 205             ] with-row
 206         ] each
 207     ] ($grid) ;
 208
 209 : a/an ( str -- str )
 210     first "aeiou" member? "an" "a" ? ;
 211
 212 GENERIC: ($instance) ( element -- )
 213
 214 M: word ($instance)
 215     dup word-name a/an write bl ($link) ;
 216
 217 M: string ($instance)
 218     dup a/an write bl $snippet ;
 219
 220 : $instance first ($instance) ;
 221
 222 : values-row ( seq -- seq )
 223     unclip \ $snippet swap ?word-name 2array
 224     swap dup first word? [ \ $instance add* ] when 2array ;
 225
 226 : $values ( element -- )
 227     "Inputs and outputs" $heading
 228     [ values-row ] map $table ;
 229
 230 : $side-effects ( element -- )
 231     "Side effects" $heading "Modifies " print-element
 232     [ $snippet ] textual-list ;
 233
 234 : $errors ( element -- )
 235     "Errors" $heading print-element ;
 236
 237 : $notes ( element -- )
 238     "Notes" $heading print-element ;
 239
 240 : ($see) ( word -- )
 241     [
 242         snippet-style get [
 243             code-style get [ see ] with-nesting
 244         ] with-style
 245     ] ($block) ;
 246
 247 : $see ( element -- ) first ($see) ;
 248
 249 : $definition ( element -- )
 250     "Definition" $heading $see ;
 251
 252 : $value ( object -- )
 253     "Variable value" $heading
 254     "Current value in global namespace:" print-element
 255     first dup [ pprint-short ] ($code) ;
 256
 257 : $curious ( element -- )
 258     "For the curious..." $heading print-element ;
 259
 260 : $references ( element -- )
 261     "References" $heading
 262     unclip print-element [ \ $link swap ] { } map>assoc $list ;
 263
 264 : $shuffle ( element -- )
 265     drop
 266     "Shuffle word. Re-arranges the stack according to the stack effect pattern." $description ;
 267
 268 : $low-level-note
 269     drop
 270     "Calling this word directly is not necessary in most cases. Higher-level words call it automatically." $notes ;
 271
 272 : $values-x/y
 273     drop { { "x" number } { "y" number } } $values ;
 274
 275 : $io-error
 276     drop
 277     "Throws an error if the I/O operation fails." $errors ;
 278
 279 : $prettyprinting-note
 280     drop {
 281         "This word should only be called from inside the "
 282         { $link with-pprint } " combinator."
 283     } $notes ;
 284
 285 : ($spec-reader-values) ( slot-spec class -- element )
 286     dup ?word-name swap 2array
 287     over slot-spec-name
 288     rot slot-spec-type 2array 2array
 289     [ { $instance } swap add ] assoc-map ;
 290
 291 : $spec-reader-values ( slot-spec class -- )
 292     ($spec-reader-values) $values ;
 293
 294 : $spec-reader-description ( slot-spec class -- )
 295     [
 296         "Outputs the value stored in the " ,
 297         { $snippet } rot slot-spec-name add ,
 298         " slot of " ,
 299         { $instance } swap add ,
 300         " instance." ,
 301     ] { } make $description ;
 302
 303 : $spec-reader ( reader slot-specs class -- )
 304     >r slot-of-reader r>
 305     over [
 306         2dup $spec-reader-values
 307         2dup $spec-reader-description
 308     ] when 2drop ;
 309
 310 GENERIC: slot-specs ( help-type -- specs )
 311
 312 M: word slot-specs "slots" word-prop ;
 313
 314 : $slot-reader ( reader -- )
 315     first dup "reading" word-prop [ slot-specs ] keep
 316     $spec-reader ;
 317
 318 : $spec-writer-values ( slot-spec class -- )
 319     ($spec-reader-values) reverse $values ;
 320
 321 : $spec-writer-description ( slot-spec class -- )
 322     [
 323         "Stores a new value to the " ,
 324         { $snippet } rot slot-spec-name add ,
 325         " slot of " ,
 326         { $instance } swap add ,
 327         " instance." ,
 328     ] { } make $description ;
 329
 330 : $spec-writer ( writer slot-specs class -- )
 331     >r slot-of-writer r>
 332     over [
 333         2dup $spec-writer-values
 334         2dup $spec-writer-description
 335         dup ?word-name 1array $side-effects
 336     ] when 2drop ;
 337
 338 : $slot-writer ( reader -- )
 339     first dup "writing" word-prop [ slot-specs ] keep
 340     $spec-writer ;
 341
 342 GENERIC: elements* ( elt-type element -- )
 343
 344 M: simple-element elements* [ elements* ] curry* each ;
 345
 346 M: object elements* 2drop ;
 347
 348 M: array elements*
 349     [ [ elements* ] curry* 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                 1 tail [ dup set ] each
 359             ] each
 360         ] curry each
 361     ] H{ } make-assoc keys ;