- Ported caching machinery for Lux Meta-Compiler to stdlib.

8 files changed, 355 insertions, 50 deletions

diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux
index 2ca06defa..80ddeed35 100644
--- a/stdlib/source/lux/control/exception.lux
+++ b/stdlib/source/lux/control/exception.lux
@@ -71,6 +71,12 @@
   (All [e] (-> (Exception e) e Error))
   (#/.Error (construct exception message)))
 
+(def: #export (assert exception message test)
+  (All [e] (-> (Exception e) e Bool (Error Any)))
+  (if test
+    (#/.Success [])
+    (..throw exception message)))
+
 (syntax: #export (exception: {export csr.export}
                    {t-vars (p.default (list) csr.type-variables)}
                    {[name inputs] (p.either (p.seq s.local-symbol (wrap (list)))
diff --git a/stdlib/source/lux/data/format/binary.lux b/stdlib/source/lux/data/format/binary.lux
index cabdf7091..040ae5e8b 100644
--- a/stdlib/source/lux/data/format/binary.lux
+++ b/stdlib/source/lux/data/format/binary.lux
@@ -1,5 +1,5 @@
 (.module:
-  [lux #- nat int rev]
+  [lux #- nat int rev list]
   (lux (control [monad #+ do Monad]
                 ["p" parser]
                 ["ex" exception #+ exception:])
@@ -14,8 +14,9 @@
   (ex.report ["Blob length" (%n length)]
              ["Read bytes" (%n read)]))
 
-(exception: #export (invalid-bool {byte Nat})
-  (%n byte))
+(exception: #export (invalid-tag {range Nat} {byte Nat})
+  (ex.report ["Range" (%n range)]
+             ["Byte" (%n byte)]))
 
 ## Types
 (type: #export Offset Nat)
@@ -33,13 +34,13 @@
 (type: #export (Write a)
   (-> a [Size (-> Offset Blob Blob)]))
 
-(type: #export (Format a)
+(type: #export (Binary a)
   {#read (Read a)
    #write (Write a)})
 
 ## Operators
 (def: #export (read format input)
-  (All [a] (-> (Format a) Blob (error.Error a)))
+  (All [a] (-> (Binary a) Blob (error.Error a)))
   (case ((get@ #read format) [+0 input])
     (#error.Error msg)
     (#error.Error msg)
@@ -51,26 +52,14 @@
         (ex.throw blob-was-not-fully-read [length end])))))
 
 (def: #export (write format value)
-  (All [a] (-> (Format a) a Blob))
+  (All [a] (-> (Binary a) a Blob))
   (let [[valueS valueT] ((get@ #write format) value)]
     (|> valueS blob.create (valueT +0))))
 
-## Combinators
-(def: #export (seq preF postF)
-  (All [a b] (-> (Format a) (Format b) (Format [a b])))
-  {#read (p.seq (get@ #read preF) (get@ #read postF))
-   #write (function (_ [preV postV])
-            (let [[preS preT] ((get@ #write preF) preV)
-                  [postS postT] ((get@ #write postF) postV)]
-              [(n/+ preS postS)
-               (function (_ offset)
-                 (|>> (preT offset)
-                      (postT (n/+ preS offset))))]))})
-
 ## Primitives
 (do-template [<name> <size> <read> <write>]
   [(def: <name>
-     (Format (I64 Any))
+     (Binary (I64 Any))
      {#read (function (_ [offset blob])
               (case (<read> offset blob)
                 (#error.Success data)
@@ -81,7 +70,9 @@
       #write (function (_ value)
                [<size>
                 (function (_ offset blob)
-                  (error.assume (<write> offset value blob)))])})]
+                  (|> blob
+                      (<write> offset value)
+                      error.assume))])})]
 
   [bits/8  size/8 blob.read/8  blob.write/8]
   [bits/16 size/16 blob.read/16 blob.write/16]
@@ -89,9 +80,68 @@
   [bits/64 size/64 blob.read/64 blob.write/64]
   )
 
+## Combinators
+(def: #export (alt leftB rightB)
+  (All [l r] (-> (Binary l) (Binary r) (Binary (| l r))))
+  {#read (do p.Monad<Parser>
+           [flag (get@ #read bits/8)]
+           (case flag
+             +0 (:: @ map (|>> #.Left) (get@ #read leftB))
+             +1 (:: @ map (|>> #.Right) (get@ #read rightB))
+             _ (p.lift (ex.throw invalid-tag [+2 (.nat flag)]))))
+   #write (function (_ altV)
+            (case altV
+              (#.Left leftV)
+              (let [[leftS leftT] ((get@ #write leftB) leftV)]
+                [(.inc leftS)
+                 (function (_ offset blob)
+                   (|> blob
+                       (blob.write/8 offset +0)
+                       error.assume
+                       (leftT (.inc offset))))])
+              
+              (#.Right rightV)
+              (let [[rightS rightT] ((get@ #write rightB) rightV)]
+                [(.inc rightS)
+                 (function (_ offset blob)
+                   (|> blob
+                       (blob.write/8 offset +1)
+                       error.assume
+                       (rightT (.inc offset))))])
+              ))})
+
+(def: #export (seq preB postB)
+  (All [a b] (-> (Binary a) (Binary b) (Binary [a b])))
+  {#read (p.seq (get@ #read preB) (get@ #read postB))
+   #write (function (_ [preV postV])
+            (let [[preS preT] ((get@ #write preB) preV)
+                  [postS postT] ((get@ #write postB) postV)]
+              [(n/+ preS postS)
+               (function (_ offset)
+                 (|>> (preT offset)
+                      (postT (n/+ preS offset))))]))})
+
+(def: #export (rec body)
+  (All [a] (-> (-> (Binary a) (Binary a)) (Binary a)))
+  {#read (function (_ input)
+           (let [read (get@ #read (body (rec body)))]
+             (read input)))
+   #write (function (_ value)
+            (let [write (get@ #write (body (rec body)))]
+              (write value)))})
+
 ## Utilities
+(def: #export unit
+  (Binary Any)
+  {#read (function (_ input)
+           (#error.Success [input []]))
+   #write (function (_ value)
+            [+0
+             (function (_ offset blob)
+               blob)])})
+
 (def: #export bool
-  (Format Bool)
+  (Binary Bool)
   {#read (function (_ [offset blob])
            (case (blob.read/8 offset blob)
              (#error.Success data)
@@ -102,29 +152,29 @@
                 [+1 true])
                
                _
-               (ex.throw invalid-bool data))
+               (ex.throw invalid-tag [+2 data]))
              
              (#error.Error error)
              (#error.Error error)))
    #write (function (_ value)
             [+1
              (function (_ offset blob)
-               (exec (error.assume (blob.write/8 offset (if value +1 +0) blob))
-                 blob))])}
-  )
+               (|> blob
+                   (blob.write/8 offset (if value +1 +0))
+                   error.assume))])})
 
-(def: #export nat (Format Nat) (:assume ..bits/64))
-(def: #export int (Format Int) (:assume ..bits/64))
-(def: #export rev (Format Rev) (:assume ..bits/64))
+(def: #export nat (Binary Nat) (:assume ..bits/64))
+(def: #export int (Binary Int) (:assume ..bits/64))
+(def: #export rev (Binary Rev) (:assume ..bits/64))
 
 (def: #export frac
-  (Format Frac)
+  (Binary Frac)
   (let [(^slots [#read #write]) ..bits/64]
     {#read (:: p.Monad<Parser> map number.bits-to-frac read)
      #write (|>> number.frac-to-bits write)}))
 
 (def: #export blob
-  (Format Blob)
+  (Binary Blob)
   {#read (do p.Monad<Parser>
            [size (get@ #read nat)]
            (function (_ [offset blob])
@@ -142,9 +192,16 @@
                     (blob.copy size +0 value (n/+ size/64 offset) blob))))]))})
 
 (def: #export text
-  (Format Text)
+  (Binary Text)
   (let [(^slots [#read #write]) ..blob]
     {#read (do p.Monad<Parser>
              [utf8 read]
              (p.lift (encoding.from-utf8 utf8)))
      #write (|>> encoding.to-utf8 write)}))
+
+(def: #export (list value)
+  (All [a] (-> (Binary a) (Binary (List a))))
+  (..rec
+   (function (_ recur)
+     (..alt ..unit
+            (..seq value recur)))))
diff --git a/stdlib/source/lux/lang/compiler/meta/archive.lux b/stdlib/source/lux/lang/compiler/meta/archive.lux
index f61476111..371164ee4 100644
--- a/stdlib/source/lux/lang/compiler/meta/archive.lux
+++ b/stdlib/source/lux/lang/compiler/meta/archive.lux
@@ -13,41 +13,54 @@
   [////])
 
 ## Key
+(type: #export Signature
+  {#name Ident
+   #version Text})
+
+(def: Equivalence<Signature>
+  (Equivalence Signature)
+  (equivalence.product ident.Equivalence<Ident> text.Equivalence<Text>))
+
+(def: (describe signature)
+  (-> Signature Text)
+  (format (%ident (get@ #name signature)) " " (get@ #version signature)))
+
 (abstract: #export (Key k)
   {}
 
-  {#name Ident
-   #version Text}
+  Signature
 
-  (def: Equivalence<Key>'
-    (equivalence.product ident.Equivalence<Ident> text.Equivalence<Text>))
-  
   (struct: #export Equivalence<Key>
     (All [k] (Equivalence (Key k)))
     (def: (= reference sample)
-      (:: Equivalence<Key>' = (:representation reference) (:representation sample))))
+      (:: Equivalence<Signature> = (:representation reference) (:representation sample))))
 
   (def: #export default
     (Key Nothing)
     (:abstraction {#name ["" ""]
                    #version ////.version}))
 
-  (def: (describe (^:representation key))
-    (-> (Key Any) Text)
-    (format (%ident (get@ #name key)) " " (get@ #version key)))
+  (def: #export signature
+    (-> (Key Any) Signature)
+    (|>> :representation))
   )
 
 ## Document
 (exception: #export (invalid-key-for-document {expected (Key Any)} {actual (Key Any)})
-  (ex.report ["Expected" (describe expected)]
-             ["Actual" (describe actual)]))
+  (ex.report ["Expected" (describe (..signature expected))]
+             ["Actual" (describe (..signature actual))]))
+
+(exception: #export (signature-does-not-match-key {key (Key Any)} {signature Signature})
+  (ex.report ["Key" (describe (..signature key))]
+             ["Signature" (describe signature)]))
 
 (type: #export (Document d)
   {#key (Key d)
+   #hash Nat
    #value d})
 
 (def: #export (open expected [actual value])
-  (All [e] (-> (Key e) (Document Any) (Error e)))
+  (All [d] (-> (Key d) (Document Any) (Error d)))
   (if (:: Equivalence<Key> = expected actual)
     (#error.Success (:share [e]
                             {(Key e)
@@ -56,11 +69,19 @@
                              value}))
     (ex.throw invalid-key-for-document [expected actual])))
 
+(def: #export (close key signature hash value)
+  (All [d] (-> (Key d) Signature Nat d (Error (Document d))))
+  (if (:: Equivalence<Signature> = (..signature key) signature)
+    (#error.Success {#key key
+                     #hash hash
+                     #value value})
+    (ex.throw signature-does-not-match-key [key signature])))
+
 ## Archive
 (exception: #export (cannot-replace-document-in-archive {name Text} {old (Document Any)} {new (Document Any)})
   (ex.report ["Module's name" name]
-             ["Old document's key" (describe (get@ #key old))]
-             ["New document's key" (describe (get@ #key new))]))
+             ["Old document's key" (describe (..signature (get@ #key old)))]
+             ["New document's key" (describe (..signature (get@ #key new)))]))
 
 (type: #export Archive
   (Dict Text (Ex [d] (Document d))))
diff --git a/stdlib/source/lux/lang/compiler/meta/cache.lux b/stdlib/source/lux/lang/compiler/meta/cache.lux
new file mode 100644
index 000000000..153679ef0
--- /dev/null
+++ b/stdlib/source/lux/lang/compiler/meta/cache.lux
@@ -0,0 +1,163 @@
+(.module:
+  [lux #- Module]
+  (lux (control [monad #+ Monad do]
+                ["ex" exception #+ exception:]
+                pipe)
+       (data [bool "bool/" Equivalence<Bool>]
+             [maybe]
+             [error]
+             [product]
+             (format [binary #+ Binary])
+             [text]
+             text/format
+             (coll [list "list/" Functor<List> Fold<List>]
+                   (dictionary ["dict" unordered #+ Dict])
+                   (set ["set" unordered #+ Set])))
+       (world [file #+ File System]))
+  [//io #+ Context Module]
+  [//io/context]
+  [//io/archive]
+  [//archive #+ Signature Key Document Archive]
+  [/dependency #+ Dependency Graph])
+
+(exception: #export (cannot-delete-cached-file {file File})
+  (ex.report ["File" file]))
+
+(exception: #export (stale-document {module Text} {current-hash Nat} {stale-hash Nat})
+  (ex.report ["Module" module]
+             ["Current hash" (%n current-hash)]
+             ["Stale hash" (%n stale-hash)]))
+
+(do-template [<name>]
+  [(exception: #export (<name> {message Text})
+     message)]
+
+  [cannot-load-definition]
+  )
+
+## General
+(def: #export (cached System<m> root)
+  (All [m] (-> (System m) File (m (List File))))
+  (|> root
+      (//io/archive.archive System<m>)
+      (do> (:: System<m> &monad)
+           [(:: System<m> files)]
+           [(monad.map @ (function (recur file)
+                           (do @
+                             [is-dir? (:: System<m> directory? file)]
+                             (if is-dir?
+                               (|> file
+                                   (do> @
+                                        [(:: System<m> files)]
+                                        [(monad.map @ recur)]
+                                        [list.concat
+                                         (list& (maybe.assume (//io/archive.module System<m> root file)))
+                                         wrap]))
+                               (wrap (list))))))]
+           [list.concat wrap])))
+
+## Clean
+(def: (delete System<m> document)
+  (All [m] (-> (System m) File (m Any)))
+  (do (:: System<m> &monad)
+    [deleted? (:: System<m> delete document)]
+    (if deleted?
+      (wrap [])
+      (:: System<m> throw cannot-delete-cached-file document))))
+
+(def: (un-install System<m> root module)
+  (All [m] (-> (System m) File Module (m Any)))
+  (let [document (//io/archive.document System<m> root module)]
+    (|> document
+        (do> (:: System<m> &monad)
+             [(:: System<m> files)]
+             [(monad.map @ (function (_ file)
+                             (do @
+                               [? (:: System<m> directory? file)]
+                               (if ?
+                                 (wrap false)
+                                 (do @
+                                   [_ (..delete System<m> file)]
+                                   (wrap true))))))]
+             [(list.every? (bool/= true))
+              (if> [(..delete System<m> document)]
+                   [(wrap [])])]))))
+
+(def: #export (clean System<m> root wanted-modules)
+  (All [m] (-> (System m) File (Set Module) (m Any)))
+  (|> root
+      (do> (:: System<m> &monad)
+           [(..cached System<m>)]
+           [(list.filter (bool.complement (set.member? wanted-modules)))
+            (monad.map @ (un-install System<m> root))])))
+
+## Load
+(def: signature
+  (Binary Signature)
+  (let [name (binary.seq binary.text binary.text)
+        version binary.text]
+    (binary.seq name version)))
+
+(def: imports
+  (Binary (List Module))
+  (binary.list binary.text))
+
+(def: document
+  (All [a] (-> (Binary a) (Binary [Signature Nat (List Module) a])))
+  (|>> ($_ binary.seq ..signature binary.nat ..imports)))
+
+(def: (load-document System<m> contexts root key binary module)
+  (All [m d] (-> (System m) (List File) File (Key d) (Binary d) Module
+                 (m (Maybe [Dependency (Document d)]))))
+  (do (:: System<m> &monad)
+    [document' (:: System<m> read (//io/archive.document System<m> root module))
+     [module' source-code] (//io/context.read System<m> contexts module)
+     #let [current-hash (:: text.Hash<Text> hash source-code)]]
+    (case (do error.Monad<Error>
+            [[signature document-hash imports content] (binary.read (..document binary) document')
+             _ (ex.assert stale-document [module current-hash document-hash]
+                          (n/= current-hash document-hash))
+             document (//archive.close key signature document-hash content)]
+            (wrap [[module imports] document]))
+      (#error.Success [dependency document])
+      (wrap (#.Some [dependency document]))
+      
+      (#error.Error error)
+      (do @
+        [_ (un-install System<m> root module)]
+        (wrap #.None)))))
+
+(def: #export (load-archive System<m> contexts root key binary)
+  (All [m d] (-> (System m) (List Context) File (Key d) (Binary d) (m Archive)))
+  (do (:: System<m> &monad)
+    [candidate (|> root
+                   (do> @
+                        [(..cached System<m>)]
+                        [(monad.map @ (load-document System<m> contexts root key binary))
+                         (:: @ map (list/fold (function (_ full-document archive)
+                                                (case full-document
+                                                  (#.Some [[module imports] document])
+                                                  (dict.put module [imports document] archive)
+                                                  
+                                                  #.None
+                                                  archive))
+                                              (: (Dict Text [(List Module) (Ex [d] (Document d))])
+                                                 (dict.new text.Hash<Text>))))]))
+     #let [candidate-entries (dict.entries candidate)
+           candidate-dependencies (list/map (product.both id product.left)
+                                            candidate-entries)
+           candidate-archive (|> candidate-entries
+                                 (list/map (product.both id product.right))
+                                 (dict.from-list text.Hash<Text>))
+           graph (|> candidate
+                     dict.entries
+                     (list/map (product.both id product.left))
+                     /dependency.graph
+                     (/dependency.prune candidate-archive))
+           archive (list/fold (function (_ module archive)
+                                (if (dict.contains? module graph)
+                                  archive
+                                  (dict.remove module archive)))
+                              candidate-archive
+                              (dict.keys candidate))]]
+    (wrap archive)))
diff --git a/stdlib/source/lux/lang/compiler/meta/cache/dependency.lux b/stdlib/source/lux/lang/compiler/meta/cache/dependency.lux
new file mode 100644
index 000000000..28fcfccc8
--- /dev/null
+++ b/stdlib/source/lux/lang/compiler/meta/cache/dependency.lux
@@ -0,0 +1,51 @@
+(.module:
+  [lux #- Module]
+  (lux (data [text]
+             (coll [list "list/" Functor<List> Fold<List>]
+                   (dictionary ["dict" unordered #+ Dict]))))
+  [///io #+ Module]
+  [///archive #+ Archive])
+
+(type: #export Graph (Dict Module (List Module)))
+
+(def: #export empty Graph (dict.new text.Hash<Text>))
+
+(def: #export (add to from)
+  (-> Module Module Graph Graph)
+  (|>> (dict.update~ from (list) (|>> (#.Cons to)))
+       (dict.update~ to (list) id)))
+
+(def: dependents
+  (-> Module Graph (Maybe (List Text)))
+  dict.get)
+
+(def: #export (remove module dependency)
+  (-> Module Graph Graph)
+  (case (dependents module dependency)
+    (#.Some dependents)
+    (list/fold remove (dict.remove module dependency) dependents)
+
+    #.None
+    dependency))
+
+(type: #export Dependency
+  {#module Module
+   #imports (List Module)})
+
+(def: #export (dependency [module imports])
+  (-> Dependency Graph)
+  (list/fold (..add module) ..empty imports))
+
+(def: #export graph
+  (-> (List Dependency) Graph)
+  (|>> (list/map ..dependency)
+       (list/fold dict.merge empty)))
+
+(def: #export (prune archive graph)
+  (-> Archive Graph Graph)
+  (list/fold (function (_ module graph)
+               (if (dict.contains? module archive)
+                 graph
+                 (..remove module graph)))
+             graph
+             (dict.keys graph)))
diff --git a/stdlib/source/lux/lang/compiler/meta/io.lux b/stdlib/source/lux/lang/compiler/meta/io.lux
index 6be4605f2..e440c16f9 100644
--- a/stdlib/source/lux/lang/compiler/meta/io.lux
+++ b/stdlib/source/lux/lang/compiler/meta/io.lux
@@ -9,6 +9,8 @@
        (world [file #+ File System]
               [blob #+ Blob])))
 
+(type: #export Context File)
+
 (type: #export Module Text)
 
 (def: #export (sanitize system)
diff --git a/stdlib/source/lux/lang/compiler/meta/io/context.lux b/stdlib/source/lux/lang/compiler/meta/io/context.lux
index d03dcbdd8..327f52cf5 100644
--- a/stdlib/source/lux/lang/compiler/meta/io/context.lux
+++ b/stdlib/source/lux/lang/compiler/meta/io/context.lux
@@ -1,5 +1,5 @@
 (.module:
-  [lux #- Module]
+  [lux #- Module Code]
   (lux (control monad
                 ["ex" exception #+ Exception exception:])
        (data [error]
@@ -8,9 +8,7 @@
        (world [file #+ File System]
               [blob #+ Blob]))
   [/////host]
-  [// #+ Module])
-
-(type: #export Context File)
+  [// #+ Context Module])
 
 (type: #export Extension Text)
 
@@ -72,8 +70,10 @@
         #.None
         (try System<m> computations' exception message)))))
 
+(type: #export Code Text)
+
 (def: #export (read System<m> contexts name)
-  (All [m] (-> (System m) (List Context) Module (m [Module Text])))
+  (All [m] (-> (System m) (List Context) Module (m [Text Code])))
   (let [find-source' (find-source System<m> contexts name)]
     (do (:: System<m> &monad)
       [[path file] (try System<m>
diff --git a/stdlib/source/lux/world/file.lux b/stdlib/source/lux/world/file.lux
index 21f5c1d3c..24c38024c 100644
--- a/stdlib/source/lux/world/file.lux
+++ b/stdlib/source/lux/world/file.lux
@@ -29,6 +29,9 @@
 
   (: (All [a] (-> (m a) (m (Error a))))
      try)
+
+  (: (All [a] (-> (Error a) (m a)))
+     lift)
   
   (do-template [<name>]
     [(: (-> Blob File (m Any))
@@ -136,6 +139,8 @@
                      (do io.Monad<IO>
                        [outcome computation]
                        (:: io.Monad<Process> wrap outcome)))
+
+                   (def: lift (:: io.Monad<IO> wrap))
                    
                    (do-template [<name> <flag>]
                      [(def: (<name> data file)