aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/abstract/algebra.lux2
-rw-r--r--stdlib/source/lux/abstract/hash.lux10
-rw-r--r--stdlib/source/lux/abstract/monoid.lux13
-rw-r--r--stdlib/source/lux/tool/compiler/default/init.lux9
-rw-r--r--stdlib/source/lux/tool/compiler/default/platform.lux129
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive.lux165
-rw-r--r--stdlib/source/lux/tool/compiler/meta/cache/dependency.lux136
-rw-r--r--stdlib/source/lux/tool/compiler/meta/io/archive.lux28
-rw-r--r--stdlib/source/lux/tool/compiler/meta/io/context.lux9
-rw-r--r--stdlib/source/test/lux/abstract/fold.lux37
-rw-r--r--stdlib/source/test/lux/abstract/interval.lux179
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."