aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/extension/host.lux160
-rw-r--r--stdlib/source/lux/control/region.lux11
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux18
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux175
-rw-r--r--stdlib/source/test/lux/control/pipe.lux84
-rw-r--r--stdlib/source/test/lux/control/reader.lux9
-rw-r--r--stdlib/source/test/lux/control/region.lux95
7 files changed, 304 insertions, 248 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm/extension/host.lux b/new-luxc/source/luxc/lang/translation/jvm/extension/host.lux
index 408b2a389..d448d182c 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/extension/host.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/extension/host.lux
@@ -12,7 +12,8 @@
[data
["." product]
["." maybe]
- ["." text ("#@." equivalence)]
+ ["." text ("#@." equivalence)
+ ["%" format (#+ format)]]
[number
["." nat]]
[collection
@@ -56,7 +57,7 @@
["_." def]]]]]
["." // #_
[common (#+ custom)]
- ["/#" // #_
+ ["/#" //
["#." reference]
["#." function]]])
@@ -946,89 +947,88 @@
## (:: type.equivalence = type.double returnT)
_.DRETURN))))
-## TODO: Uncomment ASAP
-## (def: class::anonymous
-## Handler
-## (..custom
-## [($_ <>.and
-## <s>.text
-## ..class
-## (<s>.tuple (<>.some ..class))
-## (<s>.tuple (<>.some ..input))
-## (<s>.tuple (<>.some ..overriden-method-definition)))
-## (function (_ extension-name generate archive [class-name
-## super-class super-interfaces
-## inputsTS
-## overriden-methods])
-## (do phase.monad
-## [#let [class (type.class class-name (list))
-## total-environment (|> overriden-methods
-## ## Get all the environments.
-## (list@map product.left)
-## ## Combine them.
-## list@join
-## ## Remove duplicates.
-## (set.from-list reference.hash)
-## set.to-list)
-## global-mapping (|> total-environment
-## ## Give them names as "foreign" variables.
-## list.enumerate
-## (list@map (function (_ [id capture])
-## [capture (#reference.Foreign id)]))
-## (dictionary.from-list reference.hash))
-## normalized-methods (list@map (function (_ [environment
-## [ownerT name
-## strict-fp? annotations vars
-## self-name arguments returnT exceptionsT
-## body]])
-## (let [local-mapping (|> environment
-## list.enumerate
-## (list@map (function (_ [foreign-id capture])
-## [(#reference.Foreign foreign-id)
-## (|> global-mapping
-## (dictionary.get capture)
-## maybe.assume)]))
-## (dictionary.from-list reference.hash))]
-## [ownerT name
-## strict-fp? annotations vars
-## self-name arguments returnT exceptionsT
-## (normalize-method-body local-mapping body)]))
-## overriden-methods)]
-## inputsTI (monad.map @ (generate-input generate archive) inputsTS)
-## method-definitions (|> normalized-methods
-## (monad.map @ (function (_ [ownerT name
-## strict-fp? annotations vars
-## self-name arguments returnT exceptionsT
-## bodyS])
-## (do @
-## [bodyG (generation.with-specific-context class-name
-## (generate archive bodyS))]
-## (wrap (_def.method #$.Public
-## (if strict-fp?
-## ($_ $.++M $.finalM $.strictM)
-## $.finalM)
-## name
-## (type.method [(list@map product.right arguments)
-## returnT
-## exceptionsT])
-## (|>> bodyG (returnI returnT)))))))
-## (:: @ map _def.fuse))
-## _ (generation.save! true ["" class-name]
-## [class-name
-## (_def.class #$.V1_6 #$.Public $.finalC
-## class-name (list)
-## super-class super-interfaces
-## (|>> (///function.with-environment total-environment)
-## (..with-anonymous-init class total-environment super-class inputsTI)
-## method-definitions))])]
-## (anonymous-instance class total-environment)))]))
+(def: class::anonymous
+ Handler
+ (..custom
+ [($_ <>.and
+ ..class
+ (<s>.tuple (<>.some ..class))
+ (<s>.tuple (<>.some ..input))
+ (<s>.tuple (<>.some ..overriden-method-definition)))
+ (function (_ extension-name generate archive [super-class super-interfaces
+ inputsTS
+ overriden-methods])
+ (do phase.monad
+ [[context _] (generation.with-new-context archive (wrap []))
+ #let [[module-id artifact-id] context
+ anonymous-class-name (///.class-name context)
+ class (type.class anonymous-class-name (list))
+ total-environment (|> overriden-methods
+ ## Get all the environments.
+ (list@map product.left)
+ ## Combine them.
+ list@join
+ ## Remove duplicates.
+ (set.from-list reference.hash)
+ set.to-list)
+ global-mapping (|> total-environment
+ ## Give them names as "foreign" variables.
+ list.enumerate
+ (list@map (function (_ [id capture])
+ [capture (#reference.Foreign id)]))
+ (dictionary.from-list reference.hash))
+ normalized-methods (list@map (function (_ [environment
+ [ownerT name
+ strict-fp? annotations vars
+ self-name arguments returnT exceptionsT
+ body]])
+ (let [local-mapping (|> environment
+ list.enumerate
+ (list@map (function (_ [foreign-id capture])
+ [(#reference.Foreign foreign-id)
+ (|> global-mapping
+ (dictionary.get capture)
+ maybe.assume)]))
+ (dictionary.from-list reference.hash))]
+ [ownerT name
+ strict-fp? annotations vars
+ self-name arguments returnT exceptionsT
+ (normalize-method-body local-mapping body)]))
+ overriden-methods)]
+ inputsTI (monad.map @ (generate-input generate archive) inputsTS)
+ method-definitions (|> normalized-methods
+ (monad.map @ (function (_ [ownerT name
+ strict-fp? annotations vars
+ self-name arguments returnT exceptionsT
+ bodyS])
+ (do @
+ [bodyG (generation.with-context artifact-id
+ (generate archive bodyS))]
+ (wrap (_def.method #$.Public
+ (if strict-fp?
+ ($_ $.++M $.finalM $.strictM)
+ $.finalM)
+ name
+ (type.method [(list@map product.right arguments)
+ returnT
+ exceptionsT])
+ (|>> bodyG (returnI returnT)))))))
+ (:: @ map _def.fuse))
+ _ (generation.save! true ["" (%.nat artifact-id)]
+ [anonymous-class-name
+ (_def.class #$.V1_6 #$.Public $.finalC
+ anonymous-class-name (list)
+ super-class super-interfaces
+ (|>> (///function.with-environment total-environment)
+ (..with-anonymous-init class total-environment super-class inputsTI)
+ method-definitions))])]
+ (anonymous-instance archive class total-environment)))]))
(def: bundle::class
Bundle
(<| (bundle.prefix "class")
(|> (: Bundle bundle.empty)
- ## TODO: Uncomment ASAP
- ## (bundle.install "anonymous" class::anonymous)
+ (bundle.install "anonymous" class::anonymous)
)))
(def: #export bundle
diff --git a/stdlib/source/lux/control/region.lux b/stdlib/source/lux/control/region.lux
index 23e46353e..23f3888b3 100644
--- a/stdlib/source/lux/control/region.lux
+++ b/stdlib/source/lux/control/region.lux
@@ -10,9 +10,9 @@
["." text
["%" format (#+ format)]]
[collection
- ["." list ("#;." fold)]]]]
+ ["." list ("#@." fold)]]]]
[//
- ["ex" exception (#+ Exception exception:)]])
+ ["." exception (#+ Exception exception:)]])
(type: (Cleaner r m)
(-> r (m (Try Any))))
@@ -48,7 +48,7 @@
output
(#try.Failure error|clean-up)
- (ex.throw clean-up-error [error|clean-up output])))
+ (exception.throw ..clean-up-error [error|clean-up output])))
(def: #export (run Monad<m> computation)
(All [m a]
@@ -58,7 +58,7 @@
[[cleaners output] (computation [[] (list)])
results (monad.map @ (function (_ cleaner) (cleaner []))
cleaners)]
- (wrap (list;fold combine-outcomes output results))))
+ (wrap (list@fold combine-outcomes output results))))
(def: #export (acquire Monad<m> cleaner value)
(All [m a] (-> (Monad m) (-> a (m (Try Any))) a
@@ -145,8 +145,7 @@
(All [m e a]
(-> (Monad m) (Exception e) e
(All [r] (Region r m a))))
- (function (_ [region cleaners])
- (:: Monad<m> wrap [cleaners (ex.throw exception message)])))
+ (fail Monad<m> (exception.construct exception message)))
(def: #export (lift Monad<m> operation)
(All [m a]
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux
index 76d8525ba..3b001e9db 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux
@@ -1925,19 +1925,19 @@
mapping))
luxT.fresh
parameters)]
- name (///.lift (do macro.monad
- [where macro.current-module-name
- id macro.count]
- (wrap (..anonymous-class-name where id))))
super-classT (typeA.with-env
(luxT.check (luxT.class mapping) (..signature super-class)))
super-interfaceT+ (typeA.with-env
(monad.map check.monad
(|>> ..signature (luxT.check (luxT.class mapping)))
super-interfaces))
- #let [selfT (inheritance-relationship-type (#.Primitive name (list))
- super-classT
- super-interfaceT+)]
+ selfT (///.lift (do macro.monad
+ [where macro.current-module-name
+ id macro.count]
+ (wrap (inheritance-relationship-type (#.Primitive (..anonymous-class-name where id) (list))
+ super-classT
+ super-interfaceT+))))
+ _ (typeA.infer selfT)
constructor-argsA+ (monad.map @ (function (_ [type term])
(do @
[argT (reflection-type mapping type)
@@ -1961,14 +1961,12 @@
methods)
#let [missing-abstract-methods (mismatched-methods overriden-methods required-abstract-methods)
invalid-overriden-methods (mismatched-methods available-methods overriden-methods)]
- _ (typeA.infer selfT)
_ (phase.assert ..missing-abstract-methods missing-abstract-methods
(list.empty? missing-abstract-methods))
_ (phase.assert ..invalid-overriden-methods invalid-overriden-methods
(list.empty? invalid-overriden-methods))]
(wrap (#/////analysis.Extension extension-name
- (list (/////analysis.text name)
- (class-analysis super-class)
+ (list (class-analysis super-class)
(/////analysis.tuple (list@map class-analysis super-interfaces))
(/////analysis.tuple (list@map typed-analysis constructor-argsA+))
(/////analysis.tuple methodsA))))))]))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux
index 266985b68..ee5bbf4d6 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux
@@ -11,7 +11,8 @@
[data
["." product]
["." maybe]
- ["." text ("#@." equivalence)]
+ ["." text ("#@." equivalence)
+ ["%" format (#+ format)]]
[number
["." i32]]
[collection
@@ -46,7 +47,7 @@
[extension (#+ Nullary Unary Binary Trinary Variadic
nullary unary binary trinary variadic)]
["///" jvm
- [runtime (#+ Operation Bundle Phase Handler)]
+ ["#." runtime (#+ Operation Bundle Phase Handler)]
["#." reference]
[function
[field
@@ -983,96 +984,96 @@
## (:: type.equivalence = type.double returnT)
_.dreturn))))
-## TODO: Uncomment ASAP.
-## (def: class::anonymous
-## Handler
-## (..custom
-## [($_ <>.and
-## <s>.text
-## ..class
-## (<s>.tuple (<>.some ..class))
-## (<s>.tuple (<>.some ..input))
-## (<s>.tuple (<>.some ..overriden-method-definition)))
-## (function (_ extension-name generate archive [class-name
-## super-class super-interfaces
-## inputsTS
-## overriden-methods])
-## (do //////.monad
-## [#let [class (type.class class-name (list))
-## total-environment (|> overriden-methods
-## ## Get all the environments.
-## (list@map product.left)
-## ## Combine them.
-## list@join
-## ## Remove duplicates.
-## (set.from-list //////reference.hash)
-## set.to-list)
-## global-mapping (|> total-environment
-## ## Give them names as "foreign" variables.
-## list.enumerate
-## (list@map (function (_ [id capture])
-## [capture (#//////reference.Foreign id)]))
-## (dictionary.from-list //////reference.hash))
-## normalized-methods (list@map (function (_ [environment
-## [ownerT name
-## strict-fp? annotations vars
-## self-name arguments returnT exceptionsT
-## body]])
-## (let [local-mapping (|> environment
-## list.enumerate
-## (list@map (function (_ [foreign-id capture])
-## [(#//////reference.Foreign foreign-id)
-## (|> global-mapping
-## (dictionary.get capture)
-## maybe.assume)]))
-## (dictionary.from-list //////reference.hash))]
-## [ownerT name
-## strict-fp? annotations vars
-## self-name arguments returnT exceptionsT
-## (normalize-method-body local-mapping body)]))
-## overriden-methods)]
-## inputsTI (monad.map @ (generate-input generate archive) inputsTS)
-## method-definitions (monad.map @ (function (_ [ownerT name
-## strict-fp? annotations vars
-## self-name arguments returnT exceptionsT
-## bodyS])
-## (do @
-## [bodyG (//////generation.with-specific-context class-name
-## (generate archive bodyS))]
-## (wrap (method.method ($_ modifier@compose
-## method.public
-## method.final
-## (if strict-fp?
-## method.strict
-## modifier@identity))
-## name
-## (type.method [(list@map product.right arguments)
-## returnT
-## exceptionsT])
-## (list)
-## (#.Some ($_ _.compose
-## bodyG
-## (returnG returnT)))))))
-## normalized-methods)
-## bytecode (<| (:: @ map (format.run class.writer))
-## //////.lift
-## (class.class version.v6_0 ($_ modifier@compose class.public class.final)
-## (name.internal class-name)
-## (name.internal (..reflection super-class))
-## (list@map (|>> ..reflection name.internal) super-interfaces)
-## (foreign.variables total-environment)
-## (list& (..with-anonymous-init class total-environment super-class inputsTI)
-## method-definitions)
-## (row.row)))
-## _ (//////generation.save! true ["" class-name] [class-name bytecode])]
-## (anonymous-instance class total-environment)))]))
+(def: class::anonymous
+ Handler
+ (..custom
+ [($_ <>.and
+ ..class
+ (<s>.tuple (<>.some ..class))
+ (<s>.tuple (<>.some ..input))
+ (<s>.tuple (<>.some ..overriden-method-definition)))
+ (function (_ extension-name generate archive [super-class super-interfaces
+ inputsTS
+ overriden-methods])
+ (do //////.monad
+ [[context _] (//////generation.with-new-context archive (wrap []))
+ #let [[module-id artifact-id] context
+ anonymous-class-name (///runtime.class-name context)
+ class (type.class anonymous-class-name (list))
+ total-environment (|> overriden-methods
+ ## Get all the environments.
+ (list@map product.left)
+ ## Combine them.
+ list@join
+ ## Remove duplicates.
+ (set.from-list //////reference.hash)
+ set.to-list)
+ global-mapping (|> total-environment
+ ## Give them names as "foreign" variables.
+ list.enumerate
+ (list@map (function (_ [id capture])
+ [capture (#//////reference.Foreign id)]))
+ (dictionary.from-list //////reference.hash))
+ normalized-methods (list@map (function (_ [environment
+ [ownerT name
+ strict-fp? annotations vars
+ self-name arguments returnT exceptionsT
+ body]])
+ (let [local-mapping (|> environment
+ list.enumerate
+ (list@map (function (_ [foreign-id capture])
+ [(#//////reference.Foreign foreign-id)
+ (|> global-mapping
+ (dictionary.get capture)
+ maybe.assume)]))
+ (dictionary.from-list //////reference.hash))]
+ [ownerT name
+ strict-fp? annotations vars
+ self-name arguments returnT exceptionsT
+ (normalize-method-body local-mapping body)]))
+ overriden-methods)]
+ inputsTI (monad.map @ (generate-input generate archive) inputsTS)
+ method-definitions (monad.map @ (function (_ [ownerT name
+ strict-fp? annotations vars
+ self-name arguments returnT exceptionsT
+ bodyS])
+ (do @
+ [bodyG (//////generation.with-context artifact-id
+ (generate archive bodyS))]
+ (wrap (method.method ($_ modifier@compose
+ method.public
+ method.final
+ (if strict-fp?
+ method.strict
+ modifier@identity))
+ name
+ (type.method [(list@map product.right arguments)
+ returnT
+ exceptionsT])
+ (list)
+ (#.Some ($_ _.compose
+ bodyG
+ (returnG returnT)))))))
+ normalized-methods)
+ bytecode (<| (:: @ map (format.run class.writer))
+ //////.lift
+ (class.class version.v6_0 ($_ modifier@compose class.public class.final)
+ (name.internal anonymous-class-name)
+ (name.internal (..reflection super-class))
+ (list@map (|>> ..reflection name.internal) super-interfaces)
+ (foreign.variables total-environment)
+ (list& (..with-anonymous-init class total-environment super-class inputsTI)
+ method-definitions)
+ (row.row)))
+ _ (//////generation.save! true ["" (%.nat artifact-id)]
+ [anonymous-class-name bytecode])]
+ (anonymous-instance archive class total-environment)))]))
(def: bundle::class
Bundle
(<| (/////bundle.prefix "class")
(|> (: Bundle /////bundle.empty)
- ## TODO: Uncomment ASAP
- ## (/////bundle.install "anonymous" class::anonymous)
+ (/////bundle.install "anonymous" class::anonymous)
)))
(def: #export bundle
diff --git a/stdlib/source/test/lux/control/pipe.lux b/stdlib/source/test/lux/control/pipe.lux
index 0aecde080..d705e23ca 100644
--- a/stdlib/source/test/lux/control/pipe.lux
+++ b/stdlib/source/test/lux/control/pipe.lux
@@ -13,7 +13,7 @@
[math
["r" random]]]
{1
- ["." / #*]})
+ ["." /]})
(def: #export test
Test
@@ -23,65 +23,65 @@
($_ _.and
(do @
[another r.nat]
- (_.test "Can dismiss previous pipeline results and begin a new one."
+ (_.test (%.name (name-of /.new>))
(n.= (inc another)
(|> sample
(n.* 3)
(n.+ 4)
- (new> another [inc])))))
- (_.test "Let-binding"
+ (/.new> another [inc])))))
+ (_.test (%.name (name-of /.let>))
(n.= (n.+ sample sample)
(|> sample
- (let> x [(n.+ x x)]))))
- (_.test "'Conditional' branching."
+ (/.let> x [(n.+ x x)]))))
+ (_.test (%.name (name-of /.cond>))
(text@= (cond (n.= 0 sample) "zero"
(n.even? sample) "even"
"odd")
(|> sample
- (cond> [(n.= 0)] [(new> "zero" [])]
- [n.even?] [(new> "even" [])]
- [(new> "odd" [])]))))
- (_.test "'If' branching."
+ (/.cond> [(n.= 0)] [(/.new> "zero" [])]
+ [n.even?] [(/.new> "even" [])]
+ [(/.new> "odd" [])]))))
+ (_.test (%.name (name-of /.if>))
(text@= (if (n.even? sample)
"even"
"odd")
(|> sample
- (if> [n.even?]
- [(new> "even" [])]
- [(new> "odd" [])]))))
- (_.test "'When' branching."
+ (/.if> [n.even?]
+ [(/.new> "even" [])]
+ [(/.new> "odd" [])]))))
+ (_.test (%.name (name-of /.when>))
(n.= (if (n.even? sample)
(n.* 2 sample)
sample)
(|> sample
- (when> [n.even?]
- [(n.* 2)]))))
- (_.test "Can loop."
+ (/.when> [n.even?]
+ [(n.* 2)]))))
+ (_.test (%.name (name-of /.loop>))
(n.= (n.* 10 sample)
(|> sample
- (loop> [(n.= (n.* 10 sample)) not]
- [(n.+ sample)]))))
- (_.test "Monads."
+ (/.loop> [(n.= (n.* 10 sample)) not]
+ [(n.+ sample)]))))
+ (_.test (%.name (name-of /.do>))
(n.= (inc (n.+ 4 (n.* 3 sample)))
(|> sample
- (do> identity.monad
- [(n.* 3)]
- [(n.+ 4)]
- [inc]))))
- (_.test "Execution."
+ (/.do> identity.monad
+ [(n.* 3)]
+ [(n.+ 4)]
+ [inc]))))
+ (_.test (%.name (name-of /.exec>))
(n.= (n.* 10 sample)
(|> sample
- (exec> [%.nat (format "sample = ") log!])
+ (/.exec> [%.nat (format "sample = ") log!])
(n.* 10))))
- (_.test "Tuple."
+ (_.test (%.name (name-of /.tuple>))
(let [[left middle right] (|> sample
- (tuple> [inc]
- [dec]
- [%.nat]))]
+ (/.tuple> [inc]
+ [dec]
+ [%.nat]))]
(and (n.= (inc sample) left)
(n.= (dec sample) middle)
(text@= (%.nat sample) right))))
- (_.test "Pattern-matching."
+ (_.test (%.name (name-of /.case>))
(text@= (case (n.% 10 sample)
0 "zero"
1 "one"
@@ -96,15 +96,15 @@
_ "???")
(|> sample
(n.% 10)
- (case> 0 "zero"
- 1 "one"
- 2 "two"
- 3 "three"
- 4 "four"
- 5 "five"
- 6 "six"
- 7 "seven"
- 8 "eight"
- 9 "nine"
- _ "???"))))
+ (/.case> 0 "zero"
+ 1 "one"
+ 2 "two"
+ 3 "three"
+ 4 "four"
+ 5 "five"
+ 6 "six"
+ 7 "seven"
+ 8 "eight"
+ 9 "nine"
+ _ "???"))))
))))
diff --git a/stdlib/source/test/lux/control/reader.lux b/stdlib/source/test/lux/control/reader.lux
index 434ec5896..4ad1e2a45 100644
--- a/stdlib/source/test/lux/control/reader.lux
+++ b/stdlib/source/test/lux/control/reader.lux
@@ -9,6 +9,7 @@
["$." apply]
["$." monad]]}]
[data
+ ["." name]
[number
["n" nat]]
[text
@@ -32,7 +33,7 @@
(def: #export test
Test
- (<| (_.context (%.name (name-of /._)))
+ (<| (_.context (name.module (name-of /._)))
(do r.monad
[sample r.nat
factor r.nat]
@@ -41,14 +42,14 @@
($apply.spec ..injection ..comparison /.apply)
($monad.spec ..injection ..comparison /.monad)
- (_.test "Can query the environment."
+ (_.test (%.name (name-of /.ask))
(n.= sample
(/.run sample /.ask)))
- (_.test "Can modify an environment locally."
+ (_.test (%.name (name-of /.local))
(n.= (n.* factor sample)
(/.run sample (/.local (n.* factor) /.ask))))
(let [(^open "io@.") io.monad]
- (_.test "Can add reader functionality to any monad."
+ (_.test (%.name (name-of /.with))
(|> (: (/.Reader Any (IO Nat))
(do (/.with io.monad)
[a (/.lift (io@wrap sample))
diff --git a/stdlib/source/test/lux/control/region.lux b/stdlib/source/test/lux/control/region.lux
index e7000fc48..eec4e6903 100644
--- a/stdlib/source/test/lux/control/region.lux
+++ b/stdlib/source/test/lux/control/region.lux
@@ -2,10 +2,18 @@
[lux #*
["_" test (#+ Test)]
[abstract
- ["." monad (#+ do)]]
+ [functor (#+ Functor)]
+ [apply (#+ Apply)]
+ ["." monad (#+ Monad do)]
+ {[0 #test]
+ [/
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]]}]
[control
["." try (#+ Try)]]
[data
+ ["." name]
[number
["n" nat]]
[text
@@ -13,12 +21,13 @@
[collection
["." list]]]
[math
- ["r" random]]]
+ ["r" random]]
+ [type (#+ :share)]]
{1
- ["." /
+ ["." / (#+ Region)
[//
["." thread (#+ Thread)]
- ["ex" exception (#+ exception:)]]]})
+ ["." exception (#+ exception:)]]]})
(exception: oops)
@@ -36,61 +45,109 @@
[failure? #0 #1]
)
+(def: (injection value)
+ (Injection (All [a] (All [! r] (Region r (Thread !) a))))
+ (function (_ [region scope])
+ (function (_ !)
+ [scope
+ (#try.Success value)])))
+
+(def: comparison
+ (Comparison (All [a] (All [! r] (Region r (Thread !) a))))
+ (function (_ == left right)
+ (case [(:assume (thread.run (:assume (/.run thread.monad left))))
+ (:assume (thread.run (:assume (/.run thread.monad right))))]
+ [(#try.Success left) (#try.Success right)]
+ (== left right)
+
+ _
+ false)))
+
(def: #export test
Test
- (<| (_.context (%.name (name-of /._)))
+ (<| (_.context (name.module (name-of /._)))
(do r.monad
[expected-clean-ups (|> r.nat (:: @ map (|>> (n.% 100) (n.max 1))))]
($_ _.and
- (_.test "Clean-up functions are always run when region execution is done."
+ ($functor.spec ..injection ..comparison (: (All [! r]
+ (Functor (Region r (thread.Thread !))))
+ (/.functor thread.functor)))
+ ($apply.spec ..injection ..comparison (: (All [! r]
+ (Apply (Region r (thread.Thread !))))
+ (/.apply thread.monad)))
+ ($monad.spec ..injection ..comparison (: (All [! r]
+ (Monad (Region r (thread.Thread !))))
+ (/.monad thread.monad)))
+
+ (_.test (%.name (name-of /.run))
(thread.run
(do thread.monad
[clean-up-counter (thread.box 0)
- #let [@@ @
+ #let [//@ @
count-clean-up (function (_ value)
(do @
[_ (thread.update inc clean-up-counter)]
(wrap (#try.Success []))))]
outcome (/.run @
(do (/.monad @)
- [_ (monad.map @ (/.acquire @@ count-clean-up)
+ [_ (monad.map @ (/.acquire //@ count-clean-up)
(list.n/range 1 expected-clean-ups))]
(wrap [])))
actual-clean-ups (thread.read clean-up-counter)]
(wrap (and (success? outcome)
(n.= expected-clean-ups
actual-clean-ups))))))
- (_.test "Can clean-up despite errors."
+ (_.test (%.name (name-of /.fail))
+ (thread.run
+ (do thread.monad
+ [clean-up-counter (thread.box 0)
+ #let [//@ @
+ count-clean-up (function (_ value)
+ (do @
+ [_ (thread.update inc clean-up-counter)]
+ (wrap (#try.Success []))))]
+ outcome (/.run @
+ (do (/.monad @)
+ [_ (monad.map @ (/.acquire //@ count-clean-up)
+ (list.n/range 1 expected-clean-ups))
+ _ (/.fail //@ (exception.construct ..oops []))]
+ (wrap [])))
+ actual-clean-ups (thread.read clean-up-counter)]
+ (wrap (and (failure? outcome)
+ (n.= expected-clean-ups
+ actual-clean-ups))))))
+ (_.test (%.name (name-of /.throw))
(thread.run
(do thread.monad
[clean-up-counter (thread.box 0)
- #let [@@ @
+ #let [//@ @
count-clean-up (function (_ value)
(do @
[_ (thread.update inc clean-up-counter)]
(wrap (#try.Success []))))]
outcome (/.run @
(do (/.monad @)
- [_ (monad.map @ (/.acquire @@ count-clean-up)
+ [_ (monad.map @ (/.acquire //@ count-clean-up)
(list.n/range 1 expected-clean-ups))
- _ (/.throw @@ oops [])]
+ _ (/.throw //@ ..oops [])]
(wrap [])))
actual-clean-ups (thread.read clean-up-counter)]
(wrap (and (failure? outcome)
(n.= expected-clean-ups
actual-clean-ups))))))
- (_.test "Errors can propagate from the cleaners."
+ (_.test (%.name (name-of /.acquire))
(thread.run
(do thread.monad
[clean-up-counter (thread.box 0)
- #let [@@ @
+ #let [//@ @
count-clean-up (function (_ value)
(do @
[_ (thread.update inc clean-up-counter)]
- (wrap (: (Try Any) (ex.throw oops [])))))]
+ (wrap (: (Try Any)
+ (exception.throw ..oops [])))))]
outcome (/.run @
(do (/.monad @)
- [_ (monad.map @ (/.acquire @@ count-clean-up)
+ [_ (monad.map @ (/.acquire //@ count-clean-up)
(list.n/range 1 expected-clean-ups))]
(wrap [])))
actual-clean-ups (thread.read clean-up-counter)]
@@ -98,14 +155,14 @@
(failure? outcome))
(n.= expected-clean-ups
actual-clean-ups))))))
- (_.test "Can lift operations."
+ (_.test (%.name (name-of /.lift))
(thread.run
(do thread.monad
[clean-up-counter (thread.box 0)
- #let [@@ @]
+ #let [//@ @]
outcome (/.run @
(do (/.monad @)
- [_ (/.lift @@ (thread.write expected-clean-ups clean-up-counter))]
+ [_ (/.lift //@ (thread.write expected-clean-ups clean-up-counter))]
(wrap [])))
actual-clean-ups (thread.read clean-up-counter)]
(wrap (and (success? outcome)