diff options
Diffstat (limited to 'new-luxc/source/luxc/cache')
| -rw-r--r-- | new-luxc/source/luxc/cache/description.lux | 147 | ||||
| -rw-r--r-- | new-luxc/source/luxc/cache/influences.lux | 27 | ||||
| -rw-r--r-- | new-luxc/source/luxc/cache/io.lux | 210 |
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 []))) |