diff options
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) |