aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/cache
diff options
context:
space:
mode:
authorEduardo Julian2017-12-05 22:55:11 -0400
committerEduardo Julian2017-12-05 22:55:11 -0400
commit2e86fefe6f15877e8c46a45411a9cbd04b26e2e3 (patch)
treec95f8c1391b907a3e9076f4eadb831aa274cfbea /new-luxc/source/luxc/cache
parent0b87f118978e9971828d2c9ccabe685b0c5e4c35 (diff)
- WIP: Caching.
Diffstat (limited to 'new-luxc/source/luxc/cache')
-rw-r--r--new-luxc/source/luxc/cache/description.lux147
-rw-r--r--new-luxc/source/luxc/cache/influences.lux27
-rw-r--r--new-luxc/source/luxc/cache/io.lux210
3 files changed, 384 insertions, 0 deletions
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 [])))