diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/tool/compiler/meta/archive.lux | 165 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/meta/cache/dependency.lux | 136 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/meta/io/archive.lux | 28 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/meta/io/context.lux | 9 |
4 files changed, 215 insertions, 123 deletions
diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux index 2f84ad4dd..f95d713a4 100644 --- a/stdlib/source/lux/tool/compiler/meta/archive.lux +++ b/stdlib/source/lux/tool/compiler/meta/archive.lux @@ -68,70 +68,76 @@ (abstract: #export Archive {} - (Dictionary Module [ID (Maybe [Descriptor (Document Any)])]) + {#next ID + #resolver (Dictionary Module [ID (Maybe [Descriptor (Document Any)])])} (def: next (-> Archive ID) - (|>> :representation dictionary.size)) + (|>> :representation (get@ #next))) (def: #export empty Archive - (:abstraction (dictionary.new text.hash))) + (:abstraction {#next 0 + #resolver (dictionary.new text.hash)})) (def: #export (id module archive) (-> Module Archive (Try ID)) - (case (dictionary.get module (:representation archive)) - (#.Some [id _]) - (#try.Success id) - - #.None - (exception.throw ..unknown-document [module - (dictionary.keys (:representation archive))]))) + (let [(^slots [#..resolver]) (:representation archive)] + (case (dictionary.get module resolver) + (#.Some [id _]) + (#try.Success id) + + #.None + (exception.throw ..unknown-document [module + (dictionary.keys resolver)])))) (def: #export (reserve module archive) (-> Module Archive (Try [ID Archive])) - (case (dictionary.get module (:representation archive)) - (#.Some _) - (exception.throw ..module-has-already-been-reserved [module]) - - #.None - (let [id (..next archive)] - (#try.Success [id + (let [(^slots [#..next #..resolver]) (:representation archive)] + (case (dictionary.get module resolver) + (#.Some _) + (exception.throw ..module-has-already-been-reserved [module]) + + #.None + (#try.Success [next (|> archive :representation - (dictionary.put module [id #.None]) + (update@ #..resolver (dictionary.put module [next #.None])) + (update@ #..next inc) :abstraction)])))) (def: #export (add module [descriptor document] archive) (-> Module [Descriptor (Document Any)] Archive (Try Archive)) - (case (dictionary.get module (:representation archive)) - (#.Some [id #.None]) - (#try.Success (|> archive - :representation - (dictionary.put module [id (#.Some [descriptor document])]) - :abstraction)) - - (#.Some [id (#.Some [existing-descriptor existing-document])]) - (if (is? document existing-document) - ## TODO: Find out why this code allows for the same module to be added more than once. It looks fishy... - (#try.Success archive) - (exception.throw ..cannot-replace-document [module existing-document document])) - - #.None - (exception.throw ..module-must-be-reserved-before-it-can-be-added [module]))) + (let [(^slots [#..resolver]) (:representation archive)] + (case (dictionary.get module resolver) + (#.Some [id #.None]) + (#try.Success (|> archive + :representation + (update@ #..resolver (dictionary.put module [id (#.Some [descriptor document])])) + :abstraction)) + + (#.Some [id (#.Some [existing-descriptor existing-document])]) + (if (is? document existing-document) + ## TODO: Find out why this code allows for the same module to be added more than once. It looks fishy... + (#try.Success archive) + (exception.throw ..cannot-replace-document [module existing-document document])) + + #.None + (exception.throw ..module-must-be-reserved-before-it-can-be-added [module])))) (def: #export (find module archive) (-> Module Archive (Try [Descriptor (Document Any)])) - (case (dictionary.get module (:representation archive)) - (#.Some [id (#.Some document)]) - (#try.Success document) + (let [(^slots [#..resolver]) (:representation archive)] + (case (dictionary.get module resolver) + (#.Some [id (#.Some document)]) + (#try.Success document) - (#.Some [id #.None]) - (exception.throw ..module-is-only-reserved [module]) - - #.None - (exception.throw ..unknown-document [module - (dictionary.keys (:representation archive))]))) + (#.Some [id #.None]) + (exception.throw ..module-is-only-reserved [module]) + + #.None + (exception.throw ..unknown-document [module + (dictionary.keys resolver)])))) (def: #export (archived? archive module) (-> Archive Module Bit) @@ -145,6 +151,7 @@ (def: #export archived (-> Archive (List Module)) (|>> :representation + (get@ #resolver) dictionary.entries (list.search-all (function (_ [module [id descriptor+document]]) (case descriptor+document @@ -154,54 +161,63 @@ (def: #export reserved (-> Archive (List Module)) (|>> :representation + (get@ #resolver) dictionary.keys)) (def: #export reservations (-> Archive (List [Module ID])) (|>> :representation + (get@ #resolver) dictionary.entries (list@map (function (_ [module [id _]]) [module id])))) (def: #export (merge additions archive) (-> Archive Archive (Try Archive)) - (monad.fold try.monad - (function (_ [module' [id descriptor+document']] archive') - (case descriptor+document' - (#.Some descriptor+document') - (if (archived? archive' module') - (#try.Success archive') - (..add module' descriptor+document' archive')) - - #.None - (#try.Success archive'))) - archive - (dictionary.entries (:representation additions)))) + (|> additions + :representation + (get@ #resolver) + dictionary.entries + (monad.fold try.monad + (function (_ [module' [id descriptor+document']] archive') + (case descriptor+document' + (#.Some descriptor+document') + (if (archived? archive' module') + (#try.Success archive') + (..add module' descriptor+document' archive')) + + #.None + (#try.Success archive'))) + archive))) (type: Reservation [Module ID]) - (type: Frozen [Version (List Reservation)]) + (type: Frozen [Version ID (List Reservation)]) (def: reader (Parser ..Frozen) - (<>.and <b>.text - (<b>.list (<>.and <b>.text <b>.nat)))) + ($_ <>.and + <b>.text + <b>.nat + (<b>.list (<>.and <b>.text <b>.nat)))) (def: writer (Writer ..Frozen) - (binary.and binary.text - (binary.list (binary.and binary.text binary.nat)))) + ($_ binary.and + binary.text + binary.nat + (binary.list (binary.and binary.text binary.nat)))) (def: #export (export version archive) (-> Version Archive Binary) - (|> archive - :representation - dictionary.entries - (list.search-all (function (_ [module [id descriptor+document]]) - (case descriptor+document - (#.Some _) (#.Some [module id]) - #.None #.None))) - [version] - (binary.run ..writer))) + (let [(^slots [#..next #..resolver]) (:representation archive)] + (|> resolver + dictionary.entries + (list.search-all (function (_ [module [id descriptor+document]]) + (case descriptor+document + (#.Some _) (#.Some [module id]) + #.None #.None))) + [version next] + (binary.run ..writer)))) (exception: #export (version-mismatch {expected Version} {actual Version}) (exception.report @@ -234,14 +250,15 @@ (def: #export (import expected binary) (-> Version Binary (Try Archive)) (do try.monad - [[actual reservations] (<b>.run ..reader binary) + [[actual next reservations] (<b>.run ..reader binary) _ (exception.assert ..version-mismatch [expected actual] (text@= expected actual)) _ (exception.assert ..corrupt-data [] (correct-reservations? reservations))] - (wrap (|> reservations - (list@fold (function (_ [module id] archive) - (dictionary.put module [id #.None] archive)) - (:representation ..empty)) - :abstraction)))) + (wrap (:abstraction + {#next next + #resolver (list@fold (function (_ [module id] archive) + (dictionary.put module [id #.None] archive)) + (get@ #resolver (:representation ..empty)) + reservations)})))) ) diff --git a/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux b/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux index bb3736518..5a4dcef72 100644 --- a/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux +++ b/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux @@ -1,56 +1,116 @@ (.module: [lux (#- Module) + [abstract + ["." monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." function]] [data - ["." text] + ["." maybe ("#@." functor)] + ["." text + ["%" format (#+ format)]] [collection ["." list ("#@." functor fold)] - ["." dictionary (#+ Dictionary)]]]] - [///io (#+ Module)] - [///archive (#+ Archive)]) + ["." dictionary (#+ Dictionary)] + ["." set (#+ Set)]]]] + [/// + ["." archive (#+ Archive) + [key (#+ Key)] + ["." descriptor (#+ Module Descriptor)] + ["." document (#+ Document)]]]) + +(type: Ancestry + (Set Module)) + +(def: fresh + Ancestry + (set.new text.hash)) (type: #export Graph - (Dictionary Module (List Module))) + (Dictionary Module Ancestry)) -(def: #export empty +(def: empty Graph (dictionary.new text.hash)) -(def: #export (add to from) - (-> Module Module Graph Graph) - (|>> (dictionary.update~ from (list) (|>> (#.Cons to))) - (dictionary.update~ to (list) id))) +(def: #export modules + (-> Graph (List Module)) + dictionary.keys) -(def: dependents - (-> Module Graph (Maybe (List Module))) - dictionary.get) +## (def: (remove module dependency) +## (-> Module Graph Graph) +## (case (..descendants module dependency) +## (#.Some [ancestors descendants]) +## (list@fold remove +## (dictionary.remove module dependency) +## (set.to-list descendants)) -(def: #export (remove module dependency) - (-> Module Graph Graph) - (case (dependents module dependency) - (#.Some dependents) - (list@fold remove (dictionary.remove module dependency) dependents) +## #.None +## dependency)) - #.None - dependency)) - -(type: #export Dependency +(type: Dependency {#module Module - #imports (List Module)}) - -(def: #export (dependency [module imports]) - (-> Dependency Graph) - (list@fold (..add module) ..empty imports)) + #imports Ancestry}) (def: #export graph (-> (List Dependency) Graph) - (|>> (list@map ..dependency) - (list@fold dictionary.merge empty))) - -(def: #export (prune archive graph) - (-> Archive Graph Graph) - (list@fold (function (_ module graph) - (if (dictionary.contains? module archive) - graph - (..remove module graph))) - graph - (dictionary.keys graph))) + (list@fold (function (_ [module imports] graph) + (dictionary.put module imports graph)) + ..empty)) + +## (def: #export (prune archive graph) +## (-> Archive Graph Graph) +## (list@fold (function (_ module graph) +## (if (archive.archived? archive module) +## graph +## (..remove module graph))) +## graph +## (dictionary.keys graph))) + +(def: (dependency? context target source) + (-> Graph Module Module Bit) + (let [ancestry (: (-> Module Ancestry) + (function (_ module) + (|> context + (dictionary.get module) + (maybe.default ..fresh))))] + (loop [rejected ..fresh + candidates (ancestry target)] + (if (set.empty? candidates) + false + (or (set.member? candidates source) + (let [rejected (set.union rejected candidates)] + (recur rejected + (|> candidates + set.to-list + (list@fold (function (_ candidate new-batch) + (|> candidate + ancestry + (set.difference rejected) + (set.union new-batch))) + ..fresh))))))))) + +(def: #export (load-order key archive) + (-> (Key .Module) Archive (Try (List [Module [archive.ID [Descriptor (Document .Module)]]]))) + (|> archive + archive.archived + (monad.map try.monad + (function (_ module) + (do try.monad + [[descriptor document] (archive.find module archive)] + (wrap {#module module + #imports (get@ #descriptor.references descriptor)})))) + (:: try.monad map + (function (_ dependencies) + (let [context (..graph dependencies)] + (|> context + ..modules + (list.sort (..dependency? context)) + (monad.map try.monad + (function (_ module) + (do try.monad + [module-id (archive.id module archive) + [descriptor document] (archive.find module archive) + document (document.check key document)] + (wrap [module [module-id [descriptor document]]])))))))) + (:: try.monad join))) diff --git a/stdlib/source/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/lux/tool/compiler/meta/io/archive.lux index 7843b9435..9ee78c34a 100644 --- a/stdlib/source/lux/tool/compiler/meta/io/archive.lux +++ b/stdlib/source/lux/tool/compiler/meta/io/archive.lux @@ -29,6 +29,8 @@ ["." artifact (#+ Artifact)] ["." descriptor (#+ Module Descriptor)] ["." document (#+ Document)]] + [cache + ["." dependency]] [// [language ["$" lux @@ -242,21 +244,33 @@ (All [expression directive] (-> Text (generation.Host expression directive) (file.System Promise) Host Path Archive (Promise (Try [Archive .Lux])))) (do (try.with promise.monad) - [all-loaded-caches (|> archive + [pre-loaded-caches (|> archive archive.reservations (monad.map @ (function (_ [module-name module-id]) (do @ [data (..read-module-descriptor system host root module-id) - descriptor,document (promise@wrap (<b>.run ..parser data)) - descriptor,document (load-definitions system host root module-id extension host-environment descriptor,document)] - (wrap [module-name descriptor,document])))))] + descriptor,document (promise@wrap (<b>.run ..parser data))] + (wrap [module-name [module-id descriptor,document]]))))) + load-order (|> pre-loaded-caches + (monad.fold try.monad + (function (_ [module [module-id descriptor,document]] archive) + (archive.add module descriptor,document archive)) + archive) + (:: try.monad map (dependency.load-order $.key)) + (:: try.monad join) + promise@wrap) + loaded-caches (monad.map @ (function (_ [module-name [module-id descriptor,document]]) + (do @ + [descriptor,document (..load-definitions system host root module-id extension host-environment descriptor,document)] + (wrap [module-name descriptor,document]))) + load-order)] (promise@wrap (do try.monad [archive (monad.fold try.monad - (function (_ [module descriptor+document] archive) - (archive.add module descriptor+document archive)) + (function (_ [module descriptor,document] archive) + (archive.add module descriptor,document archive)) archive - all-loaded-caches) + loaded-caches) analysis-state (..analysis-state host archive)] (wrap [archive analysis-state]))))) diff --git a/stdlib/source/lux/tool/compiler/meta/io/context.lux b/stdlib/source/lux/tool/compiler/meta/io/context.lux index 1280a9591..b95e02ee9 100644 --- a/stdlib/source/lux/tool/compiler/meta/io/context.lux +++ b/stdlib/source/lux/tool/compiler/meta/io/context.lux @@ -5,7 +5,7 @@ [monad (#+ Monad do)]] [control ["." try (#+ Try)] - ["ex" exception (#+ Exception exception:)] + ["." exception (#+ Exception exception:)] [security ["!" capability]] [concurrency @@ -25,7 +25,8 @@ (template [<name>] [(exception: #export (<name> {module Module}) - (ex.report ["Module" module]))] + (exception.report + ["Module" (%.text module)]))] [cannot-find-module] [cannot-read-module] @@ -49,7 +50,7 @@ (Promise (Try [Path (File Promise)]))) (case contexts #.Nil - (promise@wrap (ex.throw ..cannot-find-module [module])) + (promise@wrap (exception.throw ..cannot-find-module [module])) (#.Cons context contexts') (do promise.monad @@ -91,4 +92,4 @@ #////.code code}) (#try.Failure _) - (promise@wrap (ex.throw ..cannot-read-module [module]))))) + (promise@wrap (exception.throw ..cannot-read-module [module]))))) |