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