1{-# LANGUAGE CPP                #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3-- | 'Async', yet using 'MVar's.
4--
5-- Adopted from @async@ library
6-- Copyright (c) 2012, Simon Marlow
7-- Licensed under BSD-3-Clause
8--
9-- @since 3.2.0.0
10--
11module Distribution.Compat.Async (
12    AsyncM,
13    withAsync, waitCatch,
14    wait, asyncThreadId,
15    cancel, uninterruptibleCancel, AsyncCancelled (..),
16    -- * Cabal extras
17    withAsyncNF,
18    ) where
19
20import Control.Concurrent      (ThreadId, forkIO)
21import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)
22import Control.DeepSeq         (NFData, force)
23import Control.Exception
24       (BlockedIndefinitelyOnMVar (..), Exception (..), SomeException (..), catch, evaluate, mask, throwIO, throwTo, try, uninterruptibleMask_)
25import Control.Monad           (void)
26import Data.Typeable           (Typeable)
27import GHC.Exts                (inline)
28
29#if MIN_VERSION_base(4,7,0)
30import Control.Exception (asyncExceptionFromException, asyncExceptionToException)
31#endif
32
33-- | Async, but based on 'MVar', as we don't depend on @stm@.
34data AsyncM a = Async
35  { asyncThreadId :: {-# UNPACK #-} !ThreadId
36                  -- ^ Returns the 'ThreadId' of the thread running
37                  -- the given 'Async'.
38  , _asyncMVar    :: MVar (Either SomeException a)
39  }
40
41-- | Spawn an asynchronous action in a separate thread, and pass its
42-- @Async@ handle to the supplied function.  When the function returns
43-- or throws an exception, 'uninterruptibleCancel' is called on the @Async@.
44--
45-- > withAsync action inner = mask $ \restore -> do
46-- >   a <- async (restore action)
47-- >   restore (inner a) `finally` uninterruptibleCancel a
48--
49-- This is a useful variant of 'async' that ensures an @Async@ is
50-- never left running unintentionally.
51--
52-- Note: a reference to the child thread is kept alive until the call
53-- to `withAsync` returns, so nesting many `withAsync` calls requires
54-- linear memory.
55--
56withAsync :: IO a -> (AsyncM a -> IO b) -> IO b
57withAsync = inline withAsyncUsing forkIO
58
59withAsyncNF :: NFData a => IO a -> (AsyncM a -> IO b) -> IO b
60withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF) where
61    evaluateNF = evaluate . force
62
63withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b
64-- The bracket version works, but is slow.  We can do better by
65-- hand-coding it:
66withAsyncUsing doFork = \action inner -> do
67  var <- newEmptyMVar
68  mask $ \restore -> do
69    t <- doFork $ try (restore action) >>= putMVar var
70    let a = Async t var
71    r <- restore (inner a) `catchAll` \e -> do
72        uninterruptibleCancel a
73        throwIO e
74    uninterruptibleCancel a
75    return r
76
77-- | Wait for an asynchronous action to complete, and return its
78-- value.  If the asynchronous action threw an exception, then the
79-- exception is re-thrown by 'wait'.
80--
81-- > wait = atomically . waitSTM
82--
83{-# INLINE wait #-}
84wait :: AsyncM a -> IO a
85wait a = do
86    res <- waitCatch a
87    case res of
88        Left (SomeException e) -> throwIO e
89        Right x                -> return x
90
91-- | Wait for an asynchronous action to complete, and return either
92-- @Left e@ if the action raised an exception @e@, or @Right a@ if it
93-- returned a value @a@.
94--
95-- > waitCatch = atomically . waitCatchSTM
96--
97{-# INLINE waitCatch #-}
98waitCatch :: AsyncM a -> IO (Either SomeException a)
99waitCatch (Async _ var) = tryAgain (readMVar var)
100  where
101    -- See: https://github.com/simonmar/async/issues/14
102    tryAgain f = f `catch` \BlockedIndefinitelyOnMVar -> f
103
104catchAll :: IO a -> (SomeException -> IO a) -> IO a
105catchAll = catch
106
107-- | Cancel an asynchronous action by throwing the @AsyncCancelled@
108-- exception to it, and waiting for the `Async` thread to quit.
109-- Has no effect if the 'Async' has already completed.
110--
111-- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a
112--
113-- Note that 'cancel' will not terminate until the thread the 'Async'
114-- refers to has terminated. This means that 'cancel' will block for
115-- as long said thread blocks when receiving an asynchronous exception.
116--
117-- For example, it could block if:
118--
119-- * It's executing a foreign call, and thus cannot receive the asynchronous
120-- exception;
121-- * It's executing some cleanup handler after having received the exception,
122-- and the handler is blocking.
123{-# INLINE cancel #-}
124cancel :: AsyncM a -> IO ()
125cancel a@(Async t _) = do
126    throwTo t AsyncCancelled
127    void (waitCatch a)
128
129-- | The exception thrown by `cancel` to terminate a thread.
130data AsyncCancelled = AsyncCancelled
131  deriving (Show, Eq
132    , Typeable
133    )
134
135instance Exception AsyncCancelled where
136#if MIN_VERSION_base(4,7,0)
137  -- wraps in SomeAsyncException
138  -- See https://github.com/ghc/ghc/commit/756a970eacbb6a19230ee3ba57e24999e4157b09
139  fromException = asyncExceptionFromException
140  toException = asyncExceptionToException
141#endif
142
143-- | Cancel an asynchronous action
144--
145-- This is a variant of `cancel`, but it is not interruptible.
146{-# INLINE uninterruptibleCancel #-}
147uninterruptibleCancel :: AsyncM a -> IO ()
148uninterruptibleCancel = uninterruptibleMask_ . cancel
149