From 73cff861f30e99a814388e04e85e60ec72b77d8d Mon Sep 17 00:00:00 2001
From: Nathan Faubion <nathan@n-son.com>
Date: Sat, 13 Feb 2016 10:22:30 -0600
Subject: [PATCH 1/2] Add forkAll combinator

---
 docs/Control.Monad.Aff.Class.md   | 18 ++++++-------
 docs/Control.Monad.Aff.Console.md |  6 ++---
 docs/Control.Monad.Aff.Par.md     | 20 +++++++-------
 docs/Control.Monad.Aff.md         | 44 +++++++++++++++++++------------
 src/Control/Monad/Aff.js          | 20 ++++++++++++++
 src/Control/Monad/Aff.purs        | 10 +++++++
 test/Test/Main.purs               | 14 ++++++++--
 7 files changed, 91 insertions(+), 41 deletions(-)

diff --git a/docs/Control.Monad.Aff.Class.md b/docs/Control.Monad.Aff.Class.md
index 25801a9..ae97de1 100644
--- a/docs/Control.Monad.Aff.Class.md
+++ b/docs/Control.Monad.Aff.Class.md
@@ -9,15 +9,15 @@ class MonadAff e m where
 
 ##### Instances
 ``` purescript
-instance monadAffAff :: MonadAff e (Aff e)
-instance monadAffContT :: (Monad m, MonadAff eff m) => MonadAff eff (ContT r m)
-instance monadAffExceptT :: (Monad m, MonadAff eff m) => MonadAff eff (ExceptT e m)
-instance monadAffListT :: (Monad m, MonadAff eff m) => MonadAff eff (ListT m)
-instance monadAffMaybe :: (Monad m, MonadAff eff m) => MonadAff eff (MaybeT m)
-instance monadAffReader :: (Monad m, MonadAff eff m) => MonadAff eff (ReaderT r m)
-instance monadAffRWS :: (Monad m, Monoid w, MonadAff eff m) => MonadAff eff (RWST r w s m)
-instance monadAffState :: (Monad m, MonadAff eff m) => MonadAff eff (StateT s m)
-instance monadAffWriter :: (Monad m, Monoid w, MonadAff eff m) => MonadAff eff (WriterT w m)
+MonadAff e (Aff e)
+(Monad m, MonadAff eff m) => MonadAff eff (ContT r m)
+(Monad m, MonadAff eff m) => MonadAff eff (ExceptT e m)
+(Monad m, MonadAff eff m) => MonadAff eff (ListT m)
+(Monad m, MonadAff eff m) => MonadAff eff (MaybeT m)
+(Monad m, MonadAff eff m) => MonadAff eff (ReaderT r m)
+(Monad m, Monoid w, MonadAff eff m) => MonadAff eff (RWST r w s m)
+(Monad m, MonadAff eff m) => MonadAff eff (StateT s m)
+(Monad m, Monoid w, MonadAff eff m) => MonadAff eff (WriterT w m)
 ```
 
 
diff --git a/docs/Control.Monad.Aff.Console.md b/docs/Control.Monad.Aff.Console.md
index 8512cda..15a8c23 100644
--- a/docs/Control.Monad.Aff.Console.md
+++ b/docs/Control.Monad.Aff.Console.md
@@ -3,7 +3,7 @@
 #### `log`
 
 ``` purescript
-log :: forall e. String -> Aff (console :: CONSOLE | e) String
+log :: forall e. String -> Aff (console :: CONSOLE | e) Unit
 ```
 
 Logs any string to the console. This basically saves you
@@ -12,10 +12,10 @@ from writing `liftEff $ log x` everywhere.
 #### `print`
 
 ``` purescript
-print :: forall e a. (Show a) => a -> Aff (console :: CONSOLE | e) a
+print :: forall e a. (Show a) => a -> Aff (console :: CONSOLE | e) Unit
 ```
 
-Prints any `Show`-able value to the console. This basically saves you 
+Prints any `Show`-able value to the console. This basically saves you
 from writing `liftEff $ print x` everywhere.
 
 
