From 1790c10bd359c90ac62be2553b4c4ec49002eff9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 31 Dec 2017 23:52:25 -0400 Subject: - Added region-based resource management. --- stdlib/source/lux/control/functor.lux | 3 +- stdlib/source/lux/control/region.lux | 145 ++++++++++++++++++++++++++++++++ stdlib/test/test/lux/control/region.lux | 100 ++++++++++++++++++++++ stdlib/test/tests.lux | 3 +- 4 files changed, 249 insertions(+), 2 deletions(-) create mode 100644 stdlib/source/lux/control/region.lux create mode 100644 stdlib/test/test/lux/control/region.lux (limited to 'stdlib') 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])))) + +(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 computation) + (All [m a] + (-> (Monad m) (All [r] (Region r m a)) + (m (Error a)))) + (do Monad + [[cleaners output] (computation [[] (list)]) + results (monad.map @ (function [cleaner] (cleaner [])) + cleaners)] + (wrap (list/fold combine-outcomes output results)))) + +(def: #export (acquire Monad cleaner value) + (All [m a] (-> (Monad m) (-> a (m (Error Unit))) a + (All [r] (Region r m a)))) + (function [[region cleaners]] + (:: Monad wrap [(#.Cons (function [region] (cleaner value)) + cleaners) + (#e.Success value)]))) + +(struct: #export (Functor Functor) + (All [m] + (-> (Functor m) + (All [r] (Functor (Region r m))))) + + (def: (map f) + (function [fa] + (function [region+cleaners] + (:: Functor 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 Monad) + (All [m] + (-> (Monad m) + (All [r] (Applicative (Region r m))))) + + (def: functor + (Functor (get@ [#monad.applicative #applicative.functor] + Monad))) + + (def: (wrap value) + (function [[region cleaners]] + (:: Monad wrap [cleaners (#e.Success value)]))) + + (def: (apply ff fa) + (function [[region cleaners]] + (do Monad + [[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 Monad) + (All [m] + (-> (Monad m) + (All [r] (Monad (Region r m))))) + + (def: applicative (Applicative Monad)) + + (def: (join ffa) + (function [[region cleaners]] + (do Monad + [[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 error) + (All [m a] + (-> (Monad m) Text + (All [r] (Region r m a)))) + (function [[region cleaners]] + (:: Monad wrap [cleaners (#e.Error error)]))) + +(def: #export (throw Monad exception message) + (All [m a] + (-> (Monad m) Exception Text + (All [r] (Region r m a)))) + (fail Monad (exception message))) + +(def: #export (lift Monad operation) + (All [m a] + (-> (Monad m) (m a) + (All [r] (Region r m a)))) + (function [[region cleaners]] + (do Monad + [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 [ ] + [(def: ( result) + (All [a] (-> (Error a) Bool)) + (case result + (#e.Success _) + (#e.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 + [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 @) + [_ (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 + [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 @) + [_ (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 + [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 @) + [_ (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 + [clean-up-counter (thread.box +0) + #let [@@ @] + outcome (/.run @ + (do (/.Monad @) + [_ (/.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] -- cgit v1.2.3