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 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( arg -- ) ;
  31 M: word print-element { } swap execute( arg -- ) ;
  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 ! Images
 141 : $image ( element -- )
 142     [ [ "" ] dip first image associate format ] ($span) ;
 143
 144 ! Some links
 145 : write-link ( string object -- )
 146     link-style get [ write-object ] with-style ;
 147
 148 : ($link) ( article -- )
 149     [ [ article-name ] [ >link ] bi write-link ] ($span) ;
 150
 151 : $link ( element -- )
 152     first ($link) ;
 153
 154 : ($definition-link) ( word -- )
 155     [ article-name ] keep write-link ;
 156
 157 : $definition-link ( element -- )
 158     first ($definition-link) ;
 159
 160 : ($long-link) ( object -- )
 161     [ article-title ] [ >link ] bi write-link ;
 162
 163 : $long-link ( object -- )
 164     first ($long-link) ;
 165
 166 : ($subsection) ( element quot -- )
 167     [
 168         subsection-style get [
 169             bullet get write bl
 170             call
 171         ] with-style
 172     ] ($block) ; inline
 173
 174 : $subsection ( element -- )
 175     [ first ($long-link) ] ($subsection) ;
 176
 177 : ($vocab-link) ( text vocab -- )
 178     >vocab-link write-link ;
 179
 180 : $vocab-subsection ( element -- )
 181     [
 182         first2 dup vocab-help dup [
 183             2nip ($long-link)
 184         ] [
 185             drop ($vocab-link)
 186         ] if
 187     ] ($subsection) ;
 188
 189 : $vocab-link ( element -- )
 190     first dup vocab-name swap ($vocab-link) ;
 191
 192 : $vocabulary ( element -- )
 193     first vocabulary>> [
 194         "Vocabulary" $heading nl dup ($vocab-link)
 195     ] when* ;
 196
 197 : textual-list ( seq quot -- )
 198     [ ", " print-element ] swap interleave ; inline
 199
 200 : $links ( topics -- )
 201     [ [ ($link) ] textual-list ] ($span) ;
 202
 203 : $vocab-links ( vocabs -- )
 204     [ vocab ] map $links ;
 205
 206 : $see-also ( topics -- )
 207     "See also" $heading $links ;
 208
 209 : related-words ( seq -- )
 210     dup '[ _ "related" set-word-prop ] each ;
 211
 212 : $related ( element -- )
 213     first dup "related" word-prop remove
 214     [ $see-also ] unless-empty ;
 215
 216 : ($grid) ( style quot -- )
 217     [
 218         table-content-style get [
 219             swap [ last-element off call ] tabular-output
 220         ] with-style
 221     ] ($block) table last-element set ; inline
 222
 223 : $list ( element -- )
 224     list-style get [
 225         [
 226             [
 227                 bullet get write-cell
 228                 [ print-element ] with-cell
 229             ] with-row
 230         ] each
 231     ] ($grid) ;
 232
 233 : $table ( element -- )
 234     table-style get [
 235         [
 236             [
 237                 [ [ print-element ] with-cell ] each
 238             ] with-row
 239         ] each
 240     ] ($grid) ;
 241
 242 : a/an ( str -- str )
 243     [ first ] [ length ] bi 1 =
 244     "afhilmnorsx" "aeiou" ? member? "an" "a" ? ;
 245
 246 GENERIC: ($instance) ( element -- )
 247
 248 M: word ($instance)
 249     dup name>> a/an write bl ($link) ;
 250
 251 M: string ($instance)
 252     dup a/an write bl $snippet ;
 253
 254 M: f ($instance)
 255     drop { f } $link ;
 256
 257 : $instance ( element -- ) first ($instance) ;
 258
 259 : $or ( element -- )
 260     dup length {
 261         { 1 [ first ($instance) ] }
 262         { 2 [ first2 [ ($instance) " or " print-element ] [ ($instance) ] bi* ] }
 263         [
 264             drop
 265             unclip-last
 266             [ [ ($instance) ", " print-element ] each ]
 267             [ "or " print-element ($instance) ]
 268             bi*
 269         ]
 270     } case ;
 271
 272 : $maybe ( element -- )
 273     f suffix $or ;
 274
 275 : $quotation ( element -- )
 276     { "a " { $link quotation } " with stack effect " } print-element
 277     $snippet ;
 278
 279 : values-row ( seq -- seq )
 280     unclip \ $snippet swap ?word-name 2array
 281     swap dup first word? [ \ $instance prefix ] when 2array ;
 282
 283 : $values ( element -- )
 284     "Inputs and outputs" $heading
 285     [ values-row ] map $table ;
 286
 287 : $side-effects ( element -- )
 288     "Side effects" $heading "Modifies " print-element
 289     [ $snippet ] textual-list ;
 290
 291 : $errors ( element -- )
 292     "Errors" $heading print-element ;
 293
 294 : $notes ( element -- )
 295     "Notes" $heading print-element ;
 296
 297 : ($see) ( word quot -- )
 298     [
 299         snippet-style get [
 300             code-style get swap with-nesting
 301         ] with-style
 302     ] ($block) ; inline
 303
 304 : $see ( element -- ) first [ see ] ($see) ;
 305
 306 : $synopsis ( element -- ) first [ synopsis write ] ($see) ;
 307
 308 : $definition ( element -- )
 309     "Definition" $heading $see ;
 310
 311 : $methods ( element -- )
 312     first methods [
 313         "Methods" $heading
 314         [ see-all ] ($see)
 315     ] unless-empty ;
 316
 317 : $value ( object -- )
 318     "Variable value" $heading
 319     "Current value in global namespace:" print-element
 320     first dup [ pprint-short ] ($code) ;
 321
 322 : $curious ( element -- )
 323     "For the curious..." $heading print-element ;
 324
 325 : $references ( element -- )
 326     "References" $heading
 327     unclip print-element [ \ $link swap ] { } map>assoc $list ;
 328
 329 : $shuffle ( element -- )
 330     drop
 331     "Shuffle word. Re-arranges the stack according to the stack effect pattern." $description ;
 332
 333 : $low-level-note ( children -- )
 334     drop
 335     "Calling this word directly is not necessary in most cases. Higher-level words call it automatically." $notes ;
 336
 337 : $values-x/y ( children -- )
 338     drop { { "x" number } { "y" number } } $values ;
 339
 340 : $parsing-note ( children -- )
 341     drop
 342     "This word should only be called from parsing words."
 343     $notes ;
 344
 345 : $io-error ( children -- )
 346     drop
 347     "Throws an error if the I/O operation fails." $errors ;
 348
 349 : $prettyprinting-note ( children -- )
 350     drop {
 351         "This word should only be called from inside the "
 352         { $link with-pprint } " combinator."
 353     } $notes ;
 354
 355 GENERIC: elements* ( elt-type element -- )
 356
 357 M: simple-element elements*
 358     [ elements* ] with each ;
 359
 360 M: object elements* 2drop ;
 361
 362 M: array elements*
 363     [ [ elements* ] with each ] 2keep
 364     [ first eq? ] keep swap [ , ] [ drop ] if ;
 365
 366 : elements ( elt-type element -- seq ) [ elements* ] { } make ;
 367
 368 : collect-elements ( element seq -- elements )
 369     swap '[ _ elements [ rest ] map concat ] map concat prune ;
 370
 371 : <$link> ( topic -- element )
 372     1array \ $link prefix ;
 373
 374 : <$snippet> ( str -- element )
 375     1array \ $snippet prefix ;