diff --git a/docs/Control.Monad.Aff.Par.md b/docs/Control.Monad.Aff.Par.md
index 713d1ce..78f54c8 100644
--- a/docs/Control.Monad.Aff.Par.md
+++ b/docs/Control.Monad.Aff.Par.md
@@ -1,7 +1,7 @@
 ## Module Control.Monad.Aff.Par
 
-A newtype over `Aff` that provides `Applicative` instances that run in 
-parallel. This is useful, for example, if you want to run a whole bunch 
+A newtype over `Aff` that provides `Applicative` instances that run in
+parallel. This is useful, for example, if you want to run a whole bunch
 of AJAX requests at the same time, rather than sequentially.
 
 #### `Par`
@@ -13,14 +13,14 @@ newtype Par e a
 
 ##### Instances
 ``` purescript
-instance semigroupPar :: (Semigroup a) => Semigroup (Par e a)
-instance monoidPar :: (Monoid a) => Monoid (Par e a)
-instance functorPar :: Functor (Par e)
-instance applyPar :: Apply (Par e)
-instance applicativePar :: Applicative (Par e)
-instance altPar :: Alt (Par e)
-instance plusPar :: Plus (Par e)
-instance alternativePar :: Alternative (Par e)
+(Semigroup a) => Semigroup (Par e a)
+(Monoid a) => Monoid (Par e a)
+Functor (Par e)
+Apply (Par e)
+Applicative (Par e)
+Alt (Par e)
+Plus (Par e)
+Alternative (Par e)
 ```
 
 #### `runPar`
diff --git a/docs/Control.Monad.Aff.md b/docs/Control.Monad.Aff.md
index bca0bfe..b845ae2 100644
--- a/docs/Control.Monad.Aff.md
+++ b/docs/Control.Monad.Aff.md
@@ -13,21 +13,21 @@ This is moral equivalent of `ErrorT (ContT Unit (Eff e)) a`.
 
 ##### Instances
 ``` purescript
-instance semigroupAff :: (Semigroup a) => Semigroup (Aff e a)
-instance monoidAff :: (Monoid a) => Monoid (Aff e a)
-instance functorAff :: Functor (Aff e)
-instance applyAff :: Apply (Aff e)
-instance applicativeAff :: Applicative (Aff e)
-instance bindAff :: Bind (Aff e)
-instance monadAff :: Monad (Aff e)
-instance monadEffAff :: MonadEff e (Aff e)
-instance monadErrorAff :: MonadError Error (Aff e)
-instance altAff :: Alt (Aff e)
-instance plusAff :: Plus (Aff e)
-instance alternativeAff :: Alternative (Aff e)
-instance monadPlusAff :: MonadPlus (Aff e)
-instance monadRecAff :: MonadRec (Aff e)
-instance monadContAff :: MonadCont (Aff e)
+(Semigroup a) => Semigroup (Aff e a)
+(Monoid a) => Monoid (Aff e a)
+Functor (Aff e)
+Apply (Aff e)
+Applicative (Aff e)
+Bind (Aff e)
+Monad (Aff e)
+MonadEff e (Aff e)
+MonadError Error (Aff e)
+Alt (Aff e)
+Plus (Aff e)
+Alternative (Aff e)
+MonadPlus (Aff e)
+MonadRec (Aff e)
+MonadCont (Aff e)
 ```
 
 #### `PureAff`
@@ -54,8 +54,8 @@ successfully canceled. The flag should not be used for communication.
 
 ##### Instances
 ``` purescript
-instance semigroupCanceler :: Semigroup (Canceler e)
-instance monoidCanceler :: Monoid (Canceler e)
+Semigroup (Canceler e)
+Monoid (Canceler e)
 ```
 
 #### `cancel`
@@ -159,6 +159,16 @@ will not block on the result of the computation.
 Returns a canceler that can be used to attempt cancellation of the
 forked computation.
 
