diff options
| -rw-r--r-- | new-luxc/source/luxc/cache.lux | 9 | ||||
| -rw-r--r-- | new-luxc/source/luxc/cache/influences.lux | 27 | ||||
| -rw-r--r-- | new-luxc/source/luxc/cache/io.lux | 214 | ||||
| -rw-r--r-- | stdlib/source/lux/control/exception.lux | 6 | ||||
| -rw-r--r-- | stdlib/source/lux/data/format/binary.lux | 119 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/meta/archive.lux | 49 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/meta/cache.lux | 163 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/meta/cache/dependency.lux | 51 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/meta/io.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/meta/io/context.lux | 10 | ||||
| -rw-r--r-- | stdlib/source/lux/world/file.lux | 5 |
11 files changed, 355 insertions, 300 deletions
diff --git a/new-luxc/source/luxc/cache.lux b/new-luxc/source/luxc/cache.lux deleted file mode 100644 index 8be91fb35..000000000 --- a/new-luxc/source/luxc/cache.lux +++ /dev/null @@ -1,9 +0,0 @@ -(.module: - lux - (lux (data [text] - (coll (dictionary ["dict" unordered #+ Dict]))))) - -(type: #export Cache (Dict Text Module)) -(def: #export empty Cache (dict.new text.Hash<Text>)) - -(def: #export descriptor-name Text "lux_module_descriptor") diff --git a/new-luxc/source/luxc/cache/influences.lux b/new-luxc/source/luxc/cache/influences.lux deleted file mode 100644 index bbddd79aa..000000000 --- a/new-luxc/source/luxc/cache/influences.lux +++ /dev/null @@ -1,27 +0,0 @@ -(.module: - lux - (lux (data [text] - (coll [list "list/" Fold<List>] - (dictionary ["dict" unordered #+ 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 deleted file mode 100644 index 2d1f373d5..000000000 --- a/new-luxc/source/luxc/cache/io.lux +++ /dev/null @@ -1,214 +0,0 @@ -(.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>] - (dictionary ["dict" unordered #+ Dict]) - (set ["set" unordered #+ Set]))) - (lang [syntax #+ Aliases]) - [io #+ Process "process/" Monad<Process>] - (concurrency [atom #+ Atom atom]) - (world [file #+ File] - [blob #+ Blob])) - [///io] - [//description] - [//influences] - [//]) - -(do-template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [Module-Is-Not-Cached] - [Cannot-Pre-Load-Cache-More-Than-Once] - [Cannot-Delete-Cached-File] - [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 Any)) - (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 Any)) - (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 Any))) - -(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 Any)) - (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 Any)) - (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 Any)) - (do io.Monad<Process> - [cached (cached target-dir) - _ (|> cached - (list.filter (bool.complement (set.member? wanted-modules))) - (monad.map @ (un-install target-dir)))] - (wrap []))) 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) |