{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Distribution.Compat.Async (
AsyncM,
withAsync, waitCatch,
wait, asyncThreadId,
cancel, uninterruptibleCancel, AsyncCancelled (..),
withAsyncNF,
) where
import Control.Concurrent (ThreadId, forkIO)
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)
import Control.DeepSeq (NFData, force)
import Control.Exception
(BlockedIndefinitelyOnMVar (..), Exception (..), SomeException (..), catch, evaluate, mask, throwIO, throwTo, try, uninterruptibleMask_)
import Control.Monad (void)
import Data.Typeable (Typeable)
import GHC.Exts (inline)
#if MIN_VERSION_base(4,7,0)
import Control.Exception (asyncExceptionFromException, asyncExceptionToException)
#endif
data AsyncM a = Async
{ forall a. AsyncM a -> ThreadId
asyncThreadId :: {-# UNPACK #-} !ThreadId
, forall a. AsyncM a -> MVar (Either SomeException a)
_asyncMVar :: MVar (Either SomeException a)
}
withAsync :: IO a -> (AsyncM a -> IO b) -> IO b
withAsync :: forall a b. IO a -> (AsyncM a -> IO b) -> IO b
withAsync = forall a. a -> a
inline forall a b.
(IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b
withAsyncUsing IO () -> IO ThreadId
forkIO
withAsyncNF :: NFData a => IO a -> (AsyncM a -> IO b) -> IO b
withAsyncNF :: forall a b. NFData a => IO a -> (AsyncM a -> IO b) -> IO b
withAsyncNF IO a
m = forall a. a -> a
inline forall a b.
(IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b
withAsyncUsing IO () -> IO ThreadId
forkIO (IO a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO a
evaluateNF) where
evaluateNF :: a -> IO a
evaluateNF = forall a. a -> IO a
evaluate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NFData a => a -> a
force
withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b
withAsyncUsing :: forall a b.
(IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b
withAsyncUsing IO () -> IO ThreadId
doFork = \IO a
action AsyncM a -> IO b
inner -> do
MVar (Either SomeException a)
var <- forall a. IO (MVar a)
newEmptyMVar
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
ThreadId
t <- IO () -> IO ThreadId
doFork forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try (forall a. IO a -> IO a
restore IO a
action) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException a)
var
let a :: AsyncM a
a = forall a. ThreadId -> MVar (Either SomeException a) -> AsyncM a
Async ThreadId
t MVar (Either SomeException a)
var
b
r <- forall a. IO a -> IO a
restore (AsyncM a -> IO b
inner AsyncM a
a) forall a. IO a -> (SomeException -> IO a) -> IO a
`catchAll` \SomeException
e -> do
forall a. AsyncM a -> IO ()
uninterruptibleCancel AsyncM a
a
forall e a. Exception e => e -> IO a
throwIO SomeException
e
forall a. AsyncM a -> IO ()
uninterruptibleCancel AsyncM a
a
forall (m :: * -> *) a. Monad m => a -> m a
return b
r
{-# INLINE wait #-}
wait :: AsyncM a -> IO a
wait :: forall a. AsyncM a -> IO a
wait AsyncM a
a = do
Either SomeException a
res <- forall a. AsyncM a -> IO (Either SomeException a)
waitCatch AsyncM a
a
case Either SomeException a
res of
Left (SomeException e
e) -> forall e a. Exception e => e -> IO a
throwIO e
e
Right a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x
{-# INLINE waitCatch #-}
waitCatch :: AsyncM a -> IO (Either SomeException a)
waitCatch :: forall a. AsyncM a -> IO (Either SomeException a)
waitCatch (Async ThreadId
_ MVar (Either SomeException a)
var) = forall a. IO a -> IO a
tryAgain (forall a. MVar a -> IO a
readMVar MVar (Either SomeException a)
var)
where
tryAgain :: IO a -> IO a
tryAgain IO a
f = IO a
f forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \BlockedIndefinitelyOnMVar
BlockedIndefinitelyOnMVar -> IO a
f
catchAll :: IO a -> (SomeException -> IO a) -> IO a
catchAll :: forall a. IO a -> (SomeException -> IO a) -> IO a
catchAll = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
{-# INLINE cancel #-}
cancel :: AsyncM a -> IO ()
cancel :: forall a. AsyncM a -> IO ()
cancel a :: AsyncM a
a@(Async ThreadId
t MVar (Either SomeException a)
_) = do
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
t AsyncCancelled
AsyncCancelled
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall a. AsyncM a -> IO (Either SomeException a)
waitCatch AsyncM a
a)
data AsyncCancelled = AsyncCancelled
deriving (Int -> AsyncCancelled -> ShowS
[AsyncCancelled] -> ShowS
AsyncCancelled -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AsyncCancelled] -> ShowS
$cshowList :: [AsyncCancelled] -> ShowS
show :: AsyncCancelled -> String
$cshow :: AsyncCancelled -> String
showsPrec :: Int -> AsyncCancelled -> ShowS
$cshowsPrec :: Int -> AsyncCancelled -> ShowS
Show, AsyncCancelled -> AsyncCancelled -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AsyncCancelled -> AsyncCancelled -> Bool
$c/= :: AsyncCancelled -> AsyncCancelled -> Bool
== :: AsyncCancelled -> AsyncCancelled -> Bool
$c== :: AsyncCancelled -> AsyncCancelled -> Bool
Eq
, Typeable
)
instance Exception AsyncCancelled where
#if MIN_VERSION_base(4,7,0)
fromException :: SomeException -> Maybe AsyncCancelled
fromException = forall e. Exception e => SomeException -> Maybe e
asyncExceptionFromException
toException :: AsyncCancelled -> SomeException
toException = forall e. Exception e => e -> SomeException
asyncExceptionToException
#endif
{-# INLINE uninterruptibleCancel #-}
uninterruptibleCancel :: AsyncM a -> IO ()
uninterruptibleCancel :: forall a. AsyncM a -> IO ()
uninterruptibleCancel = forall a. IO a -> IO a
uninterruptibleMask_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. AsyncM a -> IO ()
cancel