+#### `forkAll`
+
+``` purescript
+forkAll :: forall f e a. (Foldable f) => f (Aff e a) -> Aff e Unit
+```
+
+Forks many asynchronous computation at once, ignoring the results.
+
+This function is stack-safe up to the selected Foldable instance.
+
 #### `attempt`
 
 ``` purescript
diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js
index 6db776e..e2bd9f9 100644
--- a/src/Control/Monad/Aff.js
+++ b/src/Control/Monad/Aff.js
@@ -96,6 +96,26 @@ exports._forkAff = function (nonCanceler, aff) {
   };
 }
 
+exports._forkAll = function (nonCanceler, foldl, affs) {
+  var voidF = function(){};
+
+  return function(success, error) {
+    foldl(function(_) {
+      return function(aff) {
+        aff(voidF, voidF);
+      };
+    })({})(affs);
+
+    try {
+      success({});
+    } catch(e) {
+      error(e);
+    }
+
+    return nonCanceler;
+  };
+}
+
 exports._makeAff = function (cb) {
   return function(success, error) {
     return cb(function(e) {
diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs
index e6acbee..20cedcb 100644
--- a/src/Control/Monad/Aff.purs
+++ b/src/Control/Monad/Aff.purs
@@ -8,6 +8,7 @@ module Control.Monad.Aff
   , cancelWith
   , finally
   , forkAff
+  , forkAll
   , later
   , later'
   , launchAff
@@ -33,6 +34,7 @@ import Control.MonadPlus (MonadPlus)
 import Control.Plus (Plus)
 
 import Data.Either (Either(..), either)
+import Data.Foldable (Foldable, foldl)
 import Data.Function (Fn2(), Fn3(), runFn2, runFn3)
 import Data.Monoid (Monoid, mempty)
 
@@ -120,6 +122,12 @@ finally aff1 aff2 = do
 forkAff :: forall e a. Aff e a -> Aff e (Canceler e)
 forkAff aff = runFn2 _forkAff nonCanceler aff
 
+-- | Forks many asynchronous computation at once, ignoring the results.
+-- |
+-- | This function is stack-safe up to the selected Foldable instance.
+forkAll :: forall f e a. (Foldable f) => f (Aff e a) -> Aff e Unit
+forkAll affs = runFn3 _forkAll nonCanceler foldl affs
+
 -- | Promotes any error to the value level of the asynchronous monad.
 attempt :: forall e a. Aff e a -> Aff e (Either Error a)
 attempt aff = runFn3 _attempt Left Right aff
@@ -207,6 +215,8 @@ foreign import _unsafeInterleaveAff :: forall e1 e2 a. Aff e1 a -> Aff e2 a
 
 foreign import _forkAff :: forall e a. Fn2 (Canceler e) (Aff e a) (Aff e (Canceler e))
 
+foreign import _forkAll :: forall f e a b. Fn3 (Canceler e) ((b -> a -> b) -> b -> f a -> b) (f (Aff e a)) (Aff e Unit)
+
 foreign import _makeAff :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e (Canceler e)) -> Aff e a
 
 foreign import _pure :: forall e a. Fn2 (Canceler e) a (Aff e a)
diff --git a/test/Test/Main.purs b/test/Test/Main.purs
index d5b1b05..94d1a92 100644
--- a/test/Test/Main.purs
+++ b/test/Test/Main.purs
@@ -2,7 +2,8 @@ module Test.Main where
 
 import Prelude
 
-import Control.Monad.Aff (Aff(), runAff, later')
+import Control.Monad.Aff (Aff(), runAff, later', forkAll)
+import Control.Monad.Aff.AVar (AVAR(), makeVar', modifyVar, takeVar)
 import Control.Monad.Cont.Class (callCC)
 import Control.Monad.Eff (Eff())
 import Control.Monad.Eff.Class (liftEff)
@@ -10,6 +11,7 @@ import Control.Monad.Eff.Console (CONSOLE(), log, print)
 import Control.Monad.Eff.Exception (EXCEPTION(), throwException)
 import Control.Monad.Rec.Class (tailRecM)
 
+import Data.Array ((..))
 import Data.Either (Either(..))
 
 loop :: forall eff. Int -> Aff (console :: CONSOLE | eff) Unit
@@ -20,13 +22,21 @@ loop n = tailRecM go n
     return (Right unit)
   go n = return (Left (n - 1))
 
+all :: forall eff. Int -> Aff (console :: CONSOLE, avar :: AVAR | eff) Unit
+all n = do
+  var <- makeVar' 0
+  forkAll $ map (\_ -> modifyVar (+ 1) var) (1 .. n)
+  count <- takeVar var
+  liftEff $ log ("Forked " <> show count)
+
 delay :: forall eff. Int -> Aff eff Unit
 delay n = callCC \cont ->
   later' n (cont unit)
 
-main :: Eff (console :: CONSOLE, err :: EXCEPTION) Unit
+main :: Eff (console :: CONSOLE, avar :: AVAR, err :: EXCEPTION) Unit
 main = runAff throwException (const (pure unit)) $ do
   liftEff $ log "pre-delay"
   delay 1000
   liftEff $ log "post-delay"
   loop 1000000
+  all 100000

From a3e7e9b78646b915b646d80a419e6744197f8123 Mon Sep 17 00:00:00 2001
From: Nathan Faubion <nathan@n-son.com>
Date: Sun, 14 Feb 2016 11:32:18 -0600
Subject: [PATCH 2/2] Add canceler to forkAll

---
 docs/Control.Monad.Aff.md  |  8 ++++---
 src/Control/Monad/Aff.js   | 43 ++++++++++++++++++++++++++++++++++----
 src/Control/Monad/Aff.purs | 10 +++++----
 test/Test/Main.purs        | 15 +++++++++----
 4 files changed, 61 insertions(+), 15 deletions(-)

diff --git a/docs/Control.Monad.Aff.md b/docs/Control.Monad.Aff.md
index b845ae2..47380f6 100644
--- a/docs/Control.Monad.Aff.md
+++ b/docs/Control.Monad.Aff.md
@@ -162,12 +162,14 @@ forked computation.
 #### `forkAll`
 
 ``` purescript
