Cabal/src/Distribution/Compat/Async.hs

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