diff options
Diffstat (limited to 'stdlib/source/lux/tool/compiler/meta/cache.lux')
| -rw-r--r-- | stdlib/source/lux/tool/compiler/meta/cache.lux | 181 |
1 files changed, 0 insertions, 181 deletions
diff --git a/stdlib/source/lux/tool/compiler/meta/cache.lux b/stdlib/source/lux/tool/compiler/meta/cache.lux deleted file mode 100644 index 72de6d285..000000000 --- a/stdlib/source/lux/tool/compiler/meta/cache.lux +++ /dev/null @@ -1,181 +0,0 @@ -(.module: - [lux (#- Module) - [control - ["." monad (#+ Monad do)] - ["." try] - ["ex" exception (#+ exception:)] - pipe] - [data - ["." bit ("#@." equivalence)] - ["." maybe] - ["." product] - [number - ["n" nat]] - [format - ["." binary (#+ Format)]] - ["." text - [format (#- Format)]] - [collection - ["." list ("#@." functor fold)] - ["dict" dictionary (#+ Dictionary)] - ["." set (#+ Set)]]] - [world - [file (#+ File System)]]] - ["." // - ["#." io (#+ Context Module) - ["#/." context] - ["#/." 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)])) - -(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 hash source-code)]] - (case (do try.monad - [[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 = - (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])) - (#try.Success [dependency document]) - (wrap (#.Some [dependency document])) - - (#try.Failure 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))))])) - #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)) - 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))) |