MonadAsync: added ConcurrentlyM

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

@@ -12,6 +12,7 @@ module Control.Monad.Class.MonadAsync
   , MonadAsyncSTM (..)
   , AsyncCancelled(..)
   , ExceptionInLinkedThread(..)
+  , ConcurrentlyM (..)
   , link
   , linkTo
   , linkOnly
@@ -20,8 +21,10 @@ module Control.Monad.Class.MonadAsync
 
 import           Prelude hiding (read)
 
+import           Control.Applicative (Alternative (..), liftA2)
 import           Control.Monad.Class.MonadFork
 import           Control.Monad.Class.MonadSTM
+import           Control.Monad.Class.MonadTimer
 import           Control.Monad.Class.MonadThrow
 
 import           Control.Concurrent.Async (AsyncCancelled (..))
@@ -186,6 +189,43 @@ class ( MonadSTM m
                                withAsync right $ \b ->
                                  waitBoth a b
 
+-- | Similar to 'Async.Concurrently' but which works for any 'MonadAsync'
+-- instance.
+--
+newtype ConcurrentlyM m a = ConcurrentlyM { runConcurrentlyM :: m a }
+
+instance Functor m => Functor (ConcurrentlyM m) where
+    fmap f (ConcurrentlyM ma) = ConcurrentlyM (fmap f ma)
+
+instance ( Applicative m
+         , MonadAsync m
+         ) => Applicative (ConcurrentlyM m) where
+    pure = ConcurrentlyM . pure
+
+    ConcurrentlyM fn <*> ConcurrentlyM as =
+      ConcurrentlyM $
+        (\(f, a) -> f a)
+        `fmap`
+        concurrently fn as
+
+instance ( Alternative m
+         , MonadAsync  m
+         , MonadTimer  m
+         ) => Alternative (ConcurrentlyM m) where
+    empty = ConcurrentlyM $ forever (threadDelay 86400)
+    ConcurrentlyM as <|> ConcurrentlyM bs =
+      ConcurrentlyM $ either id id <$> as `race` bs
+
+instance ( Semigroup  a
+         , MonadAsync m
+         ) => Semigroup (ConcurrentlyM m a) where
+    (<>) = liftA2 (<>)
+
+instance ( Monoid a
+         , MonadAsync m
+         ) => Monoid (ConcurrentlyM m a) where
+    mempty = pure mempty
+
 --
 -- Instance for IO uses the existing async library implementations
 --
@@ -203,7 +243,7 @@ instance MonadAsyncSTM Async.Async STM.STM where
 
 instance MonadAsync IO where
 
-  type Async IO = Async.Async
+  type Async IO         = Async.Async
 
   async                 = Async.async
   asyncThreadId         = \_proxy -> Async.asyncThreadId