- WIP: Caching.

4 files changed, 393 insertions, 0 deletions

diff --git a/new-luxc/source/luxc/cache.lux b/new-luxc/source/luxc/cache.lux
new file mode 100644
index 000000000..2b47c12dc
--- /dev/null
+++ b/new-luxc/source/luxc/cache.lux
@@ -0,0 +1,9 @@
+(.module:
+  lux
+  (lux (data [text]
+             (coll [dict #+ Dict]))))
+
+(type: #export Cache (Dict Text Module))
+(def: #export empty Cache (dict.new text.Hash<Text>))
+
+(def: #export descriptor-name Text "lux_module_descriptor")
diff --git a/new-luxc/source/luxc/cache/description.lux b/new-luxc/source/luxc/cache/description.lux
new file mode 100644
index 000000000..1bfb1209c
--- /dev/null
+++ b/new-luxc/source/luxc/cache/description.lux
@@ -0,0 +1,147 @@
+(.module:
+  lux
+  (lux (control [monad #+ do]
+                ["p" parser "parser/" Monad<Parser>]
+                ["ex" exception #+ exception:])
+       (data [product]
+             ["e" error #+ Error]
+             [text "text/" Eq<Text>]
+             text/format
+             (coll [list "list/" Functor<List>]))
+       (macro [code]
+              ["s" syntax #+ Syntax]))
+  [///lang])
+
+(exception: #export Invalid-Lux-Version)
+
+(def: (write-type type)
+  (-> Type Code)
+  (case type
+    (#.Primitive name params)
+    (` ("Primitive"
+        (~ (code.text name))
+        (~+ (list/map write-type params))))
+    
+    #.Void
+    (` "Void")
+    
+    #.Unit
+    (` "Unit")
+
+    (^template [<tag> <description>]
+      (<tag> left right)
+      (` (<description> (~ (write-type left)) (~ (write-type right)))))
+    ([#.Sum "Sum"]
+     [#.Product "Product"]
+     [#.Function "Function"]
+     [#.Apply "Apply"])
+    
+    (^template [<tag> <description>]
+      (<tag> id)
+      (` (<description> (~ (code.nat id)))))
+    ([#.Bound "Bound"]
+     [#.Var "Var"]
+     [#.Ex "Ex"])
+
+    (^template [<tag> <description>]
+      (<tag> env body)
+      (` (<description> (~ (code.tuple (list/map write-type env)))
+                        (~ (write-type body)))))
+    ([#.UnivQ "UnivQ"]
+     [#.ExQ "ExQ"])
+    
+    (#.Named name anonymous)
+    (` ("Named" (~ (code.symbol name)) (~ (write-type anonymous))))))
+
+(def: read-type
+  (Syntax Type)
+  (let [tagged (: (All [a] (-> Text (Syntax a) (Syntax a)))
+                  (function [tag syntax]
+                    (s.form (p.after (s.this (code.text tag)) syntax))))
+        binary (: (-> Text (Syntax Type) (Syntax [Type Type]))
+                  (function [tag read-type]
+                    (tagged tag (p.seq read-type read-type))))
+        indexed (: (-> Text (Syntax Nat))
+                   (function [tag]
+                     (tagged tag s.nat)))
+        quantified (: (-> Text (Syntax Type) (Syntax [(List Type) Type]))
+                      (function [tag read-type]
+                        (tagged tag (p.seq (s.tuple (p.some read-type))
+                                           read-type))))]
+    (p.rec
+     (function [read-type]
+       ($_ p.alt
+           (tagged "Primitive" (p.seq s.text (p.some read-type)))
+           (s.this (` "Void"))
+           (s.this (` "Unit"))
+           (binary "Sum" read-type)
+           (binary "Product" read-type)
+           (binary "Function" read-type)
+           (indexed "Bound")
+           (indexed "Var")
+           (indexed "Ex")
+           (quantified "UnivQ" read-type)
+           (quantified "ExQ" read-type)
+           (binary "Apply" read-type)
+           (tagged "Named" (p.seq s.symbol read-type))
+           )))))
+
+(def: (write-definition [type annotations value])
+  (-> Definition Code)
+  (` {"type" (~ (write-type type))
+      "annotations" (~ annotations)}))
+
+(def: read-definition
+  (Syntax Definition)
+  (s.record ($_ p.seq
+                (p.after (s.this (` "type")) read-type)
+                (p.after (s.this (` "annotations")) s.any)
+                (parser/wrap []))))
+
+(def: (write-aliases aliases)
+  (-> (List [Text Text]) Code)
+  (|> aliases (list/map (product.both code.text code.text)) code.record))
+
+(def: read-aliases
+  (Syntax (List [Text Text]))
+  (s.record (p.some (p.seq s.text s.text))))
+
+(def: #export (write lux-file module)
+  (-> Text Module Code)
+  (` {"lux version" (~ (code.text ///lang.version))
+      "lux file" (~ (code.text lux-file))
+      "hash" (~ (code.nat (get@ #.module-hash module)))
+      "aliases" (~ (write-aliases (get@ #.module-aliases module)))
+      "definitions" (~ (code.record (list/map (product.both code.text write-definition)
+                                              (get@ #.definitions module))))
+      "imports" (~ (code.tuple (list/map code.text (get@ #.imports module))))
+      "annotations" (~ (case (get@ #.module-annotations module)
+                         #.None
+                         (' "None")
+
+                         (#.Some annotations)
+                         (` ("Some" (~ annotations)))))
+      }))
+
+(def: #export (read description)
+  (-> Code (Error [Text Module]))
+  (<| (s.run (list description))
+      (s.record (do p.Monad<Parser>
+                  [lux-version (p.after (s.this (` "lux version")) s.text)
+                   _ (p.assert (Invalid-Lux-Version
+                                (format "Expected: " ///lang.version "\n"
+                                        "  Actual: " lux-version "\n"))
+                               (text/= ///lang.version lux-version))]
+                  ($_ p.seq
+                      (p.after (s.this (` "lux file")) s.text)
+                      ($_ p.seq
+                          (p.after (s.this (` "hash")) s.nat)
+                          (p.after (s.this (` "aliases")) read-aliases)
+                          (p.after (s.this (` "definitions")) (s.record (p.some (p.seq s.text read-definition))))
+                          (p.after (s.this (` "imports")) (s.tuple (p.some s.text)))
+                          (parser/wrap (list))
+                          (parser/wrap (list))
+                          (p.after (s.this (` "annotations")) (p.alt (s.this (` "None"))
+                                                                     (s.form (p.after (s.this (` "Some"))
+                                                                                      s.any))))
+                          (parser/wrap #.Cached)))))))
diff --git a/new-luxc/source/luxc/cache/influences.lux b/new-luxc/source/luxc/cache/influences.lux
new file mode 100644
index 000000000..a75e1a7a1
--- /dev/null
+++ b/new-luxc/source/luxc/cache/influences.lux
@@ -0,0 +1,27 @@
+(.module:
+  lux
+  (lux (data [text]
+             (coll [list "list/" Fold<List>]
+                   [dict #+ Dict]))))
+
+(type: #export Influences (Dict Text (List Text)))
+
+(def: #export (track to from)
+  (-> Text Text Influences Influences)
+  (|>> (dict.update~ from (list) (|>> (#.Cons to)))
+       (dict.update~ to (list) id)))
+
+(def: (effluents module influences)
+  (-> Text Influences (Maybe (List Text)))
+  (dict.get module influences))
+
+(def: #export (untrack module influences)
+  (-> Text Influences Influences)
+  (case (effluents module influences)
+    (#.Some effluents)
+    (list/fold untrack (dict.remove module influences) effluents)
+
+    #.None
+    influences))
+
+(def: #export empty Influences (dict.new text.Hash<Text>))
diff --git a/new-luxc/source/luxc/cache/io.lux b/new-luxc/source/luxc/cache/io.lux
new file mode 100644
index 000000000..9f5474c76
--- /dev/null
+++ b/new-luxc/source/luxc/cache/io.lux
@@ -0,0 +1,210 @@
+(.module:
+  lux
+  (lux (control [monad #+ do]
+                ["ex" exception #+ exception:])
+       (data [product]
+             [maybe]
+             ["e" error #+ Error]
+             [bool "bool/" Eq<Bool>]
+             [text "text/" Hash<Text>]
+             text/format
+             (coll [list "list/" Fold<List>]
+                   [dict #+ Dict]
+                   [set #+ Set]))
+       (lang [syntax #+ Aliases])
+       [io #+ Process "process/" Monad<Process>]
+       (concurrency [atom #+ Atom atom])
+       (world [file #+ File]
+              [blob #+ Blob]))
+  [///io]
+  [//description]
+  [//influences]
+  [//])
+
+(exception: #export Invalid-Lux-Version)
+(exception: #export Module-Is-Not-Cached)
+(exception: #export Cannot-Pre-Load-Cache-More-Than-Once)
+(exception: #export Cannot-Delete-Cached-File)
+(exception: #export Cannot-Load-Definition)
+
+(def: cache
+  (Atom //.Cache)
+  (atom //.empty))
+
+(def: #export (load name)
+  (-> Text (Process Module))
+  (do io.Monad<IO>
+    [cache (atom.read cache)]
+    (case (dict.get name cache)
+      (#.Some module)
+      (process/wrap module)
+      
+      #.None
+      (io.throw Module-Is-Not-Cached name))))
+
+(def: #export (cached target-dir)
+  (-> File (Process (List File)))
+  (do io.Monad<Process>
+    [roots (file.files target-dir)
+     root-modules (monad.map @ (: (-> File (Process (List File)))
+                                  (function recur [file]
+                                    (do @
+                                      [is-dir? (file.directory? file)]
+                                      (if is-dir?
+                                        (do @
+                                          [subs (file.files file)
+                                           cached-subs (monad.map @ recur subs)]
+                                          (wrap (list& (maybe.assume (///io.module target-dir file))
+                                                       (list.concat cached-subs))))
+                                        (wrap (list))))))
+                             roots)]
+    (wrap (list.concat root-modules))))
+
+(def: (delete file)
+  (-> File (Process Unit))
+  (do io.Monad<Process>
+    [deleted? (file.delete file)]
+    (if deleted?
+      (wrap [])
+      (io.throw Cannot-Delete-Cached-File file))))
+
+(def: (un-install target-dir module-name)
+  (-> File Text (Process Unit))
+  (do io.Monad<Process>
+    [#let [module-dir (///io.file target-dir module-name)]
+     files (file.files module-dir)
+     can-delete-module-dir? (<| (:: @ map (list.every? (bool/= true)))
+                                (monad.map @ (function [file]
+                                               (do @
+                                                 [? (file.directory? file)]
+                                                 (if ?
+                                                   (wrap false)
+                                                   (do @
+                                                     [_ (delete file)]
+                                                     (wrap true)))))
+                                           files))]
+    (if can-delete-module-dir?
+      (delete module-dir)
+      (wrap []))))
+
+(def: no-aliases Aliases (dict.new text.Hash<Text>))
+
+(def: (source description)
+  (-> Text Source)
+  [["" +1 +0] +0 description])
+
+(def: (load-module source-dirs target-dir module-name)
+  (-> (List File) File Text (Process (List [Text Module])))
+  (do io.Monad<Process>
+    [#let [_ (log! (format "load-module #0: " module-name))]
+     description (file.read (///io.file target-dir (format module-name "/" //.descriptor-name)))
+     #let [_ (log! (format "load-module #1: " module-name))]]
+    (case (do e.Monad<Error>
+            [#let [_ (log! (format "load-module #1 #0: " module-name))]
+             [_ description] (syntax.read "" no-aliases (source (///io.blob-to-text description)))
+             #let [_ (log! (format "load-module #1 #1: " module-name))]]
+            (//description.read description))
+      (#e.Success [lux-file module])
+      (do @
+        [#let [_ (log! (format "load-module #2: " module-name " " lux-file))]
+         [file-name current-source-code] (///io.read source-dirs module-name)
+         #let [_ (log! (format "load-module #3: " module-name " " file-name))]]
+        (if (and (text/= lux-file file-name)
+                 (n/= (get@ #.module-hash module)
+                      (text/hash current-source-code)))
+          (wrap (list [module-name module]))
+          (do @
+            [_ (un-install target-dir module-name)]
+            (wrap (list)))))
+      
+      (#e.Error error)
+      (do @
+        [#let [_ (log! "load-module #2 ERROR")]
+         _ (un-install target-dir module-name)]
+        (wrap (list))))))
+
+(type: Loader (-> Ident Blob (Error Top)))
+
+(def: (install target-dir load-def module-name module)
+  (-> File Loader Text Module (Process Module))
+  (do io.Monad<Process>
+    [definitions (monad.map @ (: (-> [Text Definition] (Process [Text Definition]))
+                                 (function [[def-name [def-type def-annotations _]]]
+                                   (do @
+                                     [def-blob (file.read (///io.file target-dir (format module-name "/" def-name)))
+                                      #let [def-ident [module-name def-name]]]
+                                     (case (load-def def-ident def-blob)
+                                       (#e.Success def-value)
+                                       (wrap [def-name [def-type def-annotations def-value]])
+                                       
+                                       (#e.Error error)
+                                       (io.throw Cannot-Load-Definition
+                                                 (format "Definition: " (%ident def-ident) "\n"
+                                                         "     Error:\n" error "\n"))))))
+                            (get@ #.definitions module))]
+    (wrap (set@ #.definitions definitions module))))
+
+(def: (pre-load' source-dirs target-dir load-def)
+  (-> (List File) File Loader (Process //.Cache))
+  (do io.Monad<Process>
+    [#let [_ (log! "pre-load' #0")]
+     cached (cached target-dir)
+     #let [_ (log! (format "pre-load' #1 " (%list %t cached)))]
+     candidate-cache (|> cached
+                         (monad.map @ (load-module source-dirs target-dir))
+                         (:: @ map (|>> list.concat
+                                        (dict.from-list text.Hash<Text>))))
+     #let [_ (log! "pre-load' #2")]
+     #let [candidate-entries (dict.entries candidate-cache)
+           raw-influences (list/fold (function [[candidate-name candidate-module] influences]
+                                       (list/fold (//influences.track candidate-name)
+                                                  influences
+                                                  (get@ #.imports candidate-module)))
+                                     //influences.empty
+                                     candidate-entries)
+           pruned-influences (list/fold (function [[candidate-name candidate-module] influences]
+                                          (if (list.every? (function [module-name]
+                                                             (dict.contains? module-name candidate-cache))
+                                                           (get@ #.imports candidate-module))
+                                            influences
+                                            (//influences.untrack candidate-name influences)))
+                                        raw-influences
+                                        candidate-entries)
+           valid-cache (list/fold (function [candidate cache]
+                                    (if (dict.contains? candidate pruned-influences)
+                                      cache
+                                      (dict.remove candidate cache)))
+                                  candidate-cache
+                                  (dict.keys candidate-cache))]
+     #let [_ (log! "pre-load' #3")]]
+    (|> (dict.entries valid-cache)
+        (monad.map @ (function [[module-name module]]
+                       (do @
+                         [#let [_ (log! (format " PRE INSTALL: " module-name))]
+                          loaded-module (install target-dir load-def module-name module)
+                          #let [_ (log! (format "POST INSTALL: " module-name))]]
+                         (wrap [module-name loaded-module]))))
+        (:: @ map (dict.from-list text.Hash<Text>)))))
+
+(def: (set-cache cache)
+  (-> //.Cache (Process Unit))
+  (do io.Monad<IO>
+    [swapped? (atom.compare-and-swap //.empty cache ..cache)]
+    (if swapped?
+      (wrap (#e.Success []))
+      (io.throw Cannot-Pre-Load-Cache-More-Than-Once ""))))
+
+(def: #export (pre-load source-dirs target-dir load-def)
+  (-> (List File) File Loader (Process Unit))
+  (do io.Monad<Process>
+    [loaded-cache (pre-load' source-dirs (///io.platform-target target-dir) load-def)]
+    (set-cache loaded-cache)))
+
+(def: #export (clean target-dir wanted-modules)
+  (-> File (Set Text) (Process Unit))
+  (do io.Monad<Process>
+    [cached (cached target-dir)
+     _ (|> cached
+           (list.filter (bool.complement (set.member? wanted-modules)))
+           (monad.map @ (un-install target-dir)))]
+    (wrap [])))