- Added region-based resource management.

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]