Added the missing cache invalidation to the new compiler.

4 files changed, 143 insertions, 49 deletions

diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux
index 8faf83c46..0b811a7b7 100644
--- a/stdlib/source/lux/tool/compiler/default/platform.lux
+++ b/stdlib/source/lux/tool/compiler/default/platform.lux
@@ -48,14 +48,14 @@
       ["." artifact (#+ Registry)]
       ["." descriptor (#+ Descriptor Module)]
       ["." document (#+ Document)]]
-     [io
+     [io (#+ Context)
       ["." context]
       ["ioW" archive]]]]]
   [program
    [compositor
     ["." cli (#+ Compilation Library)]
     ["." static (#+ Static)]
-    ["." import]]])
+    ["." import (#+ Import)]]])
 
 (type: #export (Platform anchor expression directive)
   {#&file-system (file.System Promise)
@@ -138,9 +138,11 @@
       [[registry payload] (///directive.lift-generation
                            (..compile-runtime! platform))
        #let [descriptor,document [(..runtime-descriptor registry) ..runtime-document]]
-       archive (///phase.lift (do try.monad
-                                [[_ archive] (archive.reserve archive.runtime-module archive)]
-                                (archive.add archive.runtime-module descriptor,document archive)))]
+       archive (///phase.lift (if (archive.reserved? archive archive.runtime-module)
+                                (archive.add archive.runtime-module descriptor,document archive)
+                                (do try.monad
+                                  [[_ archive] (archive.reserve archive.runtime-module archive)]
+                                  (archive.add archive.runtime-module descriptor,document archive))))]
       (wrap [archive [descriptor,document payload]])))
 
   (def: (initialize-state extender
@@ -177,7 +179,8 @@
         (///phase.run' state)
         (:: try.monad map product.left)))
 
-  (def: #export (initialize static module expander host-analysis platform generation-bundle host-directive-bundle program extender)
+  (def: #export (initialize static module expander host-analysis platform generation-bundle host-directive-bundle program extender
+                            import compilation-sources)
     (All [<type-vars>]
       (-> Static
           Module
@@ -188,6 +191,7 @@
           (///directive.Bundle <type-vars>)
           (Program expression directive)
           Extender
+          Import (List Context)
           (Promise (Try [<State+> Archive]))))
     (do (try.with promise.monad)
       [#let [state (//init.state (get@ #static.host static)
@@ -201,7 +205,7 @@
                                  program
                                  extender)]
        _ (ioW.enable (get@ #&file-system platform) static)
-       [archive analysis-state bundles] (ioW.thaw (get@ #host platform) (get@ #&file-system platform) static)
+       [archive analysis-state bundles] (ioW.thaw (get@ #host platform) (get@ #&file-system platform) static import compilation-sources)
        state (promise@wrap (initialize-state extender bundles analysis-state state))]
       (if (archive.archived? archive archive.runtime-module)
         (wrap [state archive])
@@ -275,7 +279,11 @@
                                                          #.None])
                                                   
                                                   #.None
-                                                  (case (archive.reserve module archive)
+                                                  (case (if (archive.reserved? archive module)
+                                                          (do try.monad
+                                                            [module-id (archive.id module archive)]
+                                                            (wrap [module-id archive]))
+                                                          (archive.reserve module archive))
                                                     (#try.Success [module-id archive])
                                                     (do @
                                                       [_ (stm.write [archive state] current)
@@ -353,9 +361,9 @@
           try.assume
           product.left))
 
-    (def: #export (compile libraries static expander platform compilation context)
+    (def: #export (compile import static expander platform compilation context)
       (All [<type-vars>]
-        (-> (List Library) Static Expander <Platform> Compilation <Context> <Return>))
+        (-> Import Static Expander <Platform> Compilation <Context> <Return>))
       (let [[compilation-sources compilation-libraries compilation-target compilation-module] compilation
             base-compiler (:share [<type-vars>]
                                   {<Context>
@@ -364,14 +372,13 @@
                                    (:assume
                                     ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list)))})]
         (do (try.with promise.monad)
-          [libraries (import.import (get@ #&file-system platform) compilation-libraries)
-           #let [parallel-compiler (..parallel
+          [#let [parallel-compiler (..parallel
                                     context
                                     (function (_ import! module-id [archive state] module)
                                       (do (try.with promise.monad)
                                         [#let [state (..set-current-module module state)]
                                          input (context.read (get@ #&file-system platform)
-                                                             libraries
+                                                             import
                                                              compilation-sources
                                                              (get@ #static.host-module-extension static)
                                                              module)]
diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux
index 827dfd013..1aea7327f 100644
--- a/stdlib/source/lux/tool/compiler/meta/archive.lux
+++ b/stdlib/source/lux/tool/compiler/meta/archive.lux
@@ -38,28 +38,28 @@
 (exception: #export (unknown-document {module Module}
                                       {known-modules (List Module)})
   (exception.report
-   ["Module" module]
-   ["Known Modules" (exception.enumerate function.identity known-modules)]))
+   ["Module" (%.text module)]
+   ["Known Modules" (exception.enumerate %.text known-modules)]))
 
 (exception: #export (cannot-replace-document {module Module}
                                              {old (Document Any)}
                                              {new (Document Any)})
   (exception.report
-   ["Module" module]
+   ["Module" (%.text module)]
    ["Old key" (signature.description (document.signature old))]
    ["New key" (signature.description (document.signature new))]))
 
 (exception: #export (module-has-already-been-reserved {module Module})
   (exception.report
-   ["Module" module]))
+   ["Module" (%.text module)]))
 
 (exception: #export (module-must-be-reserved-before-it-can-be-added {module Module})
   (exception.report
-   ["Module" module]))
+   ["Module" (%.text module)]))
 
 (exception: #export (module-is-only-reserved {module Module})
   (exception.report
-   ["Module" module]))
+   ["Module" (%.text module)]))
 
 (type: #export ID
   Nat)
@@ -144,7 +144,7 @@
 
   (def: #export (archived? archive module)
     (-> Archive Module Bit)
-    (case (find module archive)
+    (case (..find module archive)
       (#try.Success _)
       yes
 
@@ -161,6 +161,16 @@
                               (#.Some _) (#.Some module)
                               #.None #.None)))))
 
+  (def: #export (reserved? archive module)
+    (-> Archive Module Bit)
+    (let [(^slots [#..resolver]) (:representation archive)]
+      (case (dictionary.get module resolver)
+        (#.Some [id _])
+        yes
+
+        #.None
+        no)))
+
   (def: #export reserved
     (-> Archive (List Module))
     (|>> :representation
diff --git a/stdlib/source/lux/tool/compiler/meta/io.lux b/stdlib/source/lux/tool/compiler/meta/io.lux
index 11faee222..41481d0fa 100644
--- a/stdlib/source/lux/tool/compiler/meta/io.lux
+++ b/stdlib/source/lux/tool/compiler/meta/io.lux
@@ -5,12 +5,15 @@
    [world
     [file (#+ Path System)]]])
 
-(type: #export Context Path)
+(type: #export Context
+  Path)
 
-(type: #export Code Text)
+(type: #export Code
+  Text)
 
 (def: #export (sanitize system)
   (All [m] (-> (System m) Text Text))
   (text.replace-all "/" (:: system separator)))
 
-(def: #export lux-context "lux")
+(def: #export lux-context
+  "lux")
diff --git a/stdlib/source/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/lux/tool/compiler/meta/io/archive.lux
index eef5907d2..77d7b4689 100644
--- a/stdlib/source/lux/tool/compiler/meta/io/archive.lux
+++ b/stdlib/source/lux/tool/compiler/meta/io/archive.lux
@@ -2,6 +2,7 @@
   [lux (#- Module)
    ["@" target (#+ Host)]
    [abstract
+    [predicate (#+ Predicate)]
     ["." monad (#+ do)]]
    [control
     ["." try (#+ Try)]
@@ -20,13 +21,18 @@
     [collection
      ["." list ("#@." functor fold)]
      ["." dictionary (#+ Dictionary)]
-     ["." row (#+ Row)]]]
+     ["." row (#+ Row)]
+     ["." set]]
+    [number
+     ["n" nat]]]
    [world
     ["." file (#+ Path File Directory)]]]
   [program
    [compositor
+    [import (#+ Import)]
     ["." static (#+ Static)]]]
-  ["." //
+  ["." // (#+ Context)
+   ["#." context]
    ["/#" //
     ["." archive (#+ Archive)
      ["." artifact (#+ Artifact)]
@@ -34,14 +40,15 @@
      ["." document (#+ Document)]]
     [cache
      ["." dependency]]
-    [//
+    ["/#" // (#+ Input)
      [language
       ["$" lux
        ["." version]
        ["." analysis]
        ["." synthesis]
        ["." generation]
-       ["." directive]]]]]])
+       ["." directive]
+       ["#/." program]]]]]])
 
 (exception: #export (cannot-prepare {archive Path}
                                     {module-id archive.ID}
@@ -244,13 +251,19 @@
                                                         directives]]))
                                               
                                               (#artifact.Definition name)
-                                              (do @
-                                                [value (:: host re-load context directive)]
-                                                (wrap [(dictionary.put name value definitions)
+                                              (if (text@= $/program.name name)
+                                                (wrap [definitions
                                                        [analysers
                                                         synthesizers
                                                         generators
-                                                        directives]]))
+                                                        directives]])
+                                                (do @
+                                                  [value (:: host re-load context directive)]
+                                                  (wrap [(dictionary.put name value definitions)
+                                                         [analysers
+                                                          synthesizers
+                                                          generators
+                                                          directives]])))
 
                                               (#artifact.Analyser extension)
                                               (do @
@@ -321,21 +334,76 @@
      [document bundles] (promise@wrap (loaded-document (get@ #static.artifact-extension static) host-environment module-id expected actual document))]
     (wrap [[descriptor document] bundles])))
 
-(def: (load-every-reserved-module host-environment system static archive)
+(def: (purge! system static [module-name module-id])
+  (-> (file.System Promise) Static [Module archive.ID] (Promise (Try Any)))
+  (do {@ (try.with promise.monad)}
+    [cache (!.use (:: system directory) [(..module system static module-id)])
+     artifacts (!.use (:: cache files) [])
+     _ (monad.map @ (function (_ artifact)
+                      (!.use (:: artifact delete) []))
+                  artifacts)]
+    (!.use (:: cache discard) [])))
+
+(def: (valid-cache? expected actual)
+  (-> Descriptor Input Bit)
+  (and (text@= (get@ #descriptor.name expected)
+               (get@ #////.module actual))
+       (text@= (get@ #descriptor.file expected)
+               (get@ #////.file actual))
+       (n.= (get@ #descriptor.hash expected)
+            (get@ #////.hash actual))))
+
+(type: Purge
+  (Dictionary Module archive.ID))
+
+(def: initial-purge
+  (-> (List [Bit [Module [archive.ID [Descriptor (Document .Module)]]]])
+      Purge)
+  (|>> (list.search-all (function (_ [valid-cache? [module-name [module-id _]]])
+                          (if valid-cache?
+                            #.None
+                            (#.Some [module-name module-id]))))
+       (dictionary.from-list text.hash)))
+
+(def: (full-purge caches load-order)
+  (-> (List [Bit [Module [archive.ID [Descriptor (Document .Module)]]]])
+      dependency.Order
+      Purge)
+  (list@fold (function (_ [module-name [module-id [descriptor document]]] purge)
+               (let [purged? (: (Predicate Module)
+                                (function (_ module)
+                                  (dictionary.contains? module purge)))]
+                 (if (purged? module-name)
+                   purge
+                   (if (|> descriptor
+                           (get@ #descriptor.references)
+                           set.to-list
+                           (list.any? purged?))
+                     (dictionary.put module-name module-id purge)
+                     purge))))
+             (..initial-purge caches)
+             load-order))
+
+(def: (load-every-reserved-module host-environment system static import contexts archive)
   (All [expression directive]
-    (-> (generation.Host expression directive) (file.System Promise) Static Archive
-        (Promise (Try [Archive
-                       .Lux
-                       Bundles]))))
+    (-> (generation.Host expression directive) (file.System Promise) Static Import (List Context) Archive
+        (Promise (Try [Archive .Lux Bundles]))))
   (do {@ (try.with promise.monad)}
     [pre-loaded-caches (|> archive
                            archive.reservations
                            (monad.map @ (function (_ [module-name module-id])
                                           (do @
                                             [data (..read-module-descriptor system static module-id)
-                                             descriptor,document (promise@wrap (<b>.run ..parser data))]
-                                            (wrap [module-name [module-id descriptor,document]])))))
+                                             [descriptor document] (promise@wrap (<b>.run ..parser data))]
+                                            (if (text@= archive.runtime-module module-name)
+                                              (wrap [true
+                                                     [module-name [module-id [descriptor document]]]])
+                                              (do @
+                                                [input (//context.read system import contexts (get@ #static.host-module-extension static) module-name)]
+                                                (wrap [(..valid-cache? descriptor input)
+                                                       [module-name [module-id [descriptor document]]]])))))))
      load-order (|> pre-loaded-caches
+                    (list@map product.right)
                     (monad.fold try.monad
                                 (function (_ [module [module-id descriptor,document]] archive)
                                   (archive.add module descriptor,document archive))
@@ -343,15 +411,21 @@
                     (:: try.monad map (dependency.load-order $.key))
                     (:: try.monad join)
                     promise@wrap)
-     loaded-caches (monad.map @ (function (_ [module-name [module-id descriptor,document]])
-                                  (do @
-                                    [[descriptor,document bundles] (..load-definitions system static module-id host-environment descriptor,document)]
-                                    (wrap [[module-name descriptor,document]
-                                           bundles])))
-                              load-order)]
+     #let [purge (..full-purge pre-loaded-caches load-order)]
+     _ (|> purge
+           dictionary.entries
+           (monad.map @ (..purge! system static)))
+     loaded-caches (|> load-order
+                       (list.filter (function (_ [module-name [module-id [descriptor document]]])
+                                      (not (dictionary.contains? module-name purge))))
+                       (monad.map @ (function (_ [module-name [module-id descriptor,document]])
+                                      (do @
+                                        [[descriptor,document bundles] (..load-definitions system static module-id host-environment descriptor,document)]
+                                        (wrap [[module-name descriptor,document]
+                                               bundles])))))]
     (promise@wrap
-     (do try.monad
-       [archive (monad.fold try.monad
+     (do {@ try.monad}
+       [archive (monad.fold @
                             (function (_ [[module descriptor,document] _bundle] archive)
                               (archive.add module descriptor,document archive))
                             archive
@@ -368,9 +442,9 @@
                          ..empty-bundles
                          loaded-caches)])))))
 
-(def: #export (thaw host-environment system static)
+(def: #export (thaw host-environment system static import contexts)
   (All [expression directive]
-    (-> (generation.Host expression directive) (file.System Promise) Static
+    (-> (generation.Host expression directive) (file.System Promise) Static Import (List Context)
         (Promise (Try [Archive .Lux Bundles]))))
   (do promise.monad
     [file (!.use (:: system file) (..general-descriptor system static))]
@@ -379,7 +453,7 @@
       (do (try.with promise.monad)
         [binary (!.use (:: file content) [])
          archive (promise@wrap (archive.import ///.version binary))]
-        (..load-every-reserved-module host-environment system static archive))
+        (..load-every-reserved-module host-environment system static import contexts archive))
       
       (#try.Failure error)
       (wrap (#try.Success [archive.empty