extra/tools/browser/browser.factor

   1 ! Copyright (C) 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: namespaces splitting sequences io.files kernel assocs
   4 words vocabs vocabs.loader definitions parser continuations
   5 inspector debugger io io.styles io.streams.lines hashtables
   6 sorting prettyprint source-files arrays combinators strings
   7 system math.parser help.markup help.topics help.syntax
   8 help.stylesheet ;
   9 IN: tools.browser
  10
  11 : vocab-summary-path ( vocab -- string )
  12     vocab-dir "summary.txt" path+ ;
  13
  14 : vocab-summary ( vocab -- summary )
  15     dup dup vocab-summary-path vocab-file-contents
  16     dup empty? [
  17         drop vocab-name " vocabulary" append
  18     ] [
  19         nip first
  20     ] if ;
  21
  22 M: vocab summary
  23     [
  24         dup vocab-summary %
  25         " (" %
  26         vocab-words assoc-size #
  27         " words)" %
  28     ] "" make ;
  29
  30 M: vocab-link summary vocab-summary ;
  31
  32 : set-vocab-summary ( string vocab -- )
  33     >r 1array r>
  34     dup vocab-summary-path
  35     set-vocab-file-contents ;
  36
  37 : vocab-tags-path ( vocab -- string )
  38     vocab-dir "tags.txt" path+ ;
  39
  40 : vocab-tags ( vocab -- tags )
  41     dup vocab-tags-path vocab-file-contents ;
  42
  43 : set-vocab-tags ( tags vocab -- )
  44     dup vocab-tags-path set-vocab-file-contents ;
  45
  46 : add-vocab-tags ( tags vocab -- )
  47     [ vocab-tags append prune ] keep set-vocab-tags ;
  48
  49 : vocab-authors-path ( vocab -- string )
  50     vocab-dir "authors.txt" path+ ;
  51
  52 : vocab-authors ( vocab -- authors )
  53     dup vocab-authors-path vocab-file-contents ;
  54
  55 : set-vocab-authors ( authors vocab -- )
  56     dup vocab-authors-path set-vocab-file-contents ;
  57
  58 : vocab-dir? ( root name -- ? )
  59     over [
  60         vocab-source path+ ?resource-path exists?
  61     ] [
  62         2drop f
  63     ] if ;
  64
  65 : subdirs ( dir -- dirs )
  66     directory [ second ] subset keys natural-sort ;
  67
  68 : (all-child-vocabs) ( root name -- vocabs )
  69     [ vocab-dir path+ ?resource-path subdirs ] keep
  70     dup empty? [
  71         drop
  72     ] [
  73         swap [ "." swap 3append ] curry* map
  74     ] if ;
  75
  76 : vocabs-in-dir ( root name -- )
  77     dupd (all-child-vocabs) [
  78         2dup vocab-dir? [ 2dup swap >vocab-link , ] when
  79         vocabs-in-dir
  80     ] curry* each ;
  81
  82 : sane-vocab-roots "." vocab-roots get remove ;
  83
  84 : all-vocabs ( -- assoc )
  85     sane-vocab-roots [
  86         dup [ "" vocabs-in-dir ] { } make
  87     ] { } map>assoc ;
  88
  89 : all-vocabs-seq ( -- seq )
  90     all-vocabs values concat ;
  91
  92 : dangerous? ( name -- ? )
  93     #! Hack
  94     {
  95         { [ "cpu." ?head ] [ t ] }
  96         { [ "io.unix" ?head ] [ t ] }
  97         { [ "io.windows" ?head ] [ t ] }
  98         { [ "ui.x11" ?head ] [ t ] }
  99         { [ "ui.windows" ?head ] [ t ] }
 100         { [ "ui.cocoa" ?head ] [ t ] }
 101         { [ "cocoa" ?head ] [ t ] }
 102         { [ "vocabs.loader.test" ?head ] [ t ] }
 103         { [ "editors." ?head ] [ t ] }
 104         { [ ".windows" ?tail ] [ t ] }
 105         { [ ".unix" ?tail ] [ t ] }
 106         { [ "unix." ?head ] [ t ] }
 107         { [ ".linux" ?tail ] [ t ] }
 108         { [ ".bsd" ?tail ] [ t ] }
 109         { [ ".macosx" ?tail ] [ t ] }
 110         { [ "windows." ?head ] [ t ] }
 111         { [ "cocoa" ?head ] [ t ] }
 112         { [ ".test" ?tail ] [ t ] }
 113         { [ dup "tools.deploy.app" = ] [ t ] }
 114         { [ t ] [ f ] }
 115     } cond nip ;
 116
 117 : load-everything ( -- )
 118     all-vocabs-seq
 119     [ vocab-name dangerous? not ] subset
 120     [ [ require ] each ] no-parse-hook ;
 121
 122 : unrooted-child-vocabs ( prefix -- seq )
 123     dup empty? [ CHAR: . add ] unless
 124     vocabs
 125     [ vocab-root not ] subset
 126     [
 127         vocab-name swap ?head CHAR: . rot member? not and
 128     ] curry* subset
 129     [ vocab ] map ;
 130
 131 : all-child-vocabs ( prefix -- assoc )
 132     sane-vocab-roots [
 133         dup pick dupd (all-child-vocabs)
 134         [ swap >vocab-link ] curry* map
 135     ] { } map>assoc
 136     f rot unrooted-child-vocabs 2array add ;
 137
 138 : load-children ( prefix -- )
 139     all-child-vocabs values concat
 140     [ [ require ] each ] no-parse-hook ;
 141
 142 : vocab-status-string ( vocab -- string )
 143     {
 144         { [ dup not ] [ drop "" ] }
 145         { [ dup vocab-main ] [ drop "[Runnable]" ] }
 146         { [ t ] [ drop "[Loaded]" ] }
 147     } cond ;
 148
 149 : write-status ( vocab -- )
 150     vocab vocab-status-string write ;
 151
 152 : vocab. ( vocab -- )
 153     [
 154         dup [ write-status ] with-cell
 155         dup [ ($link) ] with-cell
 156         [ vocab-summary write ] with-cell
 157     ] with-row ;
 158
 159 : vocab-headings. ( -- )
 160     [
 161         [ "State" write ] with-cell
 162         [ "Vocabulary" write ] with-cell
 163         [ "Summary" write ] with-cell
 164     ] with-row ;
 165
 166 : root-heading. ( root -- )
 167     [ "Children from " swap append ] [ "Children" ] if*
 168     $heading ;
 169
 170 : vocabs. ( assoc -- )
 171     [
 172         dup empty? [
 173             2drop
 174         ] [
 175             swap root-heading.
 176             standard-table-style [
 177                 vocab-headings. [ vocab. ] each
 178             ] ($grid)
 179         ] if
 180     ] assoc-each ;
 181
 182 : describe-summary ( vocab -- )
 183     vocab-summary [
 184         "Summary" $heading print-element
 185     ] when* ;
 186
 187 TUPLE: vocab-tag name ;
 188
 189 C: <vocab-tag> vocab-tag
 190
 191 : tags. ( seq -- ) [ <vocab-tag> ] map $links ;
 192
 193 : describe-tags ( vocab -- )
 194     vocab-tags f like [
 195         "Tags" $heading tags.
 196     ] when* ;
 197
 198 TUPLE: vocab-author name ;
 199
 200 C: <vocab-author> vocab-author
 201
 202 : authors. ( seq -- ) [ <vocab-author> ] map $links ;
 203
 204 : describe-authors ( vocab -- )
 205     vocab-authors f like [
 206         "Authors" $heading authors.
 207     ] when* ;
 208
 209 : describe-help ( vocab -- )
 210     vocab-help [
 211         "Documentation" $heading nl ($link)
 212     ] when* ;
 213
 214 : describe-children ( vocab -- )
 215     vocab-name all-child-vocabs vocabs. ;
 216
 217 : describe-files ( vocab -- )
 218     vocab-files [ <pathname> ] map [
 219         "Files" $heading
 220         [
 221             snippet-style get [
 222                 code-style get [
 223                     stack.
 224                 ] with-nesting
 225             ] with-style
 226         ] ($block)
 227     ] when* ;
 228
 229 : describe-words ( vocab -- )
 230     words dup empty? [
 231         "Words" $heading
 232         dup natural-sort $links
 233     ] unless drop ;
 234
 235 : map>set ( seq quot -- )
 236     map concat prune natural-sort ; inline
 237
 238 : vocab-xref ( vocab quot -- vocabs )
 239     >r dup vocab-name swap words r> map
 240     [ [ word? ] subset [ word-vocabulary ] map ] map>set
 241     remove [ vocab ] map ; inline
 242
 243 : vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
 244
 245 : vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
 246
 247 : describe-uses ( vocab -- )
 248     vocab-uses dup empty? [
 249         "Uses" $heading
 250         dup $links
 251     ] unless drop ;
 252
 253 : describe-usage ( vocab -- )
 254     vocab-usage dup empty? [
 255         "Used by" $heading
 256         dup $links
 257     ] unless drop ;
 258
 259 : $describe-vocab ( element -- )
 260     first
 261     dup describe-children
 262     dup vocab-root over vocab-dir? [
 263         dup describe-summary
 264         dup describe-tags
 265         dup describe-authors
 266         dup describe-files
 267     ] when
 268     dup vocab [
 269         dup describe-help
 270         dup describe-words
 271         dup describe-uses
 272         dup describe-usage
 273     ] when drop ;
 274
 275 : keyed-vocabs ( str quot -- seq )
 276     all-vocabs [
 277         swap >r
 278         [ >r 2dup r> swap call member? ] subset
 279         r> swap
 280     ] assoc-map 2nip ; inline
 281
 282 : tagged ( tag -- assoc )
 283     [ vocab-tags ] keyed-vocabs ;
 284
 285 : authored ( author -- assoc )
 286     [ vocab-authors ] keyed-vocabs ;
 287
 288 : $tagged-vocabs ( element -- )
 289     first tagged vocabs. ;
 290
 291 : all-tags ( vocabs -- seq ) [ vocab-tags ] map>set ;
 292
 293 : $authored-vocabs ( element -- )
 294     first authored vocabs. ;
 295
 296 : all-authors ( vocabs -- seq ) [ vocab-authors ] map>set ;
 297
 298 : $tags,authors ( element -- )
 299     drop
 300     all-vocabs-seq
 301     "Tags" $heading
 302     dup all-tags tags.
 303     "Authors" $heading
 304     all-authors authors. ;
 305
 306 ARTICLE: "vocab-index" "Vocabulary index"
 307 { $tags,authors }
 308 { $describe-vocab "" } ;
 309
 310 M: vocab-spec article-title vocab-name " vocabulary" append ;
 311
 312 M: vocab-spec article-name vocab-name ;
 313
 314 M: vocab-spec article-content
 315     vocab-name \ $describe-vocab swap 2array ;
 316
 317 M: vocab-spec article-parent drop "vocab-index" ;
 318
 319 M: vocab-tag >link ;
 320
 321 M: vocab-tag article-title
 322     vocab-tag-name "Vocabularies tagged ``" swap "''" 3append ;
 323
 324 M: vocab-tag article-name vocab-tag-name ;
 325
 326 M: vocab-tag article-content
 327     \ $tagged-vocabs swap vocab-tag-name 2array ;
 328
 329 M: vocab-tag article-parent drop "vocab-index" ;
 330
 331 M: vocab-tag summary article-title ;
 332
 333 M: vocab-author >link ;
 334
 335 M: vocab-author article-title
 336     vocab-author-name "Vocabularies by " swap append ;
 337
 338 M: vocab-author article-name vocab-author-name ;
 339
 340 M: vocab-author article-content
 341     \ $authored-vocabs swap vocab-author-name 2array ;
 342
 343 M: vocab-author article-parent drop "vocab-index" ;
 344
 345 M: vocab-author summary article-title ;