diff options
Diffstat (limited to 'stdlib/source/lux/platform/compiler/meta/cache.lux')
| -rw-r--r-- | stdlib/source/lux/platform/compiler/meta/cache.lux | 178 |
1 files changed, 178 insertions, 0 deletions
diff --git a/stdlib/source/lux/platform/compiler/meta/cache.lux b/stdlib/source/lux/platform/compiler/meta/cache.lux new file mode 100644 index 000000000..bcb7c98f0 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/meta/cache.lux @@ -0,0 +1,178 @@ +(.module: + [lux (#- Module) + [control + ["." monad (#+ Monad do)] + ["ex" exception (#+ exception:)] + pipe] + [data + ["." bit ("bit/." Equivalence<Bit>)] + ["." maybe] + ["." error] + ["." product] + [format + ["." binary (#+ Format)]] + ["." text + [format (#- Format)]] + [collection + ["." list ("list/." Functor<List> Fold<List>)] + ["dict" dictionary (#+ Dictionary)] + ["." set (#+ Set)]]] + [world + [file (#+ File System)]]] + [// + [io (#+ Context Module) + ["io/." context] + ["io/." archive]] + ["." archive (#+ Signature Key Descriptor Document Archive)] + ["/." //]] + ["." /dependency (#+ Dependency Graph)]) + +(exception: #export (cannot-delete-file {file File}) + (ex.report ["File" file])) + +(exception: #export (stale-document {module ///.Module} {current-hash Nat} {stale-hash Nat}) + (ex.report ["Module" module] + ["Current hash" (%n current-hash)] + ["Stale hash" (%n stale-hash)])) + +(exception: #export (mismatched-signature {module ///.Module} {expected Signature} {actual Signature}) + (ex.report ["Module" module] + ["Expected" (archive.describe expected)] + ["Actual" (archive.describe actual)])) + +(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-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 #0) + (do @ + [_ (..delete System<m> file)] + (wrap #1))))))] + [(list.every? (bit/= #1)) + (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 (bit.complement (set.member? wanted-modules))) + (monad.map @ (un-install System<m> root))]))) + +## Load +(def: signature + (Format Signature) + ($_ binary.and binary.name binary.text)) + +(def: descriptor + (Format Descriptor) + ($_ binary.and binary.nat binary.text (binary.list binary.text) (binary.ignore #.Cached))) + +(def: document + (All [a] (-> (Format a) (Format [Signature Descriptor a]))) + (|>> ($_ binary.and ..signature ..descriptor))) + +(def: (load-document System<m> contexts root key binary module) + (All [m d] (-> (System m) (List File) File (Key d) (Format 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 descriptor content] (binary.read (..document binary) document') + #let [[document-hash _file references _state] descriptor] + _ (ex.assert mismatched-signature [module (get@ #archive.signature key) signature] + (:: archive.Equivalence<Signature> = + (get@ #archive.signature key) + signature)) + _ (ex.assert stale-document [module current-hash document-hash] + (n/= current-hash document-hash)) + document (archive.write key signature descriptor content)] + (wrap [[module references] 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) (Format 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 references] document]) + (dict.put module [references document] archive) + + #.None + archive)) + (: (Dictionary 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))) |