basis/help/vocabs/vocabs.factor

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