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

Added cancelWith to the MonadAsync type class #912

Merged
merged 1 commit into from
Aug 11, 2019
Merged

Added cancelWith to the MonadAsync type class #912

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
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
10 changes: 6 additions & 4 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 @@ -17,7 +17,7 @@ import Control.Concurrent.Async (AsyncCancelled(..))

class MonadSTM m => MonadAsync m where

{-# MINIMAL async, cancel, waitCatchSTM, pollSTM #-}
{-# MINIMAL async, cancel, cancelWith, waitCatchSTM, pollSTM #-}

-- | An asynchronous action
type Async m :: * -> *
Expand All @@ -26,9 +26,10 @@ class MonadSTM m => MonadAsync m where
withAsync :: m a -> (Async m a -> m b) -> m b

wait :: Async m a -> m a
poll :: Async m a -> m (Maybe (Either SomeException a))
poll :: Async m a -> m (Maybe (Either SomeException a))
waitCatch :: Async m a -> m (Either SomeException a)
cancel :: Async m a -> m ()
cancelWith :: Exception e => Async m a -> e -> m ()
uninterruptibleCancel :: Async m a -> m ()

waitSTM :: Async m a -> STM m a
Expand All @@ -37,7 +38,7 @@ class MonadSTM m => MonadAsync m where

waitAny :: [Async m a] -> m (Async m a, a)
waitAnyCatch :: [Async m a] -> m (Async m a, Either SomeException a)
waitAnyCancel :: [Async m a] -> m (Async m a, a)
waitAnyCancel :: [Async m a] -> m (Async m a, a)
waitAnyCatchCancel :: [Async m a] -> m (Async m a, Either SomeException a)
waitEither :: Async m a -> Async m b -> m (Either a b)

Expand Down Expand Up @@ -70,7 +71,7 @@ class MonadSTM m => MonadAsync m where
default uninterruptibleCancel
:: MonadMask m => Async m a -> m ()
default waitSTM :: MonadThrow (STM m) => Async m a -> STM m a
default waitAnyCancel :: MonadThrow m => [Async m a] -> m (Async m a, a)
default waitAnyCancel :: MonadThrow m => [Async m a] -> m (Async m a, a)
default waitAnyCatchCancel :: MonadThrow m => [Async m a]
-> m (Async m a, Either SomeException a)
default waitEitherCancel :: MonadThrow m => Async m a -> Async m b
Expand Down Expand Up @@ -227,6 +228,7 @@ instance MonadAsync IO where
poll = Async.poll
waitCatch = Async.waitCatch
cancel = Async.cancel
cancelWith = Async.cancelWith
uninterruptibleCancel = Async.uninterruptibleCancel

waitSTM = Async.waitSTM
Expand Down
3 changes: 2 additions & 1 deletion io-sim/src/Control/Monad/IOSim.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -333,6 +333,7 @@ instance MonadAsync (SimM s) where
return (Async tid var)

cancel a@(Async tid _) = throwTo tid AsyncCancelled <* waitCatch a
cancelWith a@(Async tid _) e = throwTo tid e <* waitCatch a

waitCatchSTM (Async _ var) = readTMVar var
pollSTM (Async _ var) = tryReadTMVar var
Expand Down Expand Up @@ -643,7 +644,7 @@ schedule thread@Thread{

Catch action' handler k -> do
-- push the failure and success continuations onto the control stack
let thread' = thread { threadControl = ThreadControl action'
let thread' = thread { threadControl = ThreadControl action'
(CatchFrame handler k ctl) }
schedule thread' simstate

Expand Down