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