Merge pull request #45 from natefaubion/forkall

Add forkAll combinator

Author: garyb

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)
 ```
 
 

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.
 
 

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`

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,18 @@ 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 (Canceler e)
+```
+
+Forks many asynchronous computation in a synchronous manner while being
+stack-safe up to the selected Foldable instance.
+
+Returns a canceler that can be used to attempt cancellation of all
+forked computations.
+
 #### `attempt`
 
 ``` purescript

src/Control/Monad/Aff.js

@@ -96,6 +96,61 @@ exports._forkAff = function (nonCanceler, aff) {
   };
 }
 
+exports._forkAll = function (nonCanceler, foldl, affs) {
+  var voidF = function(){};
+
+  return function(success, error) {
+    var cancelers = foldl(function(acc) {
+      return function(aff) {
+        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;
+      };
+    };
+
+    try {
+      success(canceler);
+    } catch(e) {
+      error(e);
+    }
+
+    return nonCanceler;
+  };
+}
+
 exports._makeAff = function (cb) {
   return function(success, error) {
     return cb(function(e) {

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,14 @@ 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 in a synchronous manner while being
+-- | stack-safe up to the selected Foldable instance.
+-- |
+-- | 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.
 attempt :: forall e a. Aff e a -> Aff e (Either Error a)
 attempt aff = runFn3 _attempt Left Right aff
@@ -207,6 +217,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 (Canceler e))
+
 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)

test/Test/Main.purs

@@ -2,14 +2,16 @@ module Test.Main where
 
 import Prelude
 
-import Control.Monad.Aff (Aff(), runAff, later')
+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 (replicate)
 import Data.Either (Either(..))
 
 loop :: forall eff. Int -> Aff (console :: CONSOLE | eff) Unit
@@ -20,13 +22,28 @@ 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 $ 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)
 
-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
+  cancelAll 100000