    {-# LANGUAGE CPP                #-}
    {-# LANGUAGE DeriveDataTypeable #-}
    -- | 'Async', yet using 'MVar's.
    --
    -- Adopted from @async@ library
    -- Copyright (c) 2012, Simon Marlow
    -- Licensed under BSD-3-Clause
    --
    -- @since 3.2.0.0
    --
    module Distribution.Compat.Async (
        AsyncM,
        withAsync, waitCatch,
        wait, asyncThreadId,
        cancel, uninterruptibleCancel, AsyncCancelled (..),
        -- * Cabal extras
        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

    -- | Async, but based on 'MVar', as we don't depend on @stm@.
    data AsyncM a = Async
      { forall a. AsyncM a -> ThreadId
    asyncThreadId :: {-# UNPACK #-} !ThreadId
                      -- ^ Returns the 'ThreadId' of the thread running
                      -- the given 'Async'.
      , forall a. AsyncM a -> MVar (Either SomeException a)
    _asyncMVar    :: MVar (Either SomeException a)
      }

    -- | Spawn an asynchronous action in a separate thread, and pass its
    -- @Async@ handle to the supplied function.  When the function returns
    -- or throws an exception, 'uninterruptibleCancel' is called on the @Async@.
    --
    -- > withAsync action inner = mask $ \restore -> do
    -- >   a <- async (restore action)
    -- >   restore (inner a) `finally` uninterruptibleCancel a
    --
    -- This is a useful variant of 'async' that ensures an @Async@ is
    -- never left running unintentionally.
    --
    -- Note: a reference to the child thread is kept alive until the call
    -- to `withAsync` returns, so nesting many `withAsync` calls requires
    -- linear memory.
    --
    withAsync :: IO a -> (AsyncM a -> IO b) -> IO b
    withAsync :: forall a b. IO a -> (AsyncM a -> IO b) -> IO b
    withAsync = ((IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b)
    -> (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b
    forall a. a -> a
    inline (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b
    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 = ((IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b)
    -> (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b
    forall a. a -> a
    inline (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b
    forall a b.
    (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b
    withAsyncUsing IO () -> IO ThreadId
    forkIO (IO a
    m IO a -> (a -> IO a) -> IO a
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= a -> IO a
    evaluateNF) where
        evaluateNF :: a -> IO a
    evaluateNF = a -> IO a
    forall a. a -> IO a
    evaluate (a -> IO a) -> (a -> a) -> a -> IO a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> a
    forall a. NFData a => a -> a
    force

    withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b
    -- The bracket version works, but is slow.  We can do better by
    -- hand-coding it:
    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 <- IO (MVar (Either SomeException a))
    forall a. IO (MVar a)
    newEmptyMVar
      ((forall a. IO a -> IO a) -> IO b) -> IO b
    forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
    mask (((forall a. IO a -> IO a) -> IO b) -> IO b)
    -> ((forall a. IO a -> IO a) -> IO b) -> IO b
    forall a b. (a -> b) -> a -> b
    $ \forall a. IO a -> IO a
    restore -> do
        ThreadId
    t <- IO () -> IO ThreadId
    doFork (IO () -> IO ThreadId) -> IO () -> IO ThreadId
    forall a b. (a -> b) -> a -> b
    $ IO a -> IO (Either SomeException a)
    forall e a. Exception e => IO a -> IO (Either e a)
    try (IO a -> IO a
    forall a. IO a -> IO a
    restore IO a
    action) IO (Either SomeException a)
    -> (Either SomeException a -> IO ()) -> IO ()
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MVar (Either SomeException a) -> Either SomeException a -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar (Either SomeException a)
    var
        let a :: AsyncM a
    a = ThreadId -> MVar (Either SomeException a) -> AsyncM a
    forall a. ThreadId -> MVar (Either SomeException a) -> AsyncM a
    Async ThreadId
    t MVar (Either SomeException a)
    var
        b
    r <- IO b -> IO b
    forall a. IO a -> IO a
    restore (AsyncM a -> IO b
    inner AsyncM a
    a) IO b -> (SomeException -> IO b) -> IO b
    forall a. IO a -> (SomeException -> IO a) -> IO a
    `catchAll` \SomeException
    e -> do
            AsyncM a -> IO ()
    forall a. AsyncM a -> IO ()
    uninterruptibleCancel AsyncM a
    a
            SomeException -> IO b
    forall e a. Exception e => e -> IO a
    throwIO SomeException
    e
        AsyncM a -> IO ()
    forall a. AsyncM a -> IO ()
    uninterruptibleCancel AsyncM a
    a
        b -> IO b
    forall (m :: * -> *) a. Monad m => a -> m a
    return b
    r

    -- | Wait for an asynchronous action to complete, and return its
    -- value.  If the asynchronous action threw an exception, then the
    -- exception is re-thrown by 'wait'.
    --
    -- > wait = atomically . waitSTM
    --
    {-# INLINE wait #-}
    wait :: AsyncM a -> IO a
    wait :: forall a. AsyncM a -> IO a
    wait AsyncM a
    a = do
        Either SomeException a
    res <- AsyncM a -> IO (Either SomeException a)
    forall a. AsyncM a -> IO (Either SomeException a)
    waitCatch AsyncM a
    a
        case Either SomeException a
    res of
            Left (SomeException e
    e) -> e -> IO a
    forall e a. Exception e => e -> IO a
    throwIO e
    e
            Right a
    x                -> a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    x

    -- | Wait for an asynchronous action to complete, and return either
    -- @Left e@ if the action raised an exception @e@, or @Right a@ if it
    -- returned a value @a@.
    --
    -- > waitCatch = atomically . waitCatchSTM
    --
    {-# 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) = IO (Either SomeException a) -> IO (Either SomeException a)
    forall a. IO a -> IO a
    tryAgain (MVar (Either SomeException a) -> IO (Either SomeException a)
    forall a. MVar a -> IO a
    readMVar MVar (Either SomeException a)
    var)
      where
        -- See: https://github.com/simonmar/async/issues/14
        tryAgain :: IO a -> IO a
    tryAgain IO a
    f = IO a
    f IO a -> (BlockedIndefinitelyOnMVar -> IO a) -> IO a
    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 = IO a -> (SomeException -> IO a) -> IO a
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    catch

    -- | Cancel an asynchronous action by throwing the @AsyncCancelled@
    -- exception to it, and waiting for the `Async` thread to quit.
    -- Has no effect if the 'Async' has already completed.
    --
    -- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a
    --
    -- Note that 'cancel' will not terminate until the thread the 'Async'
    -- refers to has terminated. This means that 'cancel' will block for
    -- as long said thread blocks when receiving an asynchronous exception.
    --
    -- For example, it could block if:
    --
    -- * It's executing a foreign call, and thus cannot receive the asynchronous
    -- exception;
    -- * It's executing some cleanup handler after having received the exception,
    -- and the handler is blocking.
    {-# 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
        ThreadId -> AsyncCancelled -> IO ()
    forall e. Exception e => ThreadId -> e -> IO ()
    throwTo ThreadId
    t AsyncCancelled
    AsyncCancelled
        IO (Either SomeException a) -> IO ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (AsyncM a -> IO (Either SomeException a)
    forall a. AsyncM a -> IO (Either SomeException a)
    waitCatch AsyncM a
    a)

    -- | The exception thrown by `cancel` to terminate a thread.
    data AsyncCancelled = AsyncCancelled
      deriving (Int -> AsyncCancelled -> ShowS
    [AsyncCancelled] -> ShowS
    AsyncCancelled -> String
    (Int -> AsyncCancelled -> ShowS)
    -> (AsyncCancelled -> String)
    -> ([AsyncCancelled] -> ShowS)
    -> Show AsyncCancelled
    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
    (AsyncCancelled -> AsyncCancelled -> Bool)
    -> (AsyncCancelled -> AsyncCancelled -> Bool) -> Eq AsyncCancelled
    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)
      -- wraps in SomeAsyncException
      -- See https://github.com/ghc/ghc/commit/756a970eacbb6a19230ee3ba57e24999e4157b09
      fromException :: SomeException -> Maybe AsyncCancelled
    fromException = SomeException -> Maybe AsyncCancelled
    forall e. Exception e => SomeException -> Maybe e
    asyncExceptionFromException
      toException :: AsyncCancelled -> SomeException
    toException = AsyncCancelled -> SomeException
    forall e. Exception e => e -> SomeException
    asyncExceptionToException
    #endif

    -- | Cancel an asynchronous action
    --
    -- This is a variant of `cancel`, but it is not interruptible.
    {-# INLINE uninterruptibleCancel #-}
    uninterruptibleCancel :: AsyncM a -> IO ()
    uninterruptibleCancel :: forall a. AsyncM a -> IO ()
    uninterruptibleCancel = IO () -> IO ()
    forall a. IO a -> IO a
    uninterruptibleMask_ (IO () -> IO ()) -> (AsyncM a -> IO ()) -> AsyncM a -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . AsyncM a -> IO ()
    forall a. AsyncM a -> IO ()
    cancel