basis/tools/vocabs/vocabs.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov.\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: kernel io io.styles io.files io.files.info io.directories\r
   4 io.pathnames io.encodings.utf8 vocabs.loader vocabs sequences\r
   5 namespaces make math.parser arrays hashtables assocs memoize\r
   6 summary sorting splitting combinators source-files debugger\r
   7 continuations compiler.errors init checksums checksums.crc32\r
   8 sets accessors generic definitions words ;\r
   9 IN: tools.vocabs\r
  10 \r
  11 : vocab-xref ( vocab quot -- vocabs )\r
  12     [ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map\r
  13     [\r
  14         [ [ word? ] [ generic? not ] bi and ] filter [\r
  15             dup method-body?\r
  16             [ "method-generic" word-prop ] when\r
  17             vocabulary>>\r
  18         ] map\r
  19     ] gather natural-sort remove sift ; inline\r
  20 \r
  21 : vocabs. ( seq -- )\r
  22     [ dup >vocab-link write-object nl ] each ;\r
  23 \r
  24 : vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;\r
  25 \r
  26 : vocab-uses. ( vocab -- ) vocab-uses vocabs. ;\r
  27 \r
  28 : vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;\r
  29 \r
  30 : vocab-usage. ( vocab -- ) vocab-usage vocabs. ;\r
  31 \r
  32 : vocab-tests-file ( vocab -- path )\r
  33     dup "-tests.factor" vocab-dir+ vocab-append-path dup\r
  34     [ dup exists? [ drop f ] unless ] [ drop f ] if ;\r
  35 \r
  36 : vocab-tests-dir ( vocab -- paths )\r
  37     dup vocab-dir "tests" append-path vocab-append-path dup [\r
  38         dup exists? [\r
  39             dup directory-files [ ".factor" tail? ] filter\r
  40             [ append-path ] with map\r
  41         ] [ drop f ] if\r
  42     ] [ drop f ] if ;\r
  43 \r
  44 : vocab-tests ( vocab -- tests )\r
  45     [\r
  46         [ vocab-tests-file [ , ] when* ]\r
  47         [ vocab-tests-dir [ % ] when* ] bi\r
  48     ] { } make ;\r
  49 \r
  50 : vocab-files ( vocab -- seq )\r
  51     [\r
  52         [ vocab-source-path [ , ] when* ]\r
  53         [ vocab-docs-path [ , ] when* ]\r
  54         [ vocab-tests % ] tri\r
  55     ] { } make ;\r
  56 \r
  57 : vocab-heading. ( vocab -- )\r
  58     nl\r
  59     "==== " write\r
  60     [ vocab-name ] [ vocab write-object ] bi ":" print\r
  61     nl ;\r
  62 \r
  63 : load-error. ( triple -- )\r
  64     [ first vocab-heading. ] [ second print-error ] bi ;\r
  65 \r
  66 : load-failures. ( failures -- )\r
  67     [ load-error. nl ] each ;\r
  68 \r
  69 SYMBOL: failures\r
  70 \r
  71 : require-all ( vocabs -- failures )\r
  72     [\r
  73         V{ } clone blacklist set\r
  74         V{ } clone failures set\r
  75         [\r
  76             [ require ]\r
  77             [ swap vocab-name failures get set-at ]\r
  78             recover\r
  79         ] each\r
  80         failures get\r
  81     ] with-compiler-errors ;\r
  82 \r
  83 : source-modified? ( path -- ? )\r
  84     dup source-files get at [\r
  85         dup path>>\r
  86         dup exists? [\r
  87             utf8 file-lines crc32 checksum-lines\r
  88             swap checksum>> = not\r
  89         ] [\r
  90             2drop f\r
  91         ] if\r
  92     ] [\r
  93         exists?\r
  94     ] ?if ;\r
  95 \r
  96 SYMBOL: changed-vocabs\r
  97 \r
  98 [ f changed-vocabs set-global ] "tools.vocabs" add-init-hook\r
  99 \r
 100 : changed-vocab ( vocab -- )\r
 101     dup vocab changed-vocabs get and\r
 102     [ dup changed-vocabs get set-at ] [ drop ] if ;\r
 103 \r
 104 : unchanged-vocab ( vocab -- )\r
 105     changed-vocabs get delete-at ;\r
 106 \r
 107 : unchanged-vocabs ( vocabs -- )\r
 108     [ unchanged-vocab ] each ;\r
 109 \r
 110 : changed-vocab? ( vocab -- ? )\r
 111     changed-vocabs get dup [ key? ] [ 2drop t ] if ;\r
 112 \r
 113 : filter-changed ( vocabs -- vocabs' )\r
 114     [ changed-vocab? ] filter ;\r
 115 \r
 116 SYMBOL: modified-sources\r
 117 SYMBOL: modified-docs\r
 118 \r
 119 : (to-refresh) ( vocab variable loaded? path -- )\r
 120     dup [\r
 121         swap [\r
 122             pick changed-vocab? [\r
 123                 source-modified? [ get push ] [ 2drop ] if\r
 124             ] [ 3drop ] if\r
 125         ] [ drop get push ] if\r
 126     ] [ 2drop 2drop ] if ;\r
 127 \r
 128 : to-refresh ( prefix -- modified-sources modified-docs unchanged )\r
 129     [\r
 130         V{ } clone modified-sources set\r
 131         V{ } clone modified-docs set\r
 132 \r
 133         child-vocabs [\r
 134             [\r
 135                 [\r
 136                     [ modified-sources ]\r
 137                     [ vocab source-loaded?>> ]\r
 138                     [ vocab-source-path ]\r
 139                     tri (to-refresh)\r
 140                 ] [\r
 141                     [ modified-docs ]\r
 142                     [ vocab docs-loaded?>> ]\r
 143                     [ vocab-docs-path ]\r
 144                     tri (to-refresh)\r
 145                 ] bi\r
 146             ] each\r
 147 \r
 148             modified-sources get\r
 149             modified-docs get\r
 150         ]\r
 151         [ modified-docs get modified-sources get append diff ] bi\r
 152     ] with-scope ;\r
 153 \r
 154 : do-refresh ( modified-sources modified-docs unchanged -- )\r
 155     unchanged-vocabs\r
 156     [\r
 157         [ [ vocab f >>source-loaded? drop ] each ]\r
 158         [ [ vocab f >>docs-loaded? drop ] each ] bi*\r
 159     ]\r
 160     [\r
 161         append prune\r
 162         [ unchanged-vocabs ]\r
 163         [ require-all load-failures. ] bi\r
 164     ] 2bi ;\r
 165 \r
 166 : refresh ( prefix -- ) to-refresh do-refresh ;\r
 167 \r
 168 : refresh-all ( -- ) "" refresh ;\r
 169 \r
 170 MEMO: vocab-file-contents ( vocab name -- seq )\r
 171     vocab-append-path dup\r
 172     [ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ;\r
 173 \r
 174 : set-vocab-file-contents ( seq vocab name -- )\r
 175     dupd vocab-append-path [\r
 176         utf8 set-file-lines\r
 177         \ vocab-file-contents reset-memoized\r
 178     ] [\r
 179         "The " swap vocab-name\r
 180         " vocabulary was not loaded from the file system"\r
 181         3append throw\r
 182     ] ?if ;\r
 183 \r
 184 : vocab-summary-path ( vocab -- string )\r
 185     vocab-dir "summary.txt" append-path ;\r
 186 \r
 187 : vocab-summary ( vocab -- summary )\r
 188     dup dup vocab-summary-path vocab-file-contents\r
 189     [\r
 190         vocab-name " vocabulary" append\r
 191     ] [\r
 192         nip first\r
 193     ] if-empty ;\r
 194 \r
 195 M: vocab summary\r
 196     [\r
 197         dup vocab-summary %\r
 198         " (" %\r
 199         words>> assoc-size #\r
 200         " words)" %\r
 201     ] "" make ;\r
 202 \r
 203 M: vocab-link summary vocab-summary ;\r
 204 \r
 205 : set-vocab-summary ( string vocab -- )\r
 206     [ 1array ] dip\r
 207     dup vocab-summary-path\r
 208     set-vocab-file-contents ;\r
 209 \r
 210 : vocab-tags-path ( vocab -- string )\r
 211     vocab-dir "tags.txt" append-path ;\r
 212 \r
 213 : vocab-tags ( vocab -- tags )\r
 214     dup vocab-tags-path vocab-file-contents harvest ;\r
 215 \r
 216 : set-vocab-tags ( tags vocab -- )\r
 217     dup vocab-tags-path set-vocab-file-contents ;\r
 218 \r
 219 : add-vocab-tags ( tags vocab -- )\r
 220     [ vocab-tags append prune ] keep set-vocab-tags ;\r
 221 \r
 222 : vocab-authors-path ( vocab -- string )\r
 223     vocab-dir "authors.txt" append-path ;\r
 224 \r
 225 : vocab-authors ( vocab -- authors )\r
 226     dup vocab-authors-path vocab-file-contents harvest ;\r
 227 \r
 228 : set-vocab-authors ( authors vocab -- )\r
 229     dup vocab-authors-path set-vocab-file-contents ;\r
 230 \r
 231 : subdirs ( dir -- dirs )\r
 232     [\r
 233         [ link-info directory? ] filter\r
 234     ] with-directory-files natural-sort ;\r
 235 \r
 236 : (all-child-vocabs) ( root name -- vocabs )\r
 237     [\r
 238         vocab-dir append-path dup exists?\r
 239         [ subdirs ] [ drop { } ] if\r
 240     ] keep [\r
 241         swap [ "." glue ] with map\r
 242     ] unless-empty ;\r
 243 \r
 244 : vocabs-in-dir ( root name -- )\r
 245     dupd (all-child-vocabs) [\r
 246         2dup vocab-dir? [ dup >vocab-link , ] when\r
 247         vocabs-in-dir\r
 248     ] with each ;\r
 249 \r
 250 : all-vocabs ( -- assoc )\r
 251     vocab-roots get [\r
 252         dup [ "" vocabs-in-dir ] { } make\r
 253     ] { } map>assoc ;\r
 254 \r
 255 MEMO: all-vocabs-seq ( -- seq )\r
 256     all-vocabs values concat ;\r
 257 \r
 258 : unportable? ( name -- ? )\r
 259     vocab-tags "unportable" swap member? ;\r
 260 \r
 261 : filter-unportable ( seq -- seq' )\r
 262     [ vocab-name unportable? not ] filter ;\r
 263 \r
 264 : try-everything ( -- failures )\r
 265     all-vocabs-seq\r
 266     filter-unportable\r
 267     require-all ;\r
 268 \r
 269 : load-everything ( -- )\r
 270     try-everything load-failures. ;\r
 271 \r
 272 : unrooted-child-vocabs ( prefix -- seq )\r
 273     dup empty? [ CHAR: . suffix ] unless\r
 274     vocabs\r
 275     [ find-vocab-root not ] filter\r
 276     [\r
 277         vocab-name swap ?head CHAR: . rot member? not and\r
 278     ] with filter\r
 279     [ vocab ] map ;\r
 280 \r
 281 : all-child-vocabs ( prefix -- assoc )\r
 282     vocab-roots get [\r
 283         dup pick (all-child-vocabs) [ >vocab-link ] map\r
 284     ] { } map>assoc\r
 285     swap unrooted-child-vocabs f swap 2array suffix ;\r
 286 \r
 287 : all-child-vocabs-seq ( prefix -- assoc )\r
 288     vocab-roots get swap [\r
 289         dupd (all-child-vocabs)\r
 290         [ vocab-dir? ] with filter\r
 291     ] curry map concat ;\r
 292 \r
 293 MEMO: all-tags ( -- seq )\r
 294     all-vocabs-seq [ vocab-tags ] gather natural-sort ;\r
 295 \r
 296 MEMO: all-authors ( -- seq )\r
 297     all-vocabs-seq [ vocab-authors ] gather natural-sort ;\r
 298 \r
 299 : reset-cache ( -- )\r
 300     root-cache get-global clear-assoc\r
 301     \ vocab-file-contents reset-memoized\r
 302     \ all-vocabs-seq reset-memoized\r
 303     \ all-authors reset-memoized\r
 304     \ all-tags reset-memoized ;\r