Implement supervise with generalBracket

Author: natefaubion

src/Control/Monad/Aff.js

@@ -168,45 +168,47 @@ var Aff = function () {
         return count === 0;
       },
       killAll: function (killError, cb) {
-        var killCount = 0;
-        var kills     = {};
+        return function () {
+          var killCount = 0;
+          var kills     = {};
 
-        function kill(fid) {
-          kills[fid] = fibers[fid].kill(killError, function (result) {
-            return function () {
-              delete kills[fid];
-              killCount--;
-              if (util.isLeft(result) && util.fromLeft(result)) {
-                setTimeout(function () {
-                  throw util.fromLeft(result);
-                }, 0);
-              }
-              if (killCount === 0) {
-                cb();
-              }
-            };
-          })();
-        }
+          function kill(fid) {
+            kills[fid] = fibers[fid].kill(killError, function (result) {
+              return function () {
+                delete kills[fid];
+                killCount--;
+                if (util.isLeft(result) && util.fromLeft(result)) {
+                  setTimeout(function () {
+                    throw util.fromLeft(result);
+                  }, 0);
+                }
+                if (killCount === 0) {
+                  cb();
+                }
+              };
+            })();
+          }
 
-        for (var k in fibers) {
-          if (fibers.hasOwnProperty(k)) {
-            killCount++;
-            kill(k);
+          for (var k in fibers) {
+            if (fibers.hasOwnProperty(k)) {
+              killCount++;
+              kill(k);
+            }
           }
-        }
 
-        fibers  = {};
-        fiberId = 0;
-        count   = 0;
+          fibers  = {};
+          fiberId = 0;
+          count   = 0;
 
-        return function (error) {
-          return new Aff(SYNC, function () {
-            for (var k in kills) {
-              if (kills.hasOwnProperty(k)) {
-                kills[k]();
+          return function (error) {
+            return new Aff(SYNC, function () {
+              for (var k in kills) {
+                if (kills.hasOwnProperty(k)) {
+                  kills[k]();
+                }
               }
-            }
-          });
+            });
+          };
         };
       }
     };
@@ -1046,64 +1048,18 @@ exports._makeFiber = function (util, aff) {
   };
 };
 
-exports._supervise = function (util, aff) {
-  return Aff.Async(function (cb) {
-    return function () {
-      var supervisor = Aff.Supervisor(util);
-      var fiber      = Aff.Fiber(util, supervisor, aff);
-      var killing    = false;
-      var cancelCb   = fiber.onComplete({
-        rethrow: false,
-        handler: function (result) {
-          return function () {
-            killing = true;
-            supervisor.killAll(new Error("[Aff] Child fiber outlived parent"), cb(result));
-          };
-        }
-      })();
-
-      fiber.run();
-
-      return function (killError) {
-        return Aff.Async(function (killCb) {
-          return function () {
-            if (killing) {
-              return Aff.nonCanceler;
-            }
-            cancelCb();
-
-            var killResult = null;
-            var killedAll  = false;
-
-            var canceler1  = fiber.kill(killError, function (result) {
-              return function () {
-                if (killedAll) {
-                  killCb(result)();
-                } else {
-                  killResult = result;
-                }
-              };
-            })();
-
-            var canceler2  = supervisor.killAll(killError, function () {
-              if (killResult) {
-                killCb(killResult)();
-              } else {
-                killedAll = true;
-              }
-            });
-
-            return function (/* unused */) {
-              return Aff.Sync(function () {
-                canceler1();
-                canceler2();
-              });
-            };
-          };
-        });
-      };
+exports._makeSupervisedFiber = function (util, aff) {
+  return function () {
+    var supervisor = Aff.Supervisor(util);
+    return {
+      fiber: Aff.Fiber(util, supervisor, aff),
+      supervisor: supervisor
     };
-  });
+  };
+};
+
+exports._killAll = function (error, supervisor, cb) {
+  return supervisor.killAll(error, cb);
 };
 
 exports._delay = function () {

src/Control/Monad/Aff.purs

@@ -193,8 +193,8 @@ nonCanceler = Canceler (const (pure unit))
 -- | Forks an `Aff` from an `Eff` context, returning the `Fiber`.
 launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
 launchAff aff = do
-  fiber@(Fiber { run }) ← makeFiber aff
-  run
+  fiber ← makeFiber aff
+  case fiber of Fiber f → f.run
   pure fiber
 
 -- | Suspends an `Aff` from an `Eff` context, returning the `Fiber`.
@@ -221,12 +221,6 @@ forkAff = _fork true
 suspendAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
 suspendAff = _fork false
 
--- | Creates a new supervision context for some `Aff`, guaranteeing fiber
--- | cleanup when the parent completes. Any pending fibers forked within
--- | the context will be killed and have their cancelers run.
-supervise ∷ ∀ eff a. Aff eff a → Aff eff a
-supervise aff = Fn.runFn2 _supervise ffiUtil aff
-
 -- | Pauses the running fiber.
 delay ∷ ∀ eff. Milliseconds → Aff eff Unit
 delay (Milliseconds n) = Fn.runFn2 _delay Right n
@@ -282,6 +276,38 @@ bracket acquire completed =
     , completed: const completed
     }
 
+type Supervised eff a =
+  { fiber ∷ Fiber eff a
+  , supervisor ∷ Supervisor eff
+  }
+
+-- | Creates a new supervision context for some `Aff`, guaranteeing fiber
+-- | cleanup when the parent completes. Any pending fibers forked within
+-- | the context will be killed and have their cancelers run.
+supervise ∷ ∀ eff a. Aff eff a → Aff eff a
+supervise aff =
+  generalBracket (liftEff acquire)
+    { killed: \err sup → parSequence_ [ killFiber err sup.fiber, killAll err sup ]
+    , failed: const (killAll killError)
+    , completed: const (killAll killError)
+    }
+    (joinFiber <<< _.fiber)
+  where
+  killError ∷ Error
+  killError =
+    error "[Aff] Child fiber outlived parent"
+
+  killAll ∷ Error → Supervised eff a → Aff eff Unit
+  killAll err sup = makeAff \k →
+    Fn.runFn3 _killAll err sup.supervisor (k (pure unit))
+
+  acquire ∷ Eff eff (Supervised eff a)
+  acquire = do
+    sup ← Fn.runFn2 _makeSupervisedFiber ffiUtil aff
+    case sup.fiber of Fiber f → f.run
+    pure sup
+
+foreign import data Supervisor ∷ # Effect → Type
 foreign import _pure ∷ ∀ eff a. a → Aff eff a
 foreign import _throwError ∷ ∀ eff a. Error → Aff eff a
 foreign import _catchError ∷ ∀ eff a. Aff eff a → (Error → Aff eff a) → Aff eff a
@@ -294,7 +320,8 @@ foreign import _parAffMap ∷ ∀ eff a b. (a → b) → ParAff eff a → ParAff
 foreign import _parAffApply ∷ ∀ eff a b. ParAff eff (a → b) → ParAff eff a → ParAff eff b
 foreign import _parAffAlt ∷ ∀ eff a. ParAff eff a → ParAff eff a → ParAff eff a
 foreign import _makeFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Fiber eff a))
-foreign import _supervise ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Aff eff a)
+foreign import _makeSupervisedFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Supervised eff a))
+foreign import _killAll ∷ ∀ eff. Fn.Fn3 Error (Supervisor eff) (Eff eff Unit) (Eff eff (Canceler eff))
 foreign import _sequential ∷ ∀ eff a. ParAff eff a → Aff eff a
 
 type BracketConditions eff a b =