Merge #2649

2649: Extended MonadAsync r=dcoutts a=coot



Co-authored-by: Marcin Szamotulski <profunctor@pm.me>

io-sim-classes/src/Control/Monad/Class/MonadAsync.hs

@@ -12,11 +12,15 @@ module Control.Monad.Class.MonadAsync
  , MonadAsyncSTM (..)
  , AsyncCancelled(..)
  , ExceptionInLinkedThread(..)
- , Concurrently (..)
  , link
  , linkTo
  , linkOnly
  , linkToOnly
+
+ , mapConcurrently, forConcurrently
+ , mapConcurrently_, forConcurrently_
+ , replicateConcurrently, replicateConcurrently_
+ , Concurrently (..)
  ) where
 
 import Prelude hiding (read)
@@ -32,8 +36,11 @@ import qualified Control.Concurrent.Async as Async
 import qualified Control.Exception as E
 import Control.Monad.Reader
 import qualified Control.Monad.STM as STM
-import Data.Proxy
+
+import Data.Foldable (fold)
+import Data.Functor (void)
 import Data.Kind (Type)
+import Data.Proxy
 
 class (Functor async, MonadSTMTx stm) => MonadAsyncSTM async stm where
  {-# MINIMAL waitCatchSTM, pollSTM #-}
@@ -130,6 +137,7 @@ class ( MonadSTM m
  race :: m a -> m b -> m (Either a b)
  race_ :: m a -> m b -> m ()
  concurrently :: m a -> m b -> m (a,b)
+ concurrently_ :: m a -> m b -> m ()
 
  asyncWithUnmask :: ((forall b . m b -> m b) -> m a) -> m (Async m a)
 
@@ -188,6 +196,8 @@ class ( MonadSTM m
  withAsync right $ \b ->
  waitBoth a b
 
+ concurrently_ left right = void $ concurrently left right
+
 -- | Similar to 'Async.Concurrently' but which works for any 'MonadAsync'
 -- instance.
 --
@@ -225,6 +235,26 @@ instance ( Monoid a
  ) => Monoid (Concurrently m a) where
  mempty = pure mempty
 
+
+mapConcurrently :: (Traversable t, MonadAsync m) => (a -> m b) -> t a -> m (t b)
+mapConcurrently f = runConcurrently . traverse (Concurrently . f)
+
+forConcurrently :: (Traversable t, MonadAsync m) => t a -> (a -> m b) -> m (t b)
+forConcurrently = flip mapConcurrently
+
+mapConcurrently_ :: (Foldable f, MonadAsync m) => (a -> m b) -> f a -> m ()
+mapConcurrently_ f = runConcurrently . foldMap (Concurrently . void . f)
+
+forConcurrently_ :: (Foldable f, MonadAsync m) => f a -> (a -> m b) -> m ()
+forConcurrently_ = flip mapConcurrently_
+
+replicateConcurrently :: MonadAsync m => Int -> m a -> m [a]
+replicateConcurrently cnt = runConcurrently . sequenceA . replicate cnt . Concurrently
+
+replicateConcurrently_ :: MonadAsync m => Int -> m a -> m ()
+replicateConcurrently_ cnt = runConcurrently . fold . replicate cnt . Concurrently . void
+
+
 --
 -- Instance for IO uses the existing async library implementations
 --
@@ -269,6 +299,7 @@ instance MonadAsync IO where
  race = Async.race
  race_ = Async.race_
  concurrently = Async.concurrently
+ concurrently_ = Async.concurrently_
 
  asyncWithUnmask = Async.asyncWithUnmask