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