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