Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Extended MonadAsync #2649

Merged
merged 2 commits into from
Oct 2, 2020
Merged

Extended MonadAsync #2649

Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
11e0ee3
io-sim-classes: extend MonadAsync
coot Sep 30, 2020
a6795bd
io-sim-classes: extend MonadAsync
coot Sep 30, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
35 changes: 33 additions & 2 deletions io-sim-classes/src/Control/Monad/Class/MonadAsync.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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 #-}
Expand Down Expand Up @@ -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)

Expand Down Expand Up @@ -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.
--
Expand Down Expand Up @@ -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
--
Expand Down Expand Up @@ -269,6 +299,7 @@ instance MonadAsync IO where
race = Async.race
race_ = Async.race_
concurrently = Async.concurrently
concurrently_ = Async.concurrently_

asyncWithUnmask = Async.asyncWithUnmask

Expand Down