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