aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/abstract/monoid.lux8
-rw-r--r--stdlib/source/lux/control/concurrency/actor.lux63
-rw-r--r--stdlib/source/lux/control/concurrency/promise.lux37
-rw-r--r--stdlib/source/lux/control/concurrency/stm.lux22
-rw-r--r--stdlib/source/lux/data/number/int.lux28
-rw-r--r--stdlib/source/lux/test.lux24
-rw-r--r--stdlib/source/test/lux.lux89
-rw-r--r--stdlib/source/test/lux/abstract.lux2
-rw-r--r--stdlib/source/test/lux/abstract/monoid.lux44
-rw-r--r--stdlib/source/test/lux/control/concurrency/actor.lux2
-rw-r--r--stdlib/source/test/lux/control/concurrency/frp.lux34
-rw-r--r--stdlib/source/test/lux/control/concurrency/promise.lux202
12 files changed, 372 insertions, 183 deletions
diff --git a/stdlib/source/lux/abstract/monoid.lux b/stdlib/source/lux/abstract/monoid.lux
index 088fda263..7f4254af3 100644
--- a/stdlib/source/lux/abstract/monoid.lux
+++ b/stdlib/source/lux/abstract/monoid.lux
@@ -9,12 +9,12 @@
(: (-> a a a)
compose))
-(def: #export (compose Monoid<l> Monoid<r>)
+(def: #export (compose left right)
(All [l r] (-> (Monoid l) (Monoid r) (Monoid [l r])))
(structure
(def: identity
- [(:: Monoid<l> identity) (:: Monoid<r> identity)])
+ [(:: left identity) (:: right identity)])
(def: (compose [lL rL] [lR rR])
- [(:: Monoid<l> compose lL lR)
- (:: Monoid<r> compose rL rR)])))
+ [(:: left compose lL lR)
+ (:: right compose rL rR)])))
diff --git a/stdlib/source/lux/control/concurrency/actor.lux b/stdlib/source/lux/control/concurrency/actor.lux
index a4c345967..0f38c4c3d 100644
--- a/stdlib/source/lux/control/concurrency/actor.lux
+++ b/stdlib/source/lux/control/concurrency/actor.lux
@@ -3,6 +3,7 @@
[abstract
monad]
[control
+ [pipe (#+ case>)]
["." function]
["." try (#+ Try)]
["." exception (#+ exception:)]
@@ -49,13 +50,16 @@
(-> (Rec Mailbox
[(Promise [a Mailbox])
(Resolver [a Mailbox])])
- (List a)))
- (case (promise.poll read)
- (#.Some [head tail])
- (#.Cons head (pending tail))
-
- #.None
- #.Nil))
+ (IO (List a))))
+ (do io.monad
+ [current (promise.poll read)]
+ (case current
+ (#.Some [head tail])
+ (:: @ map (|>> (#.Cons head))
+ (pending tail))
+
+ #.None
+ (wrap #.Nil))))
(abstract: #export (Actor s)
{#.doc "An actor, defined as all the necessities it requires."}
@@ -101,7 +105,10 @@
(do @
[_ (end error state)]
(let [[_ resolve] (get@ #obituary (:representation self))]
- (exec (io.run (resolve [error state (#.Cons head (..pending tail))]))
+ (exec (io.run
+ (do io.monad
+ [pending (..pending tail)]
+ (resolve [error state (#.Cons head pending)])))
(wrap []))))
(#try.Success state')
@@ -111,17 +118,19 @@
(def: #export (alive? actor)
(All [s] (-> (Actor s) (IO Bit)))
(let [[obituary _] (get@ #obituary (:representation actor))]
- (io.io (case (promise.poll obituary)
- #.None
- yes
+ (|> obituary
+ promise.poll
+ (:: io.functor map
+ (|>> (case> #.None
+ yes
- _
- no))))
+ _
+ no))))))
(def: #export (obituary actor)
(All [s] (-> (Actor s) (IO (Maybe (Obituary s)))))
(let [[obituary _] (get@ #obituary (:representation actor))]
- (io.io (promise.poll obituary))))
+ (promise.poll obituary)))
(def: #export (send message actor)
{#.doc "Communicate with an actor through message passing."}
@@ -133,18 +142,20 @@
(do @
[|mailbox|&resolve (atom.read (get@ #mailbox (:representation actor)))]
(loop [[|mailbox| resolve] |mailbox|&resolve]
- (case (promise.poll |mailbox|)
- #.None
- (do @
- [resolved? (resolve entry)]
- (if resolved?
- (do @
- [_ (atom.write (product.right entry) (get@ #mailbox (:representation actor)))]
- (wrap true))
- (recur |mailbox|&resolve)))
-
- (#.Some [_ |mailbox|'])
- (recur |mailbox|')))))
+ (do @
+ [|mailbox| (promise.poll |mailbox|)]
+ (case |mailbox|
+ #.None
+ (do @
+ [resolved? (resolve entry)]
+ (if resolved?
+ (do @
+ [_ (atom.write (product.right entry) (get@ #mailbox (:representation actor)))]
+ (wrap true))
+ (recur |mailbox|&resolve)))
+
+ (#.Some [_ |mailbox|'])
+ (recur |mailbox|'))))))
(wrap false))))
)
)
diff --git a/stdlib/source/lux/control/concurrency/promise.lux b/stdlib/source/lux/control/concurrency/promise.lux
index 49d4247b4..def999622 100644
--- a/stdlib/source/lux/control/concurrency/promise.lux
+++ b/stdlib/source/lux/control/concurrency/promise.lux
@@ -5,6 +5,7 @@
[apply (#+ Apply)]
["." monad (#+ Monad do)]]
[control
+ [pipe (#+ case>)]
["." function]
["." io (#+ IO io)]]
[data
@@ -55,11 +56,10 @@
(def: #export poll
{#.doc "Polls a promise's value."}
- (All [a] (-> (Promise a) (Maybe a)))
+ (All [a] (-> (Promise a) (IO (Maybe a))))
(|>> :representation
atom.read
- io.run
- product.left))
+ (:: io.functor map product.left)))
(def: #export (await f promise)
(All [a] (-> (-> a (IO Any)) (Promise a) (IO Any)))
@@ -76,23 +76,28 @@
(await f (:abstraction promise)))))))
)
-(def: #export (resolved? promise)
+(def: #export resolved?
{#.doc "Checks whether a promise's value has already been resolved."}
- (All [a] (-> (Promise a) Bit))
- (case (poll promise)
- #.None
- #0
-
- (#.Some _)
- #1))
-
-(structure: #export functor (Functor Promise)
+ (All [a] (-> (Promise a) (IO Bit)))
+ (|>> ..poll
+ (:: io.functor map
+ (|>> (case> #.None
+ #0
+
+ (#.Some _)
+ #1)))))
+
+(structure: #export functor
+ (Functor Promise)
+
(def: (map f fa)
(let [[fb resolve] (..promise [])]
(exec (io.run (await (|>> f resolve) fa))
fb))))
-(structure: #export apply (Apply Promise)
+(structure: #export apply
+ (Apply Promise)
+
(def: &functor ..functor)
(def: (apply ff fa)
@@ -102,7 +107,9 @@
ff))
fb))))
-(structure: #export monad (Monad Promise)
+(structure: #export monad
+ (Monad Promise)
+
(def: &functor ..functor)
(def: wrap ..resolved)
diff --git a/stdlib/source/lux/control/concurrency/stm.lux b/stdlib/source/lux/control/concurrency/stm.lux
index 9d97b389f..783bc2117 100644
--- a/stdlib/source/lux/control/concurrency/stm.lux
+++ b/stdlib/source/lux/control/concurrency/stm.lux
@@ -202,16 +202,18 @@
(do io.monad
[|commits|&resolve (atom.read pending-commits)]
(loop [[|commits| resolve] |commits|&resolve]
- (case (promise.poll |commits|)
- #.None
- (do io.monad
- [resolved? (resolve entry)]
- (if resolved?
- (atom.write (product.right entry) pending-commits)
- (recur |commits|&resolve)))
-
- (#.Some [head tail])
- (recur tail))))))
+ (do @
+ [|commits| (promise.poll |commits|)]
+ (case |commits|
+ #.None
+ (do io.monad
+ [resolved? (resolve entry)]
+ (if resolved?
+ (atom.write (product.right entry) pending-commits)
+ (recur |commits|&resolve)))
+
+ (#.Some [head tail])
+ (recur tail)))))))
(def: (process-commit commit)
(All [a] (-> (Commit a) (IO Any)))
diff --git a/stdlib/source/lux/data/number/int.lux b/stdlib/source/lux/data/number/int.lux
index 67f2c8177..80842692e 100644
--- a/stdlib/source/lux/data/number/int.lux
+++ b/stdlib/source/lux/data/number/int.lux
@@ -128,25 +128,35 @@
(-> Int Frac)
(|>> "lux i64 f64"))
-(structure: #export equivalence (Equivalence Int)
+(structure: #export equivalence
+ (Equivalence Int)
+
(def: = ..=))
-(structure: #export order (Order Int)
+(structure: #export order
+ (Order Int)
+
(def: &equivalence ..equivalence)
(def: < ..<))
-(structure: #export enum (Enum Int)
+(structure: #export enum
+ (Enum Int)
+
(def: &order ..order)
(def: succ inc)
(def: pred dec))
-(structure: #export interval (Interval Int)
+(structure: #export interval
+ (Interval Int)
+
(def: &enum ..enum)
(def: top +9,223,372,036,854,775,807)
(def: bottom -9,223,372,036,854,775,808))
(template [<name> <compose> <identity>]
- [(structure: #export <name> (Monoid Int)
+ [(structure: #export <name>
+ (Monoid Int)
+
(def: identity <identity>)
(def: compose <compose>))]
@@ -189,7 +199,9 @@
(#try.Success (..* sign output)))))
(template [<struct> <base> <to-character> <to-value> <error>]
- [(structure: #export <struct> (Codec Text Int)
+ [(structure: #export <struct>
+ (Codec Text Int)
+
(def: (encode value)
(if (..= +0 value)
"+0"
@@ -220,6 +232,8 @@
[hex +16 //nat.hexadecimal-character //nat.hexadecimal-value "Invalid hexadecimal syntax for Int: "]
)
-(structure: #export hash (Hash Int)
+(structure: #export hash
+ (Hash Int)
+
(def: &equivalence ..equivalence)
(def: hash .nat))
diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux
index 18f487ff4..96535b886 100644
--- a/stdlib/source/lux/test.lux
+++ b/stdlib/source/lux/test.lux
@@ -19,7 +19,7 @@
["." text
["%" format (#+ format)]]
[collection
- ["." list ("#@." functor)]
+ ["." list ("#@." functor fold)]
["." set (#+ Set)]]]
[time
["." instant]
@@ -308,3 +308,25 @@
(~ (code.text module))
(.list (~+ coverage))
(~ test)))))))
+
+(def: #export (in-parallel tests)
+ (-> (List Test) Test)
+ (do random.monad
+ [seed random.nat
+ #let [prng (random.pcg-32 [..pcg-32-magic-inc seed])
+ run! (: (-> Test Assertion)
+ (function (_ test)
+ (|> test
+ (random.run prng)
+ product.right
+ io.io
+ promise.future
+ promise@join)))]]
+ (wrap (do promise.monad
+ [assertions (monad.seq @ (list@map run! tests))]
+ (wrap [(|> assertions
+ (list@map product.left)
+ (list@fold ..add-counters ..start))
+ (|> assertions
+ (list@map product.right)
+ (text.join-with ..separator))])))))
diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux
index c03076d26..c43c2abf4 100644
--- a/stdlib/source/test/lux.lux
+++ b/stdlib/source/test/lux.lux
@@ -13,7 +13,7 @@
[predicate (#+ Predicate)]]
[control
["." io (#+ io)]
- ["." function
+ [function
[mixin (#+)]]
[parser
[cli (#+ program:)]]]
@@ -49,28 +49,37 @@
[php (#+)]
[common-lisp (#+)]
[scheme (#+)]]
- [tool
- [compiler
- [phase
- [generation
- [jvm (#+)
- <host-modules>]
- [js (#+)
- <host-modules>]
- [python (#+)
- <host-modules>]
- [lua (#+)
- <host-modules>]
- [ruby (#+)
- <host-modules>]
- [php (#+)
- <host-modules>]
- [common-lisp (#+)
- <host-modules>]
- [scheme (#+)
- <host-modules>]]]]]
+ ## [tool
+ ## [compiler
+ ## [language
+ ## [lux
+ ## [phase
+ ## [generation
+ ## [jvm (#+)
+ ## <host-modules>]
+ ## [js (#+)
+ ## <host-modules>]
+ ## [python (#+)
+ ## <host-modules>]
+ ## [lua (#+)
+ ## <host-modules>]
+ ## [ruby (#+)
+ ## <host-modules>]
+ ## ## [php (#+)
+ ## ## <host-modules>]
+ ## ## [common-lisp (#+)
+ ## ## <host-modules>]
+ ## ## [scheme (#+)
+ ## ## <host-modules>]
+ ## ]
+ ## [extension
+ ## [generation
+ ## [jvm (#+)]
+ ## [js (#+)]
+ ## [python (#+)]
+ ## [lua (#+)]
+ ## [ruby (#+)]]]]]]]]
## [control
- ## ["._" concatenative]
## ["._" predicate]
## [function
## ["._" contract]]
@@ -131,7 +140,7 @@
["#." macro]
["#." math]
["#." time]
- ["#." tool]
+ ## ["#." tool]
["#." type]
["#." world]
["#." host]
@@ -154,8 +163,6 @@
($_ _.and
(_.test "Every value is identical to itself."
(is? self self))
- (_.test "The identity function doesn't change values in any way."
- (is? self (function.identity self)))
(do @
[other (random.unicode 1)]
(_.test "Values created separately can't be identical."
@@ -357,27 +364,23 @@
..templates)
(<| (_.context "Cross-platform support.")
..cross-platform-support)))
- (!bundle ($_ _.and
- /abstract.test
- /control.test
- /data.test
- /macro.test
- /math.test))
- (!bundle ($_ _.and
- /time.test
- /tool.test
- /type.test
- /world.test))
- (!bundle ($_ _.and
- /host.test
- /extension.test
- ($_ _.and
- /target/jvm.test)))
+ (_.in-parallel (list /abstract.test
+ /control.test
+ /data.test
+ /macro.test
+ /math.test
+ /time.test
+ ## /tool.test
+ /type.test
+ /world.test
+ /host.test
+ /extension.test
+ /target/jvm.test
+ ))
)))
(program: args
(<| io
_.run!
- ## (_.times 100)
- (_.seed 8070500311708372420)
+ (_.times 100)
..test))
diff --git a/stdlib/source/test/lux/abstract.lux b/stdlib/source/test/lux/abstract.lux
index 4becb6344..b9aa18c9c 100644
--- a/stdlib/source/test/lux/abstract.lux
+++ b/stdlib/source/test/lux/abstract.lux
@@ -9,6 +9,7 @@
["#." functor]
["#." interval]
["#." monad]
+ ["#." monoid]
["#." order]
["#." predicate]])
@@ -22,6 +23,7 @@
/functor.test
/interval.test
/monad.test
+ /monoid.test
/order.test
/predicate.test
))
diff --git a/stdlib/source/test/lux/abstract/monoid.lux b/stdlib/source/test/lux/abstract/monoid.lux
index 5353e29cd..e1271ed2f 100644
--- a/stdlib/source/test/lux/abstract/monoid.lux
+++ b/stdlib/source/test/lux/abstract/monoid.lux
@@ -1,31 +1,55 @@
(.module:
[lux #*
- ["%" data/text/format (#+ format)]
["_" test (#+ Test)]
- [abstract/monad (#+ do)]
- [math
- ["." random (#+ Random)]]
+ [abstract
+ [monad (#+ do)]]
[control
- ["." function]]]
+ ["." function]]
+ [data
+ [number
+ ["." nat]
+ ["." int]]]
+ [math
+ ["." random (#+ Random)]]]
{1
- ["." / (#+ Monoid)
+ ["." /
[//
[equivalence (#+ Equivalence)]]]})
(def: #export (spec (^open "/@.") (^open "/@.") gen-sample)
- (All [a] (-> (Equivalence a) (Monoid a) (Random a) Test))
+ (All [a] (-> (Equivalence a) (/.Monoid a) (Random a) Test))
(do random.monad
[sample gen-sample
left gen-sample
mid gen-sample
right gen-sample]
- (<| (_.context (%.name (name-of /.Monoid)))
+ (<| (_.with-cover [/.Monoid])
($_ _.and
(_.test "Left identity."
- (/@= sample (/@compose /@identity sample)))
+ (/@= sample
+ (/@compose /@identity sample)))
(_.test "Right identity."
- (/@= sample (/@compose sample /@identity)))
+ (/@= sample
+ (/@compose sample /@identity)))
(_.test "Associativity."
(/@= (/@compose left (/@compose mid right))
(/@compose (/@compose left mid) right)))
))))
+
+(def: #export test
+ Test
+ (do random.monad
+ [natL random.nat
+ natR random.nat
+ intL random.int
+ intR random.int]
+ (<| (_.covering /._)
+ ($_ _.and
+ (_.cover [/.compose]
+ (let [[natLR intLR] (:: (/.compose nat.addition int.multiplication) compose
+ [natL intL] [natR intR])]
+ (and (nat.= (:: nat.addition compose natL natR)
+ natLR)
+ (int.= (:: int.multiplication compose intL intR)
+ intLR))))
+ ))))
diff --git a/stdlib/source/test/lux/control/concurrency/actor.lux b/stdlib/source/test/lux/control/concurrency/actor.lux
index 741b848cb..fe9362b07 100644
--- a/stdlib/source/test/lux/control/concurrency/actor.lux
+++ b/stdlib/source/test/lux/control/concurrency/actor.lux
@@ -91,7 +91,7 @@
(promise.future (write cause)))}
write)
_ (/.poison actor)]
- (io.io (promise.poll read))))]
+ (promise.poll read)))]
(_.claim [/.poisoned]
(case result
(#.Some error)
diff --git a/stdlib/source/test/lux/control/concurrency/frp.lux b/stdlib/source/test/lux/control/concurrency/frp.lux
index 8752a195f..e6c8c179d 100644
--- a/stdlib/source/test/lux/control/concurrency/frp.lux
+++ b/stdlib/source/test/lux/control/concurrency/frp.lux
@@ -34,14 +34,17 @@
(def: comparison
(Comparison /.Channel)
(function (_ == left right)
- (case [(promise.poll left)
- (promise.poll right)]
- [(#.Some (#.Some [left _]))
- (#.Some (#.Some [right _]))]
- (== left right)
-
- _
- false)))
+ (io.run
+ (do io.monad
+ [?left (promise.poll left)
+ ?right (promise.poll right)]
+ (wrap (case [?left ?right]
+ [(#.Some (#.Some [left _]))
+ (#.Some (#.Some [right _]))]
+ (== left right)
+
+ _
+ false))))))
(def: #export test
Test
@@ -72,12 +75,15 @@
_ (:: sink close)]
(wrap channel)))
(#try.Success channel)
- (case (promise.poll channel)
- (#.Some (#.Some [actual _]))
- (n.= sample actual)
-
- _
- false)
+ (io.run
+ (do io.monad
+ [?actual (promise.poll channel)]
+ (wrap (case ?actual
+ (#.Some (#.Some [actual _]))
+ (n.= sample actual)
+
+ _
+ false))))
(#try.Failure error)
false))
diff --git a/stdlib/source/test/lux/control/concurrency/promise.lux b/stdlib/source/test/lux/control/concurrency/promise.lux
index 5b412e212..3e2d8982b 100644
--- a/stdlib/source/test/lux/control/concurrency/promise.lux
+++ b/stdlib/source/test/lux/control/concurrency/promise.lux
@@ -1,73 +1,171 @@
(.module:
[lux #*
["_" test (#+ Test)]
- [abstract/monad (#+ do)]
+ [abstract
+ [monad (#+ do)]
+ {[0 #test]
+ [/
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]]}]
[control
- pipe
+ [pipe (#+ case>)]
["." io]]
- ["%" data/text/format (#+ format)]
+ [data
+ [number
+ ["n" nat]
+ ["i" int]]]
+ [time
+ ["." instant]
+ ["." duration]]
[math
- ["r" random]]]
+ ["." random]]]
{1
- ["." / ("#@." monad)]})
+ ["." /
+ [//
+ ["." atom (#+ Atom)]]]})
+
+(def: injection
+ (Injection /.Promise)
+ /.resolved)
+
+(def: comparison
+ (Comparison /.Promise)
+ (function (_ == left right)
+ (io.run
+ (do io.monad
+ [?left (/.poll left)
+ ?right (/.poll right)]
+ (wrap (case [?left ?right]
+ [(#.Some left)
+ (#.Some right)]
+ (== left right)
+
+ _
+ false))))))
(def: #export test
Test
- (do r.monad
- [_ (wrap [])]
- (<| (_.context (%.name (name-of /.Promise)))
+ (<| (_.covering /._)
+ (do random.monad
+ [to-wait (|> random.nat (:: @ map (|>> (n.% 100) (n.max 10))))
+ #let [extra-time (n.* 2 to-wait)]
+ expected random.nat
+ dummy random.nat
+ #let [not-dummy (|> random.nat (random.filter (|>> (n.= dummy) not)))]
+ leftE not-dummy
+ rightE not-dummy]
($_ _.and
+ (_.with-cover [/.functor]
+ ($functor.spec ..injection ..comparison /.functor))
+ (_.with-cover [/.apply]
+ ($apply.spec ..injection ..comparison /.apply))
+ (_.with-cover [/.monad]
+ ($monad.spec ..injection ..comparison /.monad))
+
(wrap (do /.monad
- [running? (/.future (io.io #1))]
- (_.assert "Can run IO actions in separate threads."
- running?)))
-
+ [#let [[promise resolver] (: [(/.Promise Nat) (/.Resolver Nat)]
+ (/.promise []))]
+ resolved? (/.future (resolver expected))
+ actual promise]
+ (_.claim [/.Promise /.Resolver /.promise]
+ (and resolved?
+ (n.= expected actual)))))
(wrap (do /.monad
- [_ (/.wait 500)]
- (_.assert "Can wait for a specified amount of time."
- #1)))
-
+ [actual (/.resolved expected)]
+ (_.claim [/.resolved]
+ (n.= expected actual))))
(wrap (do /.monad
- [[left right] (/.and (/.future (io.io #1))
- (/.future (io.io #0)))]
- (_.assert "Can combine promises sequentially."
- (and left (not right)))))
-
+ [actual (/.future (io.io expected))]
+ (_.claim [/.future]
+ (n.= expected actual))))
(wrap (do /.monad
- [?left (/.or (/.delay 100 #1)
- (/.delay 200 #0))
- ?right (/.or (/.delay 200 #1)
- (/.delay 100 #0))]
- (_.assert "Can combine promises alternatively."
- (case [?left ?right]
- [(#.Left #1) (#.Right #0)]
- #1
-
- _
- #0))))
-
+ [pre (/.future instant.now)
+ actual (/.schedule to-wait (io.io expected))
+ post (/.future instant.now)]
+ (_.claim [/.schedule]
+ (and (n.= expected actual)
+ (i.>= (.int to-wait)
+ (duration.to-millis (instant.span pre post)))))))
(wrap (do /.monad
- [?left (/.either (/.delay 100 #1)
- (/.delay 200 #0))
- ?right (/.either (/.delay 200 #1)
- (/.delay 100 #0))]
- (_.assert "Can combine promises alternatively [Part 2]."
- (and ?left (not ?right)))))
+ [pre (/.future instant.now)
+ _ (/.wait to-wait)
+ post (/.future instant.now)]
+ (_.claim [/.wait]
+ (i.>= (.int to-wait)
+ (duration.to-millis (instant.span pre post))))))
+ (wrap (do /.monad
+ [[leftA rightA] (/.and (/.future (io.io leftE))
+ (/.future (io.io rightE)))]
+ (_.claim [/.and]
+ (n.= (n.+ leftE rightE)
+ (n.+ leftA rightA)))))
+ (wrap (do /.monad
+ [pre (/.future instant.now)
+ actual (/.delay to-wait expected)
+ post (/.future instant.now)]
+ (_.claim [/.delay]
+ (and (n.= expected actual)
+ (i.>= (.int to-wait)
+ (duration.to-millis (instant.span pre post)))))))
+ (wrap (do /.monad
+ [?left (/.or (/.delay 10 leftE)
+ (/.delay 20 dummy))
+ ?right (/.or (/.delay 20 dummy)
+ (/.delay 10 rightE))]
+ (_.claim [/.or]
+ (case [?left ?right]
+ [(#.Left leftA) (#.Right rightA)]
+ (n.= (n.+ leftE rightE)
+ (n.+ leftA rightA))
- (_.test "Can poll a promise for its value."
- (and (|> (/.poll (/@wrap #1))
- (case> (#.Some #1) #1 _ #0))
- (|> (/.poll (/.delay 200 #1))
- (case> #.None #1 _ #0))))
+ _
+ false))))
+ (wrap (do /.monad
+ [leftA (/.either (/.delay 10 leftE)
+ (/.delay 20 dummy))
+ rightA (/.either (/.delay 20 dummy)
+ (/.delay 10 rightE))]
+ (_.claim [/.either]
+ (n.= (n.+ leftE rightE)
+ (n.+ leftA rightA)))))
+ (wrap (do /.monad
+ [?actual (/.future (/.poll (/.resolved expected)))
+ #let [[promise resolver] (: [(/.Promise Nat) (/.Resolver Nat)]
+ (/.promise []))]
+ ?never (/.future (/.poll promise))]
+ (_.claim [/.poll]
+ (case [?actual ?never]
+ [(#.Some actual) #.None]
+ (n.= expected actual)
+ _
+ false))))
+ (wrap (do /.monad
+ [yep (/.future (/.resolved? (/.resolved expected)))
+ #let [[promise resolver] (: [(/.Promise Nat) (/.Resolver Nat)]
+ (/.promise []))]
+ nope (/.future (/.resolved? promise))]
+ (_.claim [/.resolved?]
+ (and yep
+ (not nope)))))
(wrap (do /.monad
- [?none (/.time-out 100 (/.delay 200 #1))
- ?some (/.time-out 200 (/.delay 100 #1))]
- (_.assert "Can establish maximum waiting times for promises to be fulfilled."
- (case [?none ?some]
- [#.None (#.Some #1)]
- #1
+ [?none (/.time-out to-wait (/.delay extra-time dummy))
+ ?actual (/.time-out extra-time (/.delay to-wait expected))]
+ (_.claim [/.time-out]
+ (case [?none ?actual]
+ [#.None (#.Some actual)]
+ (n.= expected actual)
- _
- #0))))
+ _
+ false))))
+ (wrap (do /.monad
+ [#let [box (: (Atom Nat)
+ (atom.atom dummy))]
+ _ (/.future (/.await (function (_ value)
+ (atom.write value box))
+ (/.resolved expected)))
+ actual (/.future (atom.read box))]
+ (_.claim [/.await]
+ (n.= expected actual))))
))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 03:58:14 +0000