basis/help/vocabs/vocabs.factor

   1 ! Copyright (C) 2007, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes classes.builtin
   4 classes.intersection classes.mixin classes.predicate
   5 classes.singleton classes.tuple classes.union combinators
   6 effects generic help help.markup help.stylesheet help.topics io
   7 io.pathnames io.styles kernel macros make namespaces sequences
   8 sorting splitting summary vocabs vocabs.files vocabs.hierarchy
   9 vocabs.loader vocabs.metadata words words.symbol ;
  10 IN: help.vocabs
  11
  12 : about ( vocab -- )
  13     [ require ] [ lookup-vocab help ] bi ;
  14
  15 : vocab-row ( vocab -- row )
  16     [ <$pretty-link> ] [ vocab-summary ] bi 2array ;
  17
  18 : vocab-headings ( -- headings )
  19     {
  20         { $strong "Vocabulary" }
  21         { $strong "Summary" }
  22     } ;
  23
  24 : root-heading ( root -- )
  25     [ "Children from " prepend ] [ "Children" ] if*
  26     $heading ;
  27
  28 <PRIVATE
  29 : convert-prefixes ( seq -- seq' )
  30     [ dup vocab-prefix? [ name>> <vocab-link> ] when ] map ;
  31 PRIVATE>
  32
  33 : $vocabs ( seq -- )
  34     convert-prefixes [ vocab-row ] map vocab-headings prefix $table ;
  35
  36 : $vocab-roots ( assoc -- )
  37     [
  38         [ drop ] [ [ root-heading ] [ $vocabs ] bi* ] if-empty
  39     ] assoc-each ;
  40
  41 TUPLE: vocab-tag name ;
  42
  43 INSTANCE: vocab-tag topic
  44
  45 C: <vocab-tag> vocab-tag
  46
  47 : $tags ( seq -- ) [ <vocab-tag> ] map $links ;
  48
  49 TUPLE: vocab-author name ;
  50
  51 INSTANCE: vocab-author topic
  52
  53 C: <vocab-author> vocab-author
  54
  55 : $authors ( seq -- ) [ <vocab-author> ] map $links ;
  56
  57 : describe-help ( vocab -- )
  58     [
  59         dup vocab-help
  60         [ "Documentation" $heading ($link) ]
  61         [ "Summary" $heading vocab-summary print-element ]
  62         ?if
  63     ] unless-empty ;
  64
  65 : describe-children ( vocab -- )
  66     vocab-name disk-vocabs-for-prefix
  67     $vocab-roots ;
  68
  69 : files. ( seq -- )
  70     snippet-style get [
  71         code-style get [
  72             [ nl ] [ [ string>> ] keep write-object ] interleave
  73         ] with-nesting
  74     ] with-style ;
  75
  76 : describe-files ( vocab -- )
  77     vocab-files [ <pathname> ] map [
  78         "Files" $heading
  79         [
  80             files.
  81         ] ($block)
  82     ] unless-empty ;
  83
  84 : describe-metadata-files ( vocab -- )
  85     vocab-metadata-files [ <pathname> ] map [
  86         "Metadata files" $heading
  87         [
  88             files.
  89         ] ($block)
  90     ] unless-empty ;
  91
  92 : describe-tuple-classes ( classes -- )
  93     [
  94         "Tuple classes" $subheading
  95         [
  96             [ <$pretty-link> ]
  97             [ superclass-of <$pretty-link> ]
  98             [ "slots" word-prop [ name>> ] map unwords <$snippet> ]
  99             tri 3array
 100         ] map
 101         { { $strong "Class" } { $strong "Superclass" } { $strong "Slots" } } prefix
 102         $table
 103     ] unless-empty ;
 104
 105 : describe-predicate-classes ( classes -- )
 106     [
 107         "Predicate classes" $subheading
 108         [
 109             [ <$pretty-link> ]
 110             [ superclass-of <$pretty-link> ]
 111             bi 2array
 112         ] map
 113         { { $strong "Class" } { $strong "Superclass" } } prefix
 114         $table
 115     ] unless-empty ;
 116
 117 : (describe-classes) ( classes heading -- )
 118     '[
 119         _ $subheading
 120         [ <$pretty-link> 1array ] map $table
 121     ] unless-empty ;
 122
 123 : describe-builtin-classes ( classes -- )
 124     "Builtin classes" (describe-classes) ;
 125
 126 : describe-singleton-classes ( classes -- )
 127     "Singleton classes" (describe-classes) ;
 128
 129 : describe-mixin-classes ( classes -- )
 130     "Mixin classes" (describe-classes) ;
 131
 132 : describe-union-classes ( classes -- )
 133     "Union classes" (describe-classes) ;
 134
 135 : describe-intersection-classes ( classes -- )
 136     "Intersection classes" (describe-classes) ;
 137
 138 : describe-classes ( classes -- )
 139     [ builtin-class? ] partition
 140     [ tuple-class? ] partition
 141     [ singleton-class? ] partition
 142     [ predicate-class? ] partition
 143     [ mixin-class? ] partition
 144     [ union-class? ] partition
 145     [ intersection-class? ] filter
 146     {
 147         [ describe-builtin-classes ]
 148         [ describe-tuple-classes ]
 149         [ describe-singleton-classes ]
 150         [ describe-predicate-classes ]
 151         [ describe-mixin-classes ]
 152         [ describe-union-classes ]
 153         [ describe-intersection-classes ]
 154     } spread ;
 155
 156 : word-syntax ( word -- string/f )
 157     \ $syntax swap word-help elements dup length 1 =
 158     [ first second ] [ drop f ] if ;
 159
 160 : describe-parsing ( words -- )
 161     [
 162         "Parsing words" $subheading
 163         [
 164             [ <$pretty-link> ]
 165             [ word-syntax dup [ <$snippet> ] when ]
 166             bi 2array
 167         ] map
 168         { { $strong "Word" } { $strong "Syntax" } } prefix
 169         $table
 170     ] unless-empty ;
 171
 172 : word-row ( word -- element )
 173     [ <$pretty-link> ]
 174     [ stack-effect dup [ effect>string <$snippet> ] when ]
 175     bi 2array ;
 176
 177 : word-headings ( -- element )
 178     { { $strong "Word" } { $strong "Stack effect" } } ;
 179
 180 : words-table ( words -- )
 181     [ word-row ] map word-headings prefix $table ;
 182
 183 : (describe-words) ( words heading -- )
 184     '[ _ $subheading words-table ] unless-empty ;
 185
 186 : describe-generics ( words -- )
 187     "Generic words" (describe-words) ;
 188
 189 : describe-macros ( words -- )
 190     "Macro words" (describe-words) ;
 191
 192 : describe-primitives ( words -- )
 193     "Primitives" (describe-words) ;
 194
 195 : describe-compounds ( words -- )
 196     "Ordinary words" (describe-words) ;
 197
 198 : describe-predicates ( words -- )
 199     "Class predicate words" (describe-words) ;
 200
 201 : describe-symbols ( words -- )
 202     [
 203         "Symbol words" $subheading
 204         [ <$pretty-link> 1array ] map $table
 205     ] unless-empty ;
 206
 207 : $words ( words -- )
 208     [
 209         "Words" $heading
 210
 211         natural-sort
 212         [ [ class? ] filter describe-classes ]
 213         [
 214             [ [ class? ] [ symbol? ] bi and ] reject
 215             [ parsing-word? ] partition
 216             [ generic? ] partition
 217             [ macro? ] partition
 218             [ symbol? ] partition
 219             [ primitive? ] partition
 220             [ predicate? ] partition swap
 221             {
 222                 [ describe-parsing ]
 223                 [ describe-generics ]
 224                 [ describe-macros ]
 225                 [ describe-symbols ]
 226                 [ describe-primitives ]
 227                 [ describe-compounds ]
 228                 [ describe-predicates ]
 229             } spread
 230         ] bi
 231     ] unless-empty ;
 232
 233 : vocab-is-not-loaded ( vocab -- )
 234     "Not loaded" $heading
 235     "You must first load this vocabulary to browse its documentation and words."
 236     print-element vocab-name "USE: " prepend 1array $code ;
 237
 238 : describe-words ( vocab -- )
 239     {
 240         { [ dup lookup-vocab ] [ vocab-words $words ] }
 241         { [ dup find-vocab-root ] [ vocab-is-not-loaded ] }
 242         [ drop ]
 243     } cond ;
 244
 245 : words. ( vocab -- )
 246     last-element off
 247     [ require ] [ vocab-words $words ] bi nl ;
 248
 249 : describe-metadata ( vocab -- )
 250     [
 251         [ vocab-tags [ "Tags:" swap \ $tags prefix 2array , ] unless-empty ]
 252         [ vocab-authors [ "Authors:" swap \ $authors prefix 2array , ] unless-empty ]
 253         [ vocab-platforms [ "Platforms:" swap \ $links prefix 2array , ] unless-empty ]
 254         tri
 255     ] { } make
 256     [ "Metadata" $heading $table ] unless-empty ;
 257
 258 : $vocab ( element -- )
 259     first {
 260         [ describe-help ]
 261         [ describe-metadata ]
 262         [ describe-words ]
 263         [ describe-files ]
 264         [ describe-metadata-files ]
 265         [ describe-children ]
 266     } cleave ;
 267
 268 : keyed-vocabs ( str quot -- seq )
 269     [ all-disk-vocabs-recursive ] 2dip '[
 270         [ _ swap @ member? ] filter no-prefixes
 271         [ name>> ] sort-with
 272     ] assoc-map ; inline
 273
 274 : tagged ( tag -- assoc )
 275     [ vocab-tags ] keyed-vocabs ;
 276
 277 : authored ( author -- assoc )
 278     [ vocab-authors ] keyed-vocabs ;
 279
 280 : $tagged-vocabs ( element -- )
 281     first tagged $vocab-roots ;
 282
 283 : $authored-vocabs ( element -- )
 284     first authored $vocab-roots ;
 285
 286 : $all-tags ( element -- )
 287     drop "Tags" $heading all-tags $tags ;
 288
 289 : $all-authors ( element -- )
 290     drop "Authors" $heading all-authors $authors ;
 291
 292 INSTANCE: vocab topic
 293
 294 INSTANCE: vocab-link topic
 295
 296 M: vocab-spec valid-article? drop t ;
 297
 298 M: vocab-spec article-title vocab-name " vocabulary" append ;
 299
 300 M: vocab-spec article-name vocab-name ;
 301
 302 M: vocab-spec article-content
 303     vocab-name \ $vocab swap 2array ;
 304
 305 M: vocab-spec article-parent drop "vocab-index" ;
 306
 307 M: vocab-tag >link ;
 308
 309 M: vocab-tag valid-article? drop t ;
 310
 311 M: vocab-tag article-title
 312     name>> "Vocabularies tagged “" "”" surround ;
 313
 314 M: vocab-tag article-name name>> ;
 315
 316 M: vocab-tag article-content
 317     \ $tagged-vocabs swap name>> 2array ;
 318
 319 M: vocab-tag article-parent drop "vocab-tags" ;
 320
 321 M: vocab-tag summary article-title ;
 322
 323 M: vocab-author >link ;
 324
 325 M: vocab-author valid-article? drop t ;
 326
 327 M: vocab-author article-title
 328     name>> "Vocabularies by " prepend ;
 329
 330 M: vocab-author article-name name>> ;
 331
 332 M: vocab-author article-content
 333     \ $authored-vocabs swap name>> 2array ;
 334
 335 M: vocab-author article-parent drop "vocab-authors" ;
 336
 337 M: vocab-author summary article-title ;