Skip to content
Permalink
Browse files

Merge #443

443: Use orElse in default implementations of Async class methods r=coot a=dcoutts

These are the implementations used in the async library. The only reason we were using low level ones before was because we didn't have the STM orElse combinator available.

We could also, if needed, use this to adjust the default async implementation to provide a Functor instance.

Co-authored-by: Marcin Szamotulski <profunctor@pm.me>
Co-authored-by: Duncan Coutts <duncan@well-typed.com>
  • Loading branch information...
3 people committed Apr 14, 2019
2 parents 6de40f5 + a0d031b commit a58d7825b570901c8ca623ce231b6edb9b571529
Showing with 13 additions and 67 deletions.
  1. +12 −65 io-sim-classes/src/Control/Monad/Class/MonadAsync.hs
  2. +1 −2 io-sim/src/Control/Monad/IOSim.hs
@@ -8,6 +8,7 @@ module Control.Monad.Class.MonadAsync

import Prelude hiding (read)

import Control.Monad (void)
import Control.Monad.Class.MonadSTM
import Control.Monad.Class.MonadThrow
import Control.Exception (SomeException)
@@ -114,89 +115,35 @@ class MonadSTM m => MonadAsync m where
waitEitherCatchCancel left right =
waitEitherCatch left right `finally` (cancel left >> cancel right)

-- Our MonadSTM does not cover orElse, so these all use low level versions
waitAnySTM [] = retry
waitAnySTM (a:as) = do
mr <- pollSTM a
case mr of
Nothing -> waitAnySTM as
Just (Left e) -> throwM e
Just (Right r) -> return (a, r)
{-
waitAnySTM as =
foldr orElse retry $
map (\a -> do r <- waitSTM a; return (a, r)) asyncs
-}

waitAnyCatchSTM [] = retry
waitAnyCatchSTM (a:as) = do
mr <- pollSTM a
case mr of
Nothing -> waitAnyCatchSTM as
Just r -> return (a, r)
{-
map (\a -> do r <- waitSTM a; return (a, r)) as

waitAnyCatchSTM as =
foldr orElse retry $
map (\a -> do r <- waitCatchSTM a; return (a, r)) asyncs
-}

waitEitherSTM left right = do
ml <- pollSTM left
mr <- pollSTM right
case (ml, mr) of
(Just (Left e), _) -> throwM e
(Just (Right l), _) -> return (Left l)
(_, Just (Left e)) -> throwM e
(_, Just (Right r)) -> return (Right r)
(Nothing, Nothing) -> retry
{-
map (\a -> do r <- waitCatchSTM a; return (a, r)) as

waitEitherSTM left right =
(Left <$> waitSTM left)
`orElse`
(Right <$> waitSTM right)
-}


waitEitherSTM_ left right = do
ml <- pollSTM left
mr <- pollSTM right
case (ml, mr) of
(Just (Left e), _) -> throwM e
(Just (Right _), _) -> return ()
(_, Just (Left e)) -> throwM e
(_, Just (Right _)) -> return ()
(Nothing, Nothing) -> retry
{-

waitEitherSTM_ left right =
(void $ waitSTM left)
`orElse`
(void $ waitSTM right)
-}

waitEitherCatchSTM left right = do
ml <- pollSTM left
mr <- pollSTM right
case (ml, mr) of
(Just l, _ ) -> return (Left l)
(_, Just r ) -> return (Right r)
(Nothing, Nothing) -> retry
{-

waitEitherCatchSTM left right =
(Left <$> waitCatchSTM left)
`orElse`
(Right <$> waitCatchSTM right)
-}

waitBothSTM left right = do
ml <- pollSTM left
mr <- pollSTM right
case (ml, mr) of
(Just (Left e), _) -> throwM e
(_, Just (Left e)) -> throwM e
(Just (Right l), Just (Right r)) -> return (l, r)
(_, _) -> retry
{-
a <- waitSTM left
`orElse`
(waitSTM right >> retry)
b <- waitSTM right
return (a,b)
-}

race left right = withAsync left $ \a ->
withAsync right $ \b ->
@@ -1011,8 +1011,7 @@ execAtomically mytid = go [] [] []
go :: [SomeTVar s]
-> [SomeTVar s]
-> [(Int, StmA s a)] -- list of checkpoints of written variables at the
-- point of @OrElse@ and second argument of
-- @OrElse@
-- point of @OrElse@ and second argument of @OrElse@
-> TVarId
-> StmA s a -> ST s (StmTxResult s a)
go read written orElses nextVid action = case action of

0 comments on commit a58d782

Please sign in to comment.
You can’t perform that action at this time.