-forkAll :: forall f e a. (Foldable f) => f (Aff e a) -> Aff e Unit
+forkAll :: forall f e a. (Foldable f) => f (Aff e a) -> Aff e (Canceler e)
 ```
 
-Forks many asynchronous computation at once, ignoring the results.
+Forks many asynchronous computation in a synchronous manner while being
+stack-safe up to the selected Foldable instance.
 
-This function is stack-safe up to the selected Foldable instance.
+Returns a canceler that can be used to attempt cancellation of all
+forked computations.
 
 #### `attempt`
 
diff --git a/src/Control/Monad/Aff.js b/src/Control/Monad/Aff.js
index e2bd9f9..8f09789 100644
--- a/src/Control/Monad/Aff.js
+++ b/src/Control/Monad/Aff.js
@@ -100,14 +100,49 @@ exports._forkAll = function (nonCanceler, foldl, affs) {
   var voidF = function(){};
 
   return function(success, error) {
-    foldl(function(_) {
+    var cancelers = foldl(function(acc) {
       return function(aff) {
-        aff(voidF, voidF);
+        acc.push(aff(voidF, voidF));
+        return acc;
+      }
+    })([])(affs);
+
+    var canceler = function(e) {
+      return function(success, error) {
+        var cancellations = 0;
+        var result        = false;
+        var errored       = false;
+
+        var s = function(bool) {
+          cancellations = cancellations + 1;
+          result        = result || bool;
+
+          if (cancellations === cancelers.length && !errored) {
+            try {
+              success(result);
+            } catch (e) {
+              error(e);
+            }
+          }
+        };
+
+        var f = function(err) {
+          if (!errored) {
+            errored = true;
+            error(err);
+          }
+        };
+
+        for (var i = 0; i < cancelers.length; i++) {
+          cancelers[i](e)(s, f);
+        }
+
+        return nonCanceler;
       };
-    })({})(affs);
+    };
 
     try {
-      success({});
+      success(canceler);
     } catch(e) {
       error(e);
     }
diff --git a/src/Control/Monad/Aff.purs b/src/Control/Monad/Aff.purs
index 20cedcb..aa2bdab 100644
--- a/src/Control/Monad/Aff.purs
+++ b/src/Control/Monad/Aff.purs
@@ -122,10 +122,12 @@ finally aff1 aff2 = do
 forkAff :: forall e a. Aff e a -> Aff e (Canceler e)
 forkAff aff = runFn2 _forkAff nonCanceler aff
 
--- | Forks many asynchronous computation at once, ignoring the results.
+-- | Forks many asynchronous computation in a synchronous manner while being
+-- | stack-safe up to the selected Foldable instance.
 -- |
--- | This function is stack-safe up to the selected Foldable instance.
-forkAll :: forall f e a. (Foldable f) => f (Aff e a) -> Aff e Unit
+-- | Returns a canceler that can be used to attempt cancellation of all
+-- | forked computations.
+forkAll :: forall f e a. (Foldable f) => f (Aff e a) -> Aff e (Canceler e)
 forkAll affs = runFn3 _forkAll nonCanceler foldl affs
 
 -- | Promotes any error to the value level of the asynchronous monad.
@@ -215,7 +217,7 @@ foreign import _unsafeInterleaveAff :: forall e1 e2 a. Aff e1 a -> Aff e2 a
 
 foreign import _forkAff :: forall e a. Fn2 (Canceler e) (Aff e a) (Aff e (Canceler e))
 
-foreign import _forkAll :: forall f e a b. Fn3 (Canceler e) ((b -> a -> b) -> b -> f a -> b) (f (Aff e a)) (Aff e Unit)
+foreign import _forkAll :: forall f e a b. Fn3 (Canceler e) ((b -> a -> b) -> b -> f a -> b) (f (Aff e a)) (Aff e (Canceler e))
 
 foreign import _makeAff :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e (Canceler e)) -> Aff e a
 
diff --git a/test/Test/Main.purs b/test/Test/Main.purs
index 94d1a92..fa4f4c4 100644
--- a/test/Test/Main.purs
+++ b/test/Test/Main.purs
@@ -2,16 +2,16 @@ module Test.Main where
 
 import Prelude
 
-import Control.Monad.Aff (Aff(), runAff, later', forkAll)
+import Control.Monad.Aff (Aff(), runAff, later', forkAll, cancel)
 import Control.Monad.Aff.AVar (AVAR(), makeVar', modifyVar, takeVar)
 import Control.Monad.Cont.Class (callCC)
 import Control.Monad.Eff (Eff())
 import Control.Monad.Eff.Class (liftEff)
 import Control.Monad.Eff.Console (CONSOLE(), log, print)
-import Control.Monad.Eff.Exception (EXCEPTION(), throwException)
+import Control.Monad.Eff.Exception (EXCEPTION(), throwException, error)
 import Control.Monad.Rec.Class (tailRecM)
 
-import Data.Array ((..))
+import Data.Array (replicate)
 import Data.Either (Either(..))
 
 loop :: forall eff. Int -> Aff (console :: CONSOLE | eff) Unit
@@ -25,10 +25,16 @@ loop n = tailRecM go n
 all :: forall eff. Int -> Aff (console :: CONSOLE, avar :: AVAR | eff) Unit
 all n = do
   var <- makeVar' 0
-  forkAll $ map (\_ -> modifyVar (+ 1) var) (1 .. n)
+  forkAll $ replicate n (modifyVar (+ 1) var)
   count <- takeVar var
   liftEff $ log ("Forked " <> show count)
 
+cancelAll :: forall eff. Int -> Aff (console :: CONSOLE, avar :: AVAR | eff) Unit
+cancelAll n = do
+  canceler <- forkAll $ replicate n (later' 100000 (liftEff $ log "oops"))
+  canceled <- cancel canceler (error "bye")
+  liftEff $ log ("Cancelled all: " <> show canceled)
+
 delay :: forall eff. Int -> Aff eff Unit
 delay n = callCC \cont ->
   later' n (cont unit)
@@ -40,3 +46,4 @@ main = runAff throwException (const (pure unit)) $ do
   liftEff $ log "post-delay"
   loop 1000000
   all 100000
+  cancelAll 100000