diff options
Diffstat (limited to 'stdlib/source')
| -rw-r--r-- | stdlib/source/lux/abstract/algebra.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/abstract/hash.lux | 10 | ||||
| -rw-r--r-- | stdlib/source/lux/abstract/monoid.lux | 13 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/default/init.lux | 9 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/default/platform.lux | 129 | ||||
| -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 | ||||
| -rw-r--r-- | stdlib/source/test/lux/abstract/fold.lux | 37 | ||||
| -rw-r--r-- | stdlib/source/test/lux/abstract/interval.lux | 179 |
11 files changed, 425 insertions, 292 deletions
diff --git a/stdlib/source/lux/abstract/algebra.lux b/stdlib/source/lux/abstract/algebra.lux index 0d066fb4f..14d29bf16 100644 --- a/stdlib/source/lux/abstract/algebra.lux +++ b/stdlib/source/lux/abstract/algebra.lux @@ -1,7 +1,7 @@ (.module: [lux #* [control - functor]]) + [functor (#+ Fix)]]]) (type: #export (Algebra f a) (-> (f a) a)) diff --git a/stdlib/source/lux/abstract/hash.lux b/stdlib/source/lux/abstract/hash.lux index e2716335c..62e72e52a 100644 --- a/stdlib/source/lux/abstract/hash.lux +++ b/stdlib/source/lux/abstract/hash.lux @@ -11,14 +11,14 @@ (: (-> a Nat) hash)) -(def: #export (product leftH rightH) +(def: #export (product left right) (All [l r] (-> (Hash l) (Hash r) (Hash [l r]))) (structure (def: &equivalence - (equivalence.product (:: leftH &equivalence) - (:: rightH &equivalence))) + (equivalence.product (:: left &equivalence) + (:: right &equivalence))) (def: (hash [leftV rightV]) (:coerce Nat ("lux i64 *" - (:coerce Int (:: leftH hash leftV)) - (:coerce Int (:: rightH hash rightV))))))) + (:coerce Int (:: left hash leftV)) + (:coerce Int (:: right hash rightV))))))) diff --git a/stdlib/source/lux/abstract/monoid.lux b/stdlib/source/lux/abstract/monoid.lux index 33d082020..088fda263 100644 --- a/stdlib/source/lux/abstract/monoid.lux +++ b/stdlib/source/lux/abstract/monoid.lux @@ -11,9 +11,10 @@ (def: #export (compose Monoid<l> Monoid<r>) (All [l r] (-> (Monoid l) (Monoid r) (Monoid [l r]))) - (structure (def: identity - [(:: Monoid<l> identity) (:: Monoid<r> identity)]) - - (def: (compose [lL rL] [lR rR]) - [(:: Monoid<l> compose lL lR) - (:: Monoid<r> compose rL rR)]))) + (structure + (def: identity + [(:: Monoid<l> identity) (:: Monoid<r> identity)]) + + (def: (compose [lL rL] [lR rR]) + [(:: Monoid<l> compose lL lR) + (:: Monoid<r> compose rL rR)]))) diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux index 3c23bf62c..ae03d19d5 100644 --- a/stdlib/source/lux/tool/compiler/default/init.lux +++ b/stdlib/source/lux/tool/compiler/default/init.lux @@ -43,7 +43,7 @@ [directive [".D" lux]]]]]] [meta - [archive (#+ Archive) + ["." archive (#+ Archive) ["." descriptor (#+ Module)] ["." artifact] ["." document]]]]]) @@ -206,9 +206,10 @@ (def: (default-dependencies prelude input) (-> Module ///.Input (List Module)) - (if (text@= prelude (get@ #///.module input)) - (list) - (list prelude))) + (list& archive.runtime-module + (if (text@= prelude (get@ #///.module input)) + (list) + (list prelude)))) (def: module-aliases (-> .Module Aliases) diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index 86a1dea87..8e4946966 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -16,7 +16,8 @@ ["%" format (#+ format)]] [collection ["." row] - ["." set]] + ["." set] + ["." list ("#@." monoid)]] [format ["_" binary (#+ Writer)]]] [world @@ -66,10 +67,10 @@ (:coerce (Monad Action) (try.with promise.monad))) -(with-expansions [<type-vars> (as-is [anchor expression directive]) - <Platform> (as-is (Platform anchor expression directive)) - <State+> (as-is (///directive.State+ anchor expression directive)) - <Bundle> (as-is (///generation.Bundle anchor expression directive))] +(with-expansions [<type-vars> (as-is anchor expression directive) + <Platform> (as-is (Platform <type-vars>)) + <State+> (as-is (///directive.State+ <type-vars>)) + <Bundle> (as-is (///generation.Bundle <type-vars>))] (def: writer (Writer [Descriptor (Document .Module)]) @@ -77,7 +78,7 @@ (document.writer $.writer))) (def: (cache-module platform host target-dir module-id extension [[descriptor document] output]) - (All <type-vars> + (All [<type-vars>] (-> <Platform> Host Path archive.ID Text [[Descriptor (Document Any)] Output] (Promise (Try Any)))) (let [system (get@ #&file-system platform) @@ -97,14 +98,14 @@ ## TODO: Inline ASAP (def: initialize-buffer! - (All <type-vars> - (///generation.Operation anchor expression directive Any)) + (All [<type-vars>] + (///generation.Operation <type-vars> Any)) (///generation.set-buffer ///generation.empty-buffer)) ## TODO: Inline ASAP (def: (compile-runtime! platform) - (All <type-vars> - (-> <Platform> (///generation.Operation anchor expression directive [Registry Output]))) + (All [<type-vars>] + (-> <Platform> (///generation.Operation <type-vars> [Registry Output]))) (do ///phase.monad [_ ..initialize-buffer!] (get@ #runtime platform))) @@ -122,15 +123,13 @@ (Document .Module) (document.write $.key (module.new 0))) - (def: (process-runtime analysis-state archive platform) - (All <type-vars> - (-> .Lux Archive <Platform> - (///directive.Operation anchor expression directive + (def: (process-runtime archive platform) + (All [<type-vars>] + (-> Archive <Platform> + (///directive.Operation <type-vars> [Archive [[Descriptor (Document .Module)] Output]]))) (do ///phase.monad - [_ (///directive.lift-analysis - (///analysis.install analysis-state)) - [registry payload] (///directive.lift-generation + [[registry payload] (///directive.lift-generation (..compile-runtime! platform)) #let [descriptor,document [(..runtime-descriptor registry) ..runtime-document]] archive (///phase.lift (do try.monad @@ -139,7 +138,7 @@ (wrap [archive [descriptor,document payload]]))) (def: #export (initialize extension target host module expander host-analysis platform generation-bundle host-directive-bundle program extender) - (All <type-vars> + (All [<type-vars>] (-> Text Path Host @@ -148,34 +147,45 @@ ///analysis.Bundle <Platform> <Bundle> - (///directive.Bundle anchor expression directive) + (///directive.Bundle <type-vars>) (-> expression directive) Extender (Promise (Try [<State+> Archive])))) - (let [state (//init.state host - module - expander - host-analysis - (get@ #host platform) - (get@ #phase platform) - generation-bundle - host-directive-bundle - program - extender)] - (do (try.with promise.monad) - [_ (ioW.enable (get@ #&file-system platform) host target) - [archive analysis-state] (ioW.thaw extension (get@ #host platform) (get@ #&file-system platform) host target) - [state [archive payload]] (|> (process-runtime analysis-state archive platform) - (///phase.run' state) - promise@wrap) - _ (..cache-module platform host target 0 extension payload)] - (wrap [state archive])))) + (do (try.with promise.monad) + [#let [state (//init.state host + module + expander + host-analysis + (get@ #host platform) + (get@ #phase platform) + generation-bundle + host-directive-bundle + program + extender)] + _ (ioW.enable (get@ #&file-system platform) host target) + [archive analysis-state] (ioW.thaw extension (get@ #host platform) (get@ #&file-system platform) host target) + [state _] (|> (:share [<type-vars>] + {<State+> + state} + {(///directive.Operation <type-vars> Any) + (///directive.lift-analysis + (///analysis.install analysis-state))}) + (///phase.run' state) + promise@wrap)] + (if (archive.archived? archive archive.runtime-module) + (wrap [state archive]) + (do (try.with promise.monad) + [[state [archive payload]] (|> (..process-runtime archive platform) + (///phase.run' state) + promise@wrap) + _ (..cache-module platform host target 0 extension payload)] + (wrap [state archive]))))) (def: #export (compile target partial-host-extension expander platform host configuration archive extension state) - (All <type-vars> + (All [<type-vars>] (-> Text Text Expander <Platform> Host Configuration Archive Text <State+> (Promise (Try [Archive <State+>])))) (let [source-module (get@ #cli.module configuration) - compiler (:share <type-vars> + compiler (:share [<type-vars>] {<State+> state} {(///.Compiler <State+> .Module Any) @@ -184,11 +194,11 @@ [archive state] [archive state]] (if (archive.archived? archive module) (promise@wrap (#try.Success [archive state])) - (let [import! (:share <type-vars> + (let [import! (:share [<type-vars>] {<Platform> platform} {(-> Module [Archive <State+>] - (Promise (Try [Archive <State+>]))) + (Action [Archive <State+>])) recur})] (do (try.with promise.monad) [[module-id archive] (promise@wrap (archive.reserve module archive)) @@ -198,24 +208,25 @@ module)] (loop [archive archive state state - compilation (compiler (:coerce ///.Input input))] + compilation (compiler (:coerce ///.Input input)) + all-dependencies (: (List Module) + (list))] (do @ - [#let [dependencies (get@ #///.dependencies compilation)] - archive+state (monad.fold @ import! [archive state] dependencies) - #let [## TODO: Inline ASAP - [archive state] (:share <type-vars> - {<Platform> - platform} - {[Archive <State+>] - archive+state}) - continue! (:share <type-vars> + [#let [new-dependencies (get@ #///.dependencies compilation) + all-dependencies (list@compose new-dependencies all-dependencies)] + [archive state] (:share [<type-vars>] {<Platform> platform} - {(-> Archive <State+> (///.Compilation <State+> .Module Any) - (Promise (Try [Archive <State+>]))) + {(Action [Archive <State+>]) + (monad.fold ..monad import! [archive state] new-dependencies)}) + #let [continue! (:share [<type-vars>] + {<Platform> + platform} + {(-> Archive <State+> (///.Compilation <State+> .Module Any) (List Module) + (Action [Archive <State+>])) recur})]] (case ((get@ #///.process compilation) - (case dependencies + (case new-dependencies #.Nil state @@ -230,13 +241,13 @@ (#try.Success [state more|done]) (case more|done (#.Left more) - (continue! archive state more) + (continue! archive state more all-dependencies) - (#.Right payload) + (#.Right [[descriptor document] output]) (do (try.with promise.monad) - [_ (..cache-module platform host target module-id extension payload) - #let [[descriptor+document output] payload]] - (case (archive.add module descriptor+document archive) + [#let [descriptor (set@ #descriptor.references (set.from-list text.hash all-dependencies) descriptor)] + _ (..cache-module platform host target module-id extension [[descriptor document] output])] + (case (archive.add module [descriptor document] archive) (#try.Success archive) (wrap [archive state]) 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]))))) diff --git a/stdlib/source/test/lux/abstract/fold.lux b/stdlib/source/test/lux/abstract/fold.lux index 334d43e50..e954a0a38 100644 --- a/stdlib/source/test/lux/abstract/fold.lux +++ b/stdlib/source/test/lux/abstract/fold.lux @@ -1,12 +1,17 @@ (.module: [lux #* ["_" test (#+ Test)] - ["%" data/text/format (#+ format)] - ["r" math/random] - [abstract/monad (#+ do)] + [abstract + [monad (#+ do)]] [data [number - ["n" nat]]]] + ["n" nat]] + [text + ["%" format (#+ format)]] + [collection + ["." list]]] + [math + ["." random]]] [// [functor (#+ Injection Comparison)]] {1 @@ -14,10 +19,20 @@ (def: #export (spec injection comparison (^open "/@.")) (All [f] (-> (Injection f) (Comparison f) (Fold f) Test)) - (_.context (%.name (name-of /.Fold)) - (do r.monad - [subject r.nat - parameter r.nat] - (_.test "Can fold." - (n.= (/@fold n.+ parameter (injection subject)) - (n.+ parameter subject)))))) + (do random.monad + [subject random.nat + parameter random.nat] + (_.cover [/.Fold] + (n.= (/@fold n.+ parameter (injection subject)) + (n.+ parameter subject))))) + +(def: #export test + Test + (do random.monad + [samples (random.list 10 random.nat)] + (<| (_.covering /._) + ($_ _.and + (_.cover [/.with-monoid] + (n.= (:: list.fold fold (:: n.addition compose) (:: n.addition identity) samples) + (/.with-monoid n.addition list.fold samples))) + )))) diff --git a/stdlib/source/test/lux/abstract/interval.lux b/stdlib/source/test/lux/abstract/interval.lux index 1a15336f5..c6f2cd36f 100644 --- a/stdlib/source/test/lux/abstract/interval.lux +++ b/stdlib/source/test/lux/abstract/interval.lux @@ -12,23 +12,21 @@ [data [number ["n" nat]] - [text - ["%" format (#+ format)]] [collection ["." set] ["." list]]] [math - ["r" random (#+ Random)]]] + ["." random (#+ Random)]]] {1 ["." / (#+ Interval) ("#@." equivalence)]}) (template [<name> <cmp>] [(def: #export <name> (Random (Interval Nat)) - (do r.monad - [bottom r.nat - top (r.filter (|>> (n.= bottom) not) - r.nat)] + (do random.monad + [bottom random.nat + top (random.filter (|>> (n.= bottom) not) + random.nat)] (if (<cmp> top bottom) (wrap (/.between n.enum bottom top)) (wrap (/.between n.enum top bottom)))))] @@ -39,54 +37,54 @@ (def: #export singleton (Random (Interval Nat)) - (do r.monad - [point r.nat] + (do random.monad + [point random.nat] (wrap (/.singleton n.enum point)))) (def: #export interval (Random (Interval Nat)) - ($_ r.either + ($_ random.either ..inner ..outer ..singleton)) (def: types Test - (do r.monad + (do random.monad [inner ..inner outer ..outer singleton ..singleton] ($_ _.and - (_.test (%.name (name-of /.inner?)) - (/.inner? inner)) - (_.test (%.name (name-of /.outer?)) - (/.outer? outer)) - (_.test (%.name (name-of /.singleton?)) - (/.singleton? singleton)) + (_.cover [/.inner?] + (/.inner? inner)) + (_.cover [/.outer?] + (/.outer? outer)) + (_.cover [/.singleton /.singleton?] + (/.singleton? singleton)) ))) (def: boundaries Test - (do r.monad - [bottom r.nat - top r.nat + (do random.monad + [bottom random.nat + top random.nat #let [interval (/.between n.enum bottom top)]] ($_ _.and - (_.test (%.name (name-of /.within?)) - (and (/.within? interval bottom) - (/.within? interval top))) - (_.test (%.name (name-of /.starts-with?)) - (/.starts-with? bottom interval)) - (_.test (%.name (name-of /.ends-with?)) - (/.ends-with? top interval)) - (_.test (%.name (name-of /.borders?)) - (and (/.borders? interval bottom) - (/.borders? interval top))) + (_.cover [/.between /.within?] + (and (/.within? interval bottom) + (/.within? interval top))) + (_.cover [/.starts-with?] + (/.starts-with? bottom interval)) + (_.cover [/.ends-with?] + (/.ends-with? top interval)) + (_.cover [/.borders?] + (and (/.borders? interval bottom) + (/.borders? interval top))) ))) (def: union Test - (do r.monad + (do random.monad [some-interval ..interval left-inner ..inner right-inner ..inner @@ -107,7 +105,7 @@ (def: intersection Test - (do r.monad + (do random.monad [some-interval ..interval left-inner ..inner right-inner ..inner @@ -128,7 +126,7 @@ (def: complement Test - (do r.monad + (do random.monad [some-interval ..interval] ($_ _.and (_.test "The complement of a complement is the same as the original." @@ -139,8 +137,8 @@ (def: location Test - (do r.monad - [[l m r] (|> (r.set n.hash 3 r.nat) + (do random.monad + [[l m r] (|> (random.set n.hash 3 random.nat) (:: @ map (|>> set.to-list (list.sort n.<) (case> (^ (list b t1 t2)) @@ -151,18 +149,18 @@ #let [left (/.singleton n.enum l) right (/.singleton n.enum r)]] ($_ _.and - (_.test (format (%.name (name-of /.precedes?)) " &&& " (%.name (name-of /.succeeds?))) - (and (/.precedes? right left) - (/.succeeds? left right))) - (_.test (format (%.name (name-of /.before?)) " &&& " (%.name (name-of /.after?))) - (and (/.before? m left) - (/.after? m right))) + (_.cover [/.precedes? /.succeeds?] + (and (/.precedes? right left) + (/.succeeds? left right))) + (_.cover [/.before? /.after?] + (and (/.before? m left) + (/.after? m right))) ))) (def: touch Test - (do r.monad - [[b t1 t2] (|> (r.set n.hash 3 r.nat) + (do random.monad + [[b t1 t2] (|> (random.set n.hash 3 random.nat) (:: @ map (|>> set.to-list (list.sort n.<) (case> (^ (list b t1 t2)) @@ -173,23 +171,23 @@ #let [int-left (/.between n.enum t1 t2) int-right (/.between n.enum b t1)]] ($_ _.and - (_.test (%.name (name-of /.meets?)) - (/.meets? int-left int-right)) - (_.test (%.name (name-of /.touches?)) - (/.touches? int-left int-right)) - (_.test (%.name (name-of /.starts?)) - (/.starts? (/.between n.enum b t2) - (/.between n.enum b t1))) - (_.test (%.name (name-of /.finishes?)) - (/.finishes? (/.between n.enum b t2) - (/.between n.enum t1 t2))) + (_.cover [/.meets?] + (/.meets? int-left int-right)) + (_.cover [/.touches?] + (/.touches? int-left int-right)) + (_.cover [/.starts?] + (/.starts? (/.between n.enum b t2) + (/.between n.enum b t1))) + (_.cover [/.finishes?] + (/.finishes? (/.between n.enum b t2) + (/.between n.enum t1 t2))) ))) -(def: overlap +(def: nested Test - (do r.monad + (do random.monad [some-interval ..interval - [x0 x1 x2 x3] (|> (r.set n.hash 4 r.nat) + [x0 x1 x2 x3] (|> (random.set n.hash 4 random.nat) (:: @ map (|>> set.to-list (list.sort n.<) (case> (^ (list x0 x1 x2 x3)) @@ -200,18 +198,11 @@ ($_ _.and (_.test "Every interval is nested into itself." (/.nested? some-interval some-interval)) - (_.test "No interval overlaps with itself." - (not (/.overlaps? some-interval some-interval))) (let [small-inner (/.between n.enum x1 x2) large-inner (/.between n.enum x0 x3)] (_.test "Inner intervals can be nested inside one another." (and (/.nested? large-inner small-inner) (not (/.nested? small-inner large-inner))))) - (let [left-inner (/.between n.enum x0 x2) - right-inner (/.between n.enum x1 x3)] - (_.test "Inner intervals can overlap one another." - (and (/.overlaps? left-inner right-inner) - (/.overlaps? right-inner left-inner)))) (let [small-outer (/.between n.enum x2 x1) large-outer (/.between n.enum x3 x0)] (_.test "Outer intervals can be nested inside one another." @@ -223,6 +214,28 @@ (_.test "Inners can be nested inside outers." (and (/.nested? outer left-inner) (/.nested? outer right-inner)))) + ))) + +(def: overlap + Test + (do random.monad + [some-interval ..interval + [x0 x1 x2 x3] (|> (random.set n.hash 4 random.nat) + (:: @ map (|>> set.to-list + (list.sort n.<) + (case> (^ (list x0 x1 x2 x3)) + [x0 x1 x2 x3] + + _ + (undefined)))))] + ($_ _.and + (_.test "No interval overlaps with itself." + (not (/.overlaps? some-interval some-interval))) + (let [left-inner (/.between n.enum x0 x2) + right-inner (/.between n.enum x1 x3)] + (_.test "Inner intervals can overlap one another." + (and (/.overlaps? left-inner right-inner) + (/.overlaps? right-inner left-inner)))) (let [left-inner (/.between n.enum x0 x2) right-inner (/.between n.enum x1 x3) outer (/.between n.enum x1 x2)] @@ -233,31 +246,31 @@ (def: #export test Test - (<| (_.context (%.name (name-of /.Interval))) + (<| (_.covering /._) ($_ _.and - ($equivalence.spec /.equivalence ..interval) - (<| (_.context "Types.") - ..types) - (<| (_.context "Boundaries.") - ..boundaries) - (<| (_.context (%.name (name-of /.union))) - ..union) - (<| (_.context (%.name (name-of /.intersection))) - ..intersection) - (<| (_.context (%.name (name-of /.complement))) - ..complement) - (<| (_.context "Positioning/location.") - ..location) - (<| (_.context "Touching intervals.") - ..touch) - (<| (_.context "Nesting & overlap.") - ..overlap) + (_.with-cover [/.equivalence] + ($equivalence.spec /.equivalence ..interval)) + + ..types + ..boundaries + (_.with-cover [/.union] + ..union) + (_.with-cover [/.intersection] + ..intersection) + (_.with-cover [/.complement] + ..complement) + ..location + ..touch + (_.with-cover [/.nested?] + ..nested) + (_.with-cover [/.overlaps?] + ..overlap) ))) (def: #export (spec (^open "/@.") gen-sample) (All [a] (-> (Interval a) (Random a) Test)) - (<| (_.context (%.name (name-of /.Interval))) - (do r.monad + (<| (_.with-cover [/.Interval]) + (do random.monad [sample gen-sample] ($_ _.and (_.test "No value is bigger than the top." |