aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/control/functor.lux3
-rw-r--r--stdlib/source/lux/control/region.lux145
-rw-r--r--stdlib/test/test/lux/control/region.lux100
-rw-r--r--stdlib/test/tests.lux3
4 files changed, 249 insertions, 2 deletions
diff --git a/stdlib/source/lux/control/functor.lux b/stdlib/source/lux/control/functor.lux
index 38b3f0ee3..d6ac8c58f 100644
--- a/stdlib/source/lux/control/functor.lux
+++ b/stdlib/source/lux/control/functor.lux
@@ -2,7 +2,8 @@
(sig: #export (Functor f)
(: (All [a b]
- (-> (-> a b) (f a) (f b)))
+ (-> (-> a b)
+ (-> (f a) (f b))))
map))
(type: #export (Fix f)
diff --git a/stdlib/source/lux/control/region.lux b/stdlib/source/lux/control/region.lux
new file mode 100644
index 000000000..4be0e722e
--- /dev/null
+++ b/stdlib/source/lux/control/region.lux
@@ -0,0 +1,145 @@
+(.module:
+ lux
+ (lux (control [functor #+ Functor]
+ [applicative #+ Applicative]
+ [monad #+ Monad do]
+ ["ex" exception #+ Exception exception:])
+ (data ["e" error #+ Error]
+ text/format
+ (coll [list "list/" Fold<List>]))))
+
+(type: (Cleaner r m)
+ (-> r (m (Error Unit))))
+
+(type: #export (Region r m a)
+ (-> [r (List (Cleaner r m))]
+ (m [(List (Cleaner r m))
+ (Error a)])))
+
+(exception: #export Clean-Up-Error)
+
+(def: separator
+ Text
+ (format "\n"
+ "-----------------------------------------\n"
+ "-----------------------------------------\n"
+ "-----------------------------------------\n"
+ "\n"))
+
+(def: (combine-outcomes clean-up output)
+ (All [a] (-> (Error Unit) (Error a) (Error a)))
+ (case clean-up
+ (#e.Success _)
+ output
+
+ (#e.Error error|clean-up)
+ (ex.throw Clean-Up-Error
+ (format error|clean-up
+ (case output
+ (#e.Success _)
+ ""
+
+ (#e.Error error|output)
+ (format separator
+ error|output))))))
+
+(def: #export (run Monad<m> computation)
+ (All [m a]
+ (-> (Monad m) (All [r] (Region r m a))
+ (m (Error a))))
+ (do Monad<m>
+ [[cleaners output] (computation [[] (list)])
+ results (monad.map @ (function [cleaner] (cleaner []))
+ cleaners)]
+ (wrap (list/fold combine-outcomes output results))))
+
+(def: #export (acquire Monad<m> cleaner value)
+ (All [m a] (-> (Monad m) (-> a (m (Error Unit))) a
+ (All [r] (Region r m a))))
+ (function [[region cleaners]]
+ (:: Monad<m> wrap [(#.Cons (function [region] (cleaner value))
+ cleaners)
+ (#e.Success value)])))
+
+(struct: #export (Functor<Region> Functor<m>)
+ (All [m]
+ (-> (Functor m)
+ (All [r] (Functor (Region r m)))))
+
+ (def: (map f)
+ (function [fa]
+ (function [region+cleaners]
+ (:: Functor<m> map
+ (function [[cleaners' temp]]
+ [cleaners' (case temp
+ (#e.Success value)
+ (#e.Success (f value))
+
+ (#e.Error error)
+ (#e.Error error))])
+ (fa region+cleaners))))))
+
+(struct: #export (Applicative<Region> Monad<m>)
+ (All [m]
+ (-> (Monad m)
+ (All [r] (Applicative (Region r m)))))
+
+ (def: functor
+ (Functor<Region> (get@ [#monad.applicative #applicative.functor]
+ Monad<m>)))
+
+ (def: (wrap value)
+ (function [[region cleaners]]
+ (:: Monad<m> wrap [cleaners (#e.Success value)])))
+
+ (def: (apply ff fa)
+ (function [[region cleaners]]
+ (do Monad<m>
+ [[cleaners ef] (ff [region cleaners])
+ [cleaners ea] (fa [region cleaners])]
+ (case [ef ea]
+ [(#e.Success f) (#e.Success a)]
+ (wrap [cleaners (#e.Success (f a))])
+
+ (^or [(#e.Error error) _] [_ (#e.Error error)])
+ (wrap [cleaners (#e.Error error)]))))))
+
+(struct: #export (Monad<Region> Monad<m>)
+ (All [m]
+ (-> (Monad m)
+ (All [r] (Monad (Region r m)))))
+
+ (def: applicative (Applicative<Region> Monad<m>))
+
+ (def: (join ffa)
+ (function [[region cleaners]]
+ (do Monad<m>
+ [[cleaners efa] (ffa [region cleaners])]
+ (case efa
+ (#e.Success fa)
+ (fa [region cleaners])
+
+ (#e.Error error)
+ (wrap [cleaners (#e.Error error)]))))))
+
+(def: #export (fail Monad<m> error)
+ (All [m a]
+ (-> (Monad m) Text
+ (All [r] (Region r m a))))
+ (function [[region cleaners]]
+ (:: Monad<m> wrap [cleaners (#e.Error error)])))
+
+(def: #export (throw Monad<m> exception message)
+ (All [m a]
+ (-> (Monad m) Exception Text
+ (All [r] (Region r m a))))
+ (fail Monad<m> (exception message)))
+
+(def: #export (lift Monad<m> operation)
+ (All [m a]
+ (-> (Monad m) (m a)
+ (All [r] (Region r m a))))
+ (function [[region cleaners]]
+ (do Monad<m>
+ [output operation]
+ (wrap [cleaners (#e.Success output)]))))
diff --git a/stdlib/test/test/lux/control/region.lux b/stdlib/test/test/lux/control/region.lux
new file mode 100644
index 000000000..8de498dce
--- /dev/null
+++ b/stdlib/test/test/lux/control/region.lux
@@ -0,0 +1,100 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ ["/" region]
+ [thread #+ Thread]
+ ["ex" exception #+ exception:])
+ (data ["e" error #+ Error]
+ (coll [list])
+ text/format)
+ ["r" math/random])
+ lux/test)
+
+(exception: Oops)
+
+(do-template [<name> <success> <error>]
+ [(def: (<name> result)
+ (All [a] (-> (Error a) Bool))
+ (case result
+ (#e.Success _) <success>
+ (#e.Error _) <error>))]
+
+ [success? true false]
+ [error? false true]
+ )
+
+(context: "Regions."
+ (<| (times +100)
+ (do @
+ [expected-clean-ups (|> r.nat (:: @ map (n/% +100)))]
+ ($_ seq
+ (test "Clean-up functions are always run when region execution is done."
+ (thread.run
+ (do thread.Monad<Thread>
+ [clean-up-counter (thread.box +0)
+ #let [@@ @
+ count-clean-up (function [value]
+ (do @
+ [_ (thread.update n/inc clean-up-counter)]
+ (wrap (#e.Success []))))]
+ outcome (/.run @
+ (do (/.Monad<Region> @)
+ [_ (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."
+ (thread.run
+ (do thread.Monad<Thread>
+ [clean-up-counter (thread.box +0)
+ #let [@@ @
+ count-clean-up (function [value]
+ (do @
+ [_ (thread.update n/inc clean-up-counter)]
+ (wrap (#e.Success []))))]
+ outcome (/.run @
+ (do (/.Monad<Region> @)
+ [_ (monad.map @ (/.acquire @@ count-clean-up)
+ (list.n/range +1 expected-clean-ups))
+ _ (/.throw @@ Oops "")]
+ (wrap [])))
+ actual-clean-ups (thread.read clean-up-counter)]
+ (wrap (and (error? outcome)
+ (n/= expected-clean-ups
+ actual-clean-ups))))))
+ (test "Errors can propagate from the cleaners."
+ (thread.run
+ (do thread.Monad<Thread>
+ [clean-up-counter (thread.box +0)
+ #let [@@ @
+ count-clean-up (function [value]
+ (do @
+ [_ (thread.update n/inc clean-up-counter)]
+ (wrap (: (Error Unit) (ex.throw Oops "")))))]
+ outcome (/.run @
+ (do (/.Monad<Region> @)
+ [_ (monad.map @ (/.acquire @@ count-clean-up)
+ (list.n/range +1 expected-clean-ups))]
+ (wrap [])))
+ actual-clean-ups (thread.read clean-up-counter)]
+ (wrap (and (or (n/= +0 expected-clean-ups)
+ (error? outcome))
+ (n/= expected-clean-ups
+ actual-clean-ups))))))
+ (test "Can lift operations."
+ (thread.run
+ (do thread.Monad<Thread>
+ [clean-up-counter (thread.box +0)
+ #let [@@ @]
+ outcome (/.run @
+ (do (/.Monad<Region> @)
+ [_ (/.lift @@ (thread.write expected-clean-ups clean-up-counter))]
+ (wrap [])))
+ actual-clean-ups (thread.read clean-up-counter)]
+ (wrap (and (success? outcome)
+ (n/= expected-clean-ups
+ actual-clean-ups))))))
+ ))))
diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux
index 87f9c913d..26a4212cc 100644
--- a/stdlib/test/tests.lux
+++ b/stdlib/test/tests.lux
@@ -22,7 +22,8 @@
["_." writer]
["_." state]
["_." parser]
- ["_." thread])
+ ["_." thread]
+ ["_." region])
(data ["_." bit]
["_." bool]
["_." error]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 16:52:32 +0000