basis/tools/vocabs/browser/browser.factor

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