content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE PolyKinds #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE StandaloneDeriving #-}
  {-# LANGUAGE TypeFamilies #-}
  
  -- |
  -- Module      : Control.Monad.Conc.Class
  -- Copyright   : (c) 2016--2021 Michael Walker
  -- License     : MIT
  -- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
  -- Stability   : experimental
  -- Portability : CPP, FlexibleContexts, PolyKinds, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies
  --
  -- This module captures in a typeclass the interface of concurrency
  -- monads.
  --
  -- __Deviations:__ An instance of @MonadConc@ is not required to be an
  -- instance of @MonadFix@, unlike @IO@. The @IORef@, @MVar@, and
  -- @Ticket@ types are not required to be instances of @Show@ or @Eq@,
  -- unlike their normal counterparts. The @threadCapability@,
  -- @threadWaitRead@, @threadWaitWrite@, @threadWaitReadSTM@,
  -- @threadWaitWriteSTM@, and @mkWeakThreadId@ functions are not
  -- provided. The @threadDelay@ function is not required to delay the
  -- thread, merely to yield it. The @BlockedIndefinitelyOnMVar@ (and
  -- similar) exceptions are /not/ thrown during testing, so do not rely
  -- on them at all.
  module Control.Monad.Conc.Class
    ( MonadConc(..)
  
    -- * Threads
    , fork
    , forkOn
    , forkOS
    , forkFinally
    , spawn
    , killThread
  
    -- ** Bound threads
  
    -- | Support for multiple operating system threads and bound threads
    -- as described below is currently only available in the GHC runtime
    -- system if you use the -threaded option when linking.
    --
    -- Other Haskell systems do not currently support multiple operating
    -- system threads.
    --
    -- A bound thread is a haskell thread that is bound to an operating
    -- system thread. While the bound thread is still scheduled by the
    -- Haskell run-time system, the operating system thread takes care
    -- of all the foreign calls made by the bound thread.
    --
    -- To a foreign library, the bound thread will look exactly like an
    -- ordinary operating system thread created using OS functions like
    -- pthread_create or CreateThread.
    , rtsSupportsBoundThreads
    , runInBoundThread
    , runInUnboundThread
  
    -- ** Named Threads
    , forkN
    , forkOnN
    , forkOSN
  
    -- * Exceptions
    , throw
    , catch
    , mask
    , Ca.mask_
    , uninterruptibleMask
    , Ca.uninterruptibleMask_
    , interruptible
  
    -- * Mutable State
    , newMVar
    , newMVarN
    , cas
    , peekTicket
  
    -- * Utilities for type shenanigans
    , IsConc
    , toIsConc
    , fromIsConc
  
    -- * Utilities for instance writers
    , liftedF
    , liftedFork
    ) where
  
  -- for the class and utilities
  import           Control.Exception            (AsyncException(ThreadKilled),
                                                 Exception, MaskingState(..),
                                                 SomeException)
  import           Control.Monad.Catch          (MonadCatch, MonadMask,
                                                 MonadThrow)
  import qualified Control.Monad.Catch          as Ca
  import           Control.Monad.Fail           (MonadFail(..))
  import           Control.Monad.STM.Class      (IsSTM, MonadSTM, TVar, fromIsSTM,
                                                 newTVar, readTVar)
  import           Control.Monad.Trans.Control  (MonadTransControl, StT, liftWith)
  import           Data.Kind                    (Type)
  import           Data.Proxy                   (Proxy(..))
  
  -- for the 'IO' instance
  import qualified Control.Concurrent           as IO
  import qualified Control.Concurrent.STM.TVar  as IO
  import qualified Control.Exception            as IO
  import qualified Control.Monad.STM            as IO
  import qualified Data.Atomics                 as IO
  import qualified Data.IORef                   as IO
  import qualified GHC.Conc                     as IO
  import qualified GHC.IO                       as IO
  
  -- for the transformer instances
  import           Control.Monad.Reader         (ReaderT)
  import qualified Control.Monad.RWS.Lazy       as RL
  import qualified Control.Monad.RWS.Strict     as RS
  import qualified Control.Monad.State.Lazy     as SL
  import qualified Control.Monad.State.Strict   as SS
  import           Control.Monad.Trans          (lift)
  import           Control.Monad.Trans.Identity (IdentityT)
  import qualified Control.Monad.Writer.Lazy    as WL
  import qualified Control.Monad.Writer.Strict  as WS
  
  -- | @MonadConc@ is an abstraction over GHC's typical concurrency
  -- abstraction. It captures the interface of concurrency monads in
  -- terms of how they can operate on shared state and in the presence
  -- of exceptions.
  --
  -- Every @MonadConc@ has an associated 'MonadSTM', transactions of
  -- which can be run atomically.
  --
  -- __Deriving instances:__ If you have a newtype wrapper around a type
  -- with an existing @MonadConc@ instance, you should be able to derive
  -- an instance for your type automatically, in simple cases.
  --
  -- For example:
  --
  -- > {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  -- > {-# LANGUAGE StandaloneDeriving #-}
  -- > {-# LANGUAGE UndecidableInstances #-}
  -- >
  -- > data Env = Env
  -- >
  -- > newtype MyMonad m a = MyMonad { runMyMonad :: ReaderT Env m a }
  -- >   deriving (Functor, Applicative, Monad)
  -- >
  -- > deriving instance MonadThrow m => MonadThrow (MyMonad m)
  -- > deriving instance MonadCatch m => MonadCatch (MyMonad m)
  -- > deriving instance MonadMask  m => MonadMask  (MyMonad m)
  -- >
  -- > deriving instance MonadConc m => MonadConc (MyMonad m)
  --
  -- Do not be put off by the use of @UndecidableInstances@, it is safe
  -- here.
  --
  -- @since 1.11.0.0
  class ( Monad m
        , MonadCatch m, MonadThrow m, MonadMask m
        , MonadSTM (STM m)
        , Ord (ThreadId m), Show (ThreadId m)) => MonadConc m  where
  
    {-# MINIMAL
          (forkWithUnmask | forkWithUnmaskN)
        , (forkOnWithUnmask | forkOnWithUnmaskN)
        , (forkOSWithUnmask | forkOSWithUnmaskN)
        , supportsBoundThreads
        , isCurrentThreadBound
        , getNumCapabilities
        , setNumCapabilities
        , myThreadId
        , yield
        , (newEmptyMVar | newEmptyMVarN)
        , putMVar
        , tryPutMVar
        , readMVar
        , tryReadMVar
        , takeMVar
        , tryTakeMVar
        , (newIORef | newIORefN)
        , atomicModifyIORef
        , writeIORef
        , readForCAS
        , peekTicket'
        , casIORef
        , modifyIORefCAS
        , atomically
        , throwTo
        , getMaskingState
        , unsafeUnmask
      #-}
  
    -- | The associated 'MonadSTM' for this class.
    --
    -- @since 1.0.0.0
    type STM m :: Type -> Type
  
    -- | The mutable reference type, like 'MVar's. This may contain one
    -- value at a time, attempting to read or take from an \"empty\"
    -- @MVar@ will block until it is full, and attempting to put to a
    -- \"full\" @MVar@ will block until it is empty.
    --
    -- @since 1.0.0.0
    type MVar m :: Type -> Type
  
    -- | The mutable non-blocking reference type. These may suffer from
    -- relaxed memory effects if functions outside the set @newIORef@,
    -- @readIORef@, @atomicModifyIORef@, and @atomicWriteIORef@ are used.
    --
    -- @since 1.6.0.0
    type IORef m :: Type -> Type
  
    -- | When performing compare-and-swap operations on @IORef@s, a
    -- @Ticket@ is a proof that a thread observed a specific previous
    -- value.
    --
    -- @since 1.0.0.0
    type Ticket m :: Type -> Type
  
    -- | An abstract handle to a thread.
    --
    -- @since 1.0.0.0
    type ThreadId m :: Type
  
    -- | Like 'fork', but the child thread is passed a function that can
    -- be used to unmask asynchronous exceptions. This function should
    -- not be used within a 'mask' or 'uninterruptibleMask'.
    --
    -- > forkWithUnmask = forkWithUnmaskN ""
    --
    -- @since 1.0.0.0
    forkWithUnmask :: ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
    forkWithUnmask = forkWithUnmaskN ""
  
    -- | Like 'forkWithUnmask', but the thread is given a name which may
    -- be used to present more useful debugging information.
    --
    -- > forkWithUnmaskN _ = forkWithUnmask
    --
    -- @since 1.0.0.0
    forkWithUnmaskN :: String -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
    forkWithUnmaskN _ = forkWithUnmask
  
    -- | Like 'forkWithUnmask', but the child thread is pinned to the
    -- given CPU, as with 'forkOn'.
    --
    -- > forkOnWithUnmask = forkOnWithUnmaskN ""
    --
    -- @since 1.0.0.0
    forkOnWithUnmask :: Int -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
    forkOnWithUnmask = forkOnWithUnmaskN ""
  
    -- | Like 'forkWithUnmaskN', but the child thread is pinned to the
    -- given CPU, as with 'forkOn'.
    --
    -- > forkOnWithUnmaskN _ = forkOnWithUnmask
    --
    -- @since 1.0.0.0
    forkOnWithUnmaskN :: String -> Int -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
    forkOnWithUnmaskN _ = forkOnWithUnmask
  
    -- | Like 'forkOS', but the child thread is passed a function that
    -- can be used to unmask asynchronous exceptions. This function
    -- should not be used within a 'mask' or 'uninterruptibleMask'.
    --
    -- > forkOSWithUnmask = forkOSWithUnmaskN ""
    --
    -- @since 1.5.0.0
    forkOSWithUnmask :: ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
    forkOSWithUnmask = forkOSWithUnmaskN ""
  
    -- | Like 'forkOSWithUnmask', but the thread is given a name which
    -- may be used to present more useful debugging information.
    --
    -- > forkOSWithUnmaskN _ = forkOSWithUnmask
    --
    -- @since 1.5.0.0
    forkOSWithUnmaskN :: String -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
    forkOSWithUnmaskN _ = forkOSWithUnmask
  
    -- | Returns 'True' if bound threads can be forked.  If 'False',
    -- 'isCurrentThreadBound' will always return 'False' and both
    -- 'forkOS' and 'runInBoundThread' will fail.
    --
    -- @since 1.7.0.0
    supportsBoundThreads :: m Bool
  
    -- | Returns 'True' if the calling thread is bound, that is, if it
    -- is safe to use foreign libraries that rely on thread-local state
    -- from the calling thread.
    --
    -- This will always be false if your program is not compiled with
    -- the threaded runtime.
    --
    -- @since 1.3.0.0
    isCurrentThreadBound :: m Bool
  
    -- | Get the number of Haskell threads that can run simultaneously.
    --
    -- @since 1.0.0.0
    getNumCapabilities :: m Int
  
    -- | Set the number of Haskell threads that can run simultaneously.
    --
    -- @since 1.0.0.0
    setNumCapabilities :: Int -> m ()
  
    -- | Get the @ThreadId@ of the current thread.
    --
    -- @since 1.0.0.0
    myThreadId :: m (ThreadId m)
  
    -- | Allows a context-switch to any other unblocked thread (if any).
    --
    -- @since 1.0.0.0
    yield :: m ()
  
    -- | Yields the current thread, and optionally suspends the current
    -- thread for a given number of microseconds.
    --
    -- If suspended, there is no guarantee that the thread will be
    -- rescheduled promptly when the delay has expired, but the thread
    -- will never continue to run earlier than specified.
    --
    -- > threadDelay _ = yield
    --
    -- @since 1.0.0.0
    threadDelay :: Int -> m ()
    threadDelay _ = yield
  
    -- | Create a new empty @MVar@.
    --
    -- > newEmptyMVar = newEmptyMVarN ""
    --
    -- @since 1.0.0.0
    newEmptyMVar :: m (MVar m a)
    newEmptyMVar = newEmptyMVarN ""
  
    -- | Create a new empty @MVar@, but it is given a name which may be
    -- used to present more useful debugging information.
    --
    -- > newEmptyMVarN _ = newEmptyMVar
    --
    -- @since 1.0.0.0
    newEmptyMVarN :: String -> m (MVar m a)
    newEmptyMVarN _ = newEmptyMVar
  
    -- | Put a value into a @MVar@. If there is already a value there,
    -- this will block until that value has been taken, at which point
    -- the value will be stored.
    --
    -- @since 1.0.0.0
    putMVar :: MVar m a -> a -> m ()
  
    -- | Attempt to put a value in a @MVar@ non-blockingly, returning
    -- 'True' (and filling the @MVar@) if there was nothing there,
    -- otherwise returning 'False'.
    --
    -- @since 1.0.0.0
    tryPutMVar :: MVar m a -> a -> m Bool
  
    -- | Block until a value is present in the @MVar@, and then return
    -- it. This does not \"remove\" the value, multiple reads are
    -- possible.
    --
    -- @since 1.0.0.0
    readMVar :: MVar m a -> m a
  
    -- | Attempt to read a value from a @MVar@ non-blockingly, returning
    -- a 'Just' if there is something there, otherwise returning
    -- 'Nothing'. As with 'readMVar', this does not \"remove\" the
    -- value.
    --
    -- @since 1.1.0.0
    tryReadMVar :: MVar m a -> m (Maybe a)
  
    -- | Take a value from a @MVar@. This \"empties\" the @MVar@,
    -- allowing a new value to be put in. This will block if there is no
    -- value in the @MVar@ already, until one has been put.
    --
    -- @since 1.0.0.0
    takeMVar :: MVar m a -> m a
  
    -- | Attempt to take a value from a @MVar@ non-blockingly, returning
    -- a 'Just' (and emptying the @MVar@) if there was something there,
    -- otherwise returning 'Nothing'.
    --
    -- @since 1.0.0.0
    tryTakeMVar :: MVar m a -> m (Maybe a)
  
    -- | Create a new reference.
    --
    -- > newIORef = newIORefN ""
    --
    -- @since 1.6.0.0
    newIORef :: a -> m (IORef m a)
    newIORef = newIORefN ""
  
    -- | Create a new reference, but it is given a name which may be
    -- used to present more useful debugging information.
    --
    -- > newIORefN _ = newIORef
    --
    -- @since 1.6.0.0
    newIORefN :: String -> a -> m (IORef m a)
    newIORefN _ = newIORef
  
    -- | Read the current value stored in a reference.
    --
    -- > readIORef ioref = readForCAS ioref >>= peekTicket
    --
    -- @since 1.6.0.0
    readIORef :: IORef m a -> m a
    readIORef ioref = readForCAS ioref >>= peekTicket
  
    -- | Atomically modify the value stored in a reference. This imposes
    -- a full memory barrier.
    --
    -- @since 1.6.0.0
    atomicModifyIORef :: IORef m a -> (a -> (a, b)) -> m b
  
    -- | Write a new value into an @IORef@, without imposing a memory
    -- barrier. This means that relaxed memory effects can be observed.
    --
    -- @since 1.6.0.0
    writeIORef :: IORef m a -> a -> m ()
  
    -- | Replace the value stored in a reference, with the
    -- barrier-to-reordering property that 'atomicModifyIORef' has.
    --
    -- > atomicWriteIORef r a = atomicModifyIORef r $ const (a, ())
    --
    -- @since 1.6.0.0
    atomicWriteIORef :: IORef m a -> a -> m ()
    atomicWriteIORef r a = atomicModifyIORef r $ const (a, ())
  
    -- | Read the current value stored in a reference, returning a
    -- @Ticket@, for use in future compare-and-swap operations.
    --
    -- @since 1.6.0.0
    readForCAS :: IORef m a -> m (Ticket m a)
  
    -- | Extract the actual Haskell value from a @Ticket@.
    --
    -- The @Proxy m@ is to determine the @m@ in the @Ticket@ type.
    --
    -- @since 1.4.0.0
    peekTicket' :: Proxy m -> Ticket m a -> a
  
    -- | Perform a machine-level compare-and-swap (CAS) operation on a
    -- @IORef@. Returns an indication of success and a @Ticket@ for the
    -- most current value in the @IORef@.
    --
    -- This is strict in the \"new\" value argument.
    --
    -- @since 1.6.0.0
    casIORef :: IORef m a -> Ticket m a -> a -> m (Bool, Ticket m a)
  
    -- | A replacement for 'atomicModifyIORef' using a compare-and-swap.
    --
    -- This is strict in the \"new\" value argument.
    --
    -- @since 1.6.0.0
    modifyIORefCAS :: IORef m a -> (a -> (a, b)) -> m b
  
    -- | A variant of 'modifyIORefCAS' which doesn't return a result.
    --
    -- > modifyIORefCAS_ ioref f = modifyIORefCAS ioref (\a -> (f a, ()))
    --
    -- @since 1.6.0.0
    modifyIORefCAS_ :: IORef m a -> (a -> a) -> m ()
    modifyIORefCAS_ ioref f = modifyIORefCAS ioref (\a -> (f a, ()))
  
    -- | Perform an STM transaction atomically.
    --
    -- @since 1.0.0.0
    atomically :: STM m a -> m a
  
    -- | Create a @TVar@. This may be implemented differently for speed.
    --
    -- > newTVarConc = atomically . newTVar
    --
    -- @since 1.8.1.0
    newTVarConc :: a -> m (TVar (STM m) a)
    newTVarConc = atomically . newTVar
  
    -- | Read the current value stored in a @TVar@. This may be
    -- implemented differently for speed.
    --
    -- > readTVarConc = atomically . readTVar
    --
    -- @since 1.0.0.0
    readTVarConc :: TVar (STM m) a -> m a
    readTVarConc = atomically . readTVar
  
    -- | Throw an exception to the target thread. This blocks until the
    -- exception is delivered, and it is just as if the target thread
    -- had raised it with 'throw'. This can interrupt a blocked action.
    --
    -- @since 1.0.0.0
    throwTo :: Exception e => ThreadId m -> e -> m ()
  
    -- | Return the 'MaskingState' for the current thread.
    --
    -- @since 1.10.0.0
    getMaskingState :: m MaskingState
  
    -- | Set the 'MaskingState' for the current thread to 'MaskedUninterruptible'.
    --
    -- @since 1.11.0.0
    unsafeUnmask :: m a -> m a
  
  -------------------------------------------------------------------------------
  -- Utilities
  
  -- Threads
  
  -- | Fork a computation to happen concurrently. Communication may
  -- happen over @MVar@s.
  --
  -- @since 1.5.0.0
  fork :: MonadConc m => m () -> m (ThreadId m)
  fork ma = forkWithUnmask (\_ -> ma)
  
  -- | Fork a computation to happen on a specific processor. The
  -- specified int is the /capability number/, typically capabilities
  -- correspond to physical processors or cores but this is
  -- implementation dependent. The int is interpreted modulo to the
  -- total number of capabilities as returned by 'getNumCapabilities'.
  --
  -- @since 1.5.0.0
  forkOn :: MonadConc m => Int -> m () -> m (ThreadId m)
  forkOn c ma = forkOnWithUnmask c (\_ -> ma)
  
  -- | Fork a computation to happen in a /bound thread/, which is
  -- necessary if you need to call foreign (non-Haskell) libraries
  -- that make use of thread-local state, such as OpenGL.
  --
  -- @since 1.5.0.0
  forkOS :: MonadConc m => m () -> m (ThreadId m)
  forkOS ma = forkOSWithUnmask (\_ -> ma)
  
  -- | Fork a thread and call the supplied function when the thread is
  -- about to terminate, with an exception or a returned value. The
  -- function is called with asynchronous exceptions masked.
  --
  -- This function is useful for informing the parent when a child
  -- terminates, for example.
  --
  -- @since 1.0.0.0
  forkFinally :: MonadConc m => m a -> (Either SomeException a -> m ()) -> m (ThreadId m)
  forkFinally action and_then =
    mask $ \restore ->
      fork $ Ca.try (restore action) >>= and_then
  
  -- | Create a concurrent computation for the provided action, and
  -- return a @MVar@ which can be used to query the result.
  --
  -- @since 1.0.0.0
  spawn :: MonadConc m => m a -> m (MVar m a)
  spawn ma = do
    cvar <- newEmptyMVar
    _ <- fork $ ma >>= putMVar cvar
    pure cvar
  
  -- | Raise the 'ThreadKilled' exception in the target thread. Note
  -- that if the thread is prepared to catch this exception, it won't
  -- actually kill it.
  --
  -- @since 1.0.0.0
  killThread :: MonadConc m => ThreadId m -> m ()
  killThread tid = throwTo tid ThreadKilled
  
  -- | Like 'fork', but the thread is given a name which may be used to
  -- present more useful debugging information.
  --
  -- @since 1.0.0.0
  forkN :: MonadConc m => String -> m () -> m (ThreadId m)
  forkN name ma = forkWithUnmaskN name (\_ -> ma)
  
  -- | Like 'forkOn', but the thread is given a name which may be used
  -- to present more useful debugging information.
  --
  -- @since 1.0.0.0
  forkOnN :: MonadConc m => String -> Int -> m () -> m (ThreadId m)
  forkOnN name i ma = forkOnWithUnmaskN name i (\_ -> ma)
  
  -- | Like 'forkOS', but the thread is given a name which may be used
  -- to present more useful debugging information.
  --
  -- @since 1.5.0.0
  forkOSN :: MonadConc m => String -> m () -> m (ThreadId m)
  forkOSN name ma = forkOSWithUnmaskN name (\_ -> ma)
  
  -- | 'True' if bound threads are supported.  If
  -- 'rtsSupportsBoundThreads' is 'False', 'isCurrentThreadBound' will
  -- always return 'False' and both 'forkOS' and 'runInBoundThread' will
  -- fail.
  --
  -- Use 'supportsBoundThreads' in 'MonadConc' instead.
  --
  -- @since 1.3.0.0
  {-# DEPRECATED rtsSupportsBoundThreads "Use 'supportsBoundThreads' instead" #-}
  rtsSupportsBoundThreads :: Bool
  rtsSupportsBoundThreads = IO.rtsSupportsBoundThreads
  
  -- | Run the computation passed as the first argument.  If the calling
  -- thread is not /bound/, a bound thread is created temporarily.
  -- @runInBoundThread@ doesn't finish until the inner computation
  -- finishes.
  --
  -- You can wrap a series of foreign function calls that rely on
  -- thread-local state with @runInBoundThread@ so that you can use them
  -- without knowing whether the current thread is /bound/.
  --
  -- @since 1.3.0.0
  runInBoundThread :: MonadConc m => m a -> m a
  runInBoundThread =
    runInThread (not <$> isCurrentThreadBound) (forkOSN "runInBoundThread")
  
  -- | Run the computation passed as the first argument. If the calling
  -- thread is /bound/, an unbound thread is created temporarily using
  -- @fork@.  @runInBoundThread@ doesn't finish until the inner
  -- computation finishes.
  --
  -- Use this function /only/ in the rare case that you have actually
  -- observed a performance loss due to the use of bound threads. A
  -- program that doesn't need its main thread to be bound and makes
  -- /heavy/ use of concurrency (e.g. a web server), might want to wrap
  -- its @main@ action in @runInUnboundThread@.
  --
  -- Note that exceptions which are thrown to the current thread are
  -- thrown in turn to the thread that is executing the given
  -- computation. This ensures there's always a way of killing the
  -- forked thread.
  --
  -- @since 1.3.0.0
  runInUnboundThread :: MonadConc m => m a -> m a
  runInUnboundThread =
    runInThread isCurrentThreadBound (forkN "runInUnboundThread")
  
  -- | Helper for 'runInBoundThread' and 'runInUnboundThread'
  runInThread :: MonadConc m => m Bool -> (m () -> m (ThreadId m)) -> m a -> m a
  runInThread check dofork action = do
    flag <- check
    if flag
      then do
        mv <- newEmptyMVar
        mask $ \restore -> do
          tid <- dofork $ Ca.try (restore action) >>= putMVar mv
          let wait = takeMVar mv `catch` \(e :: SomeException) -> throwTo tid e >> wait
          wait >>= either (\(e :: SomeException) -> throw e) pure
      else action
  
  -- Exceptions
  
  -- | Throw an exception. This will \"bubble up\" looking for an
  -- exception handler capable of dealing with it and, if one is not
  -- found, the thread is killed.
  --
  -- @since 1.0.0.0
  throw :: (MonadConc m, Exception e) => e -> m a
  throw = Ca.throwM
  
  -- | Catch an exception. This is only required to be able to catch
  -- exceptions raised by 'throw', unlike the more general
  -- Control.Exception.catch function. If you need to be able to catch
  -- /all/ errors, you will have to use 'IO'.
  --
  -- @since 1.0.0.0
  catch :: (MonadConc m, Exception e) => m a -> (e -> m a) -> m a
  catch = Ca.catch
  
  -- | Executes a computation with asynchronous exceptions
  -- /masked/. That is, any thread which attempts to raise an exception
  -- in the current thread with 'throwTo' will be blocked until
  -- asynchronous exceptions are unmasked again.
  --
  -- The argument passed to mask is a function that takes as its
  -- argument another function, which can be used to restore the
  -- prevailing masking state within the context of the masked
  -- computation. This function should not be used within an
  -- 'uninterruptibleMask'.
  --
  -- @since 1.0.0.0
  mask :: MonadConc m => ((forall a. m a -> m a) -> m b) -> m b
  mask = Ca.mask
  
  -- | Like 'mask', but the masked computation is not
  -- interruptible. THIS SHOULD BE USED WITH GREAT CARE, because if a
  -- thread executing in 'uninterruptibleMask' blocks for any reason,
  -- then the thread (and possibly the program, if this is the main
  -- thread) will be unresponsive and unkillable. This function should
  -- only be necessary if you need to mask exceptions around an
  -- interruptible operation, and you can guarantee that the
  -- interruptible operation will only block for a short period of
  -- time. The supplied unmasking function should not be used within a
  -- 'mask'.
  --
  -- @since 1.0.0.0
  uninterruptibleMask :: MonadConc m => ((forall a. m a -> m a) -> m b) -> m b
  uninterruptibleMask = Ca.uninterruptibleMask
  
  -- | Allow asynchronous exceptions to be raised even inside 'mask',
  -- making the operation interruptible.
  --
  -- When called outside 'mask', or inside 'uninterruptibleMask', this
  -- function has no effect.
  --
  -- @since 1.11.0.0
  interruptible :: MonadConc m => m a -> m a
  interruptible act = do
    st <- getMaskingState
    case st of
      Unmasked              -> act
      MaskedInterruptible   -> unsafeUnmask act
      MaskedUninterruptible -> act
  
  -- Mutable Variables
  
  -- | Create a new @MVar@ containing a value.
  --
  -- @since 1.0.0.0
  newMVar :: MonadConc m => a -> m (MVar m a)
  newMVar a = do
    cvar <- newEmptyMVar
    putMVar cvar a
    pure cvar
  
  -- | Create a new @MVar@ containing a value, but it is given a name
  -- which may be used to present more useful debugging information.
  --
  -- @since 1.0.0.0
  newMVarN :: MonadConc m => String -> a -> m (MVar m a)
  newMVarN n a = do
    cvar <- newEmptyMVarN n
    putMVar cvar a
    pure cvar
  
  -- | Extract the actual Haskell value from a @Ticket@.
  --
  -- This doesn't do do any monadic computation, the @m@ appears in the
  -- result type to determine the @m@ in the @Ticket@ type.
  --
  -- @since 1.0.0.0
  peekTicket :: forall m a. MonadConc m => Ticket m a -> m a
  peekTicket t = pure $ peekTicket' (Proxy :: Proxy m) (t :: Ticket m a)
  
  -- | Compare-and-swap a value in a @IORef@, returning an indication of
  -- success and the new value.
  --
  -- @since 1.6.0.0
  cas :: MonadConc m => IORef m a -> a -> m (Bool, a)
  cas ioref a = do
    tick         <- readForCAS ioref
    (suc, tick') <- casIORef ioref tick a
    a'           <- peekTicket tick'
  
    pure (suc, a')
  
  -------------------------------------------------------------------------------
  -- Concrete instances
  
  -- | @since 1.0.0.0
  instance MonadConc IO where
    type STM      IO = IO.STM
    type MVar     IO = IO.MVar
    type IORef    IO = IO.IORef
    type Ticket   IO = IO.Ticket
    type ThreadId IO = IO.ThreadId
  
    forkWithUnmask   = IO.forkIOWithUnmask
    forkOnWithUnmask = IO.forkOnWithUnmask
    forkOSWithUnmask = IO.forkOSWithUnmask
  
    forkWithUnmaskN n ma = forkWithUnmask $ \umask -> do
      labelMe n
      ma umask
  
    forkOnWithUnmaskN n i ma = forkOnWithUnmask i $ \umask -> do
      labelMe n
      ma umask
  
    forkOSWithUnmaskN n ma = forkOSWithUnmask $ \umask -> do
      labelMe n
      ma umask
  
    supportsBoundThreads = pure IO.rtsSupportsBoundThreads
    isCurrentThreadBound = IO.isCurrentThreadBound
  
    getNumCapabilities  = IO.getNumCapabilities
    setNumCapabilities  = IO.setNumCapabilities
    readMVar            = IO.readMVar
    tryReadMVar         = IO.tryReadMVar
    myThreadId          = IO.myThreadId
    yield               = IO.yield
    threadDelay         = IO.threadDelay
    throwTo             = IO.throwTo
    newEmptyMVar        = IO.newEmptyMVar
    putMVar             = IO.putMVar
    tryPutMVar          = IO.tryPutMVar
    takeMVar            = IO.takeMVar
    tryTakeMVar         = IO.tryTakeMVar
    newIORef            = IO.newIORef
    readIORef           = IO.readIORef
    atomicModifyIORef   = IO.atomicModifyIORef
    writeIORef          = IO.writeIORef
    atomicWriteIORef    = IO.atomicWriteIORef
    readForCAS          = IO.readForCAS
    peekTicket' _       = IO.peekTicket
    casIORef            = IO.casIORef
    modifyIORefCAS      = IO.atomicModifyIORefCAS
    atomically          = IO.atomically
    newTVarConc         = IO.newTVarIO
    readTVarConc        = IO.readTVarIO
    getMaskingState     = IO.getMaskingState
    unsafeUnmask        = IO.unsafeUnmask
  
  -- | Label the current thread, if the given label is nonempty.
  labelMe :: String -> IO ()
  labelMe "" = pure ()
  labelMe n  = do
    tid <- myThreadId
    IO.labelThread tid n
  
  -------------------------------------------------------------------------------
  -- Type shenanigans
  
  -- | A value of type @IsConc m a@ can only be constructed if @m@ has a
  -- @MonadConc@ instance.
  --
  -- @since 1.2.2.0
  newtype IsConc m a = IsConc { unIsConc :: m a }
    deriving (Functor, Applicative, Monad, MonadThrow, MonadCatch, MonadMask)
  
  -- | @since 1.8.0.0
  deriving instance MonadFail m => MonadFail (IsConc m)
  
  -- | Wrap an @m a@ value inside an @IsConc@ if @m@ has a @MonadConc@
  -- instance.
  --
  -- @since 1.2.2.0
  toIsConc :: MonadConc m => m a -> IsConc m a
  toIsConc = IsConc
  
  -- | Unwrap an @IsConc@ value.
  --
  -- @since 1.2.2.0
  fromIsConc :: MonadConc m => IsConc m a -> m a
  fromIsConc = unIsConc
  
  instance MonadConc m => MonadConc (IsConc m) where
    type STM      (IsConc m) = IsSTM (STM m)
    type MVar     (IsConc m) = MVar     m
    type IORef    (IsConc m) = IORef    m
    type Ticket   (IsConc m) = Ticket   m
    type ThreadId (IsConc m) = ThreadId m
  
    forkWithUnmask        ma = toIsConc (forkWithUnmask        (\umask -> unIsConc $ ma (\mx -> toIsConc (umask $ unIsConc mx))))
    forkWithUnmaskN   n   ma = toIsConc (forkWithUnmaskN   n   (\umask -> unIsConc $ ma (\mx -> toIsConc (umask $ unIsConc mx))))
    forkOnWithUnmask    i ma = toIsConc (forkOnWithUnmask    i (\umask -> unIsConc $ ma (\mx -> toIsConc (umask $ unIsConc mx))))
    forkOnWithUnmaskN n i ma = toIsConc (forkOnWithUnmaskN n i (\umask -> unIsConc $ ma (\mx -> toIsConc (umask $ unIsConc mx))))
    forkOSWithUnmask      ma = toIsConc (forkOSWithUnmask      (\umask -> unIsConc $ ma (\mx -> toIsConc (umask $ unIsConc mx))))
    forkOSWithUnmaskN n   ma = toIsConc (forkOSWithUnmaskN n   (\umask -> unIsConc $ ma (\mx -> toIsConc (umask $ unIsConc mx))))
    unsafeUnmask          ma = toIsConc (unsafeUnmask (unIsConc ma))
  
    supportsBoundThreads = toIsConc supportsBoundThreads
    isCurrentThreadBound = toIsConc isCurrentThreadBound
  
    getNumCapabilities  = toIsConc getNumCapabilities
    setNumCapabilities  = toIsConc . setNumCapabilities
    myThreadId          = toIsConc myThreadId
    yield               = toIsConc yield
    threadDelay         = toIsConc . threadDelay
    throwTo t           = toIsConc . throwTo t
    newEmptyMVar        = toIsConc newEmptyMVar
    newEmptyMVarN       = toIsConc . newEmptyMVarN
    readMVar            = toIsConc . readMVar
    tryReadMVar         = toIsConc . tryReadMVar
    putMVar v           = toIsConc . putMVar v
    tryPutMVar v        = toIsConc . tryPutMVar v
    takeMVar            = toIsConc . takeMVar
    tryTakeMVar         = toIsConc . tryTakeMVar
    newIORef            = toIsConc . newIORef
    newIORefN n         = toIsConc . newIORefN n
    readIORef           = toIsConc . readIORef
    atomicModifyIORef r = toIsConc . atomicModifyIORef r
    writeIORef r        = toIsConc . writeIORef r
    atomicWriteIORef r  = toIsConc . atomicWriteIORef r
    readForCAS          = toIsConc . readForCAS
    peekTicket' _       = peekTicket' (Proxy :: Proxy m)
    casIORef r t        = toIsConc . casIORef r t
    modifyIORefCAS r    = toIsConc . modifyIORefCAS r
    modifyIORefCAS_ r   = toIsConc . modifyIORefCAS_ r
    atomically          = toIsConc . atomically . fromIsSTM
    newTVarConc         = toIsConc . newTVarConc
    readTVarConc        = toIsConc . readTVarConc
    getMaskingState     = toIsConc getMaskingState
  
  -------------------------------------------------------------------------------
  -- Transformer instances
  
  #define INSTANCE(T,C,F)                                          \
  instance C => MonadConc (T m) where                            { \
    type STM      (T m) = STM m                                  ; \
    type MVar     (T m) = MVar m                                 ; \
    type IORef    (T m) = IORef m                                ; \
    type Ticket   (T m) = Ticket m                               ; \
    type ThreadId (T m) = ThreadId m                             ; \
                                                                   \
    forkWithUnmask        = liftedFork F forkWithUnmask          ; \
    forkWithUnmaskN   n   = liftedFork F (forkWithUnmaskN   n  ) ; \
    forkOnWithUnmask    i = liftedFork F (forkOnWithUnmask    i) ; \
    forkOnWithUnmaskN n i = liftedFork F (forkOnWithUnmaskN n i) ; \
    forkOSWithUnmask      = liftedFork F forkOSWithUnmask        ; \
    forkOSWithUnmaskN n   = liftedFork F (forkOSWithUnmaskN n  ) ; \
                                                                   \
    supportsBoundThreads = lift supportsBoundThreads             ; \
    isCurrentThreadBound = lift isCurrentThreadBound             ; \
                                                                   \
    getNumCapabilities  = lift getNumCapabilities                ; \
    setNumCapabilities  = lift . setNumCapabilities              ; \
    myThreadId          = lift myThreadId                        ; \
    yield               = lift yield                             ; \
    threadDelay         = lift . threadDelay                     ; \
    throwTo t           = lift . throwTo t                       ; \
    newEmptyMVar        = lift newEmptyMVar                      ; \
    newEmptyMVarN       = lift . newEmptyMVarN                   ; \
    readMVar            = lift . readMVar                        ; \
    tryReadMVar         = lift . tryReadMVar                     ; \
    putMVar v           = lift . putMVar v                       ; \
    tryPutMVar v        = lift . tryPutMVar v                    ; \
    takeMVar            = lift . takeMVar                        ; \
    tryTakeMVar         = lift . tryTakeMVar                     ; \
    newIORef            = lift . newIORef                        ; \
    newIORefN n         = lift . newIORefN n                     ; \
    readIORef           = lift . readIORef                       ; \
    atomicModifyIORef r = lift . atomicModifyIORef r             ; \
    writeIORef r        = lift . writeIORef r                    ; \
    atomicWriteIORef r  = lift . atomicWriteIORef r              ; \
    readForCAS          = lift . readForCAS                      ; \
    peekTicket' _       = peekTicket' (Proxy :: Proxy m)         ; \
    casIORef r t        = lift . casIORef r t                    ; \
    modifyIORefCAS r    = lift . modifyIORefCAS r                ; \
    modifyIORefCAS_ r   = lift . modifyIORefCAS_ r               ; \
    atomically          = lift . atomically                      ; \
    newTVarConc         = lift . newTVarConc                     ; \
    readTVarConc        = lift . readTVarConc                    ; \
    getMaskingState     = lift getMaskingState                   ; \
    unsafeUnmask        = liftedF F unsafeUnmask                 }
  
  -- | New threads inherit the reader state of their parent, but do not
  -- communicate results back.
  --
  -- @since 1.0.0.0
  INSTANCE(ReaderT r, MonadConc m, id)
  
  -- | @since 1.0.0.0
  INSTANCE(IdentityT, MonadConc m, id)
  
  -- | New threads inherit the writer state of their parent, but do not
  -- communicate results back.
  --
  -- @since 1.0.0.0
  INSTANCE(WL.WriterT w, (MonadConc m, Monoid w), fst)
  
  -- | New threads inherit the writer state of their parent, but do not
  -- communicate results back.
  --
  -- @since 1.0.0.0
  INSTANCE(WS.WriterT w, (MonadConc m, Monoid w), fst)
  
  -- | New threads inherit the state of their parent, but do not
  -- communicate results back.
  --
  -- @since 1.0.0.0
  INSTANCE(SL.StateT s, MonadConc m, fst)
  
  -- | New threads inherit the state of their parent, but do not
  -- communicate results back.
  --
  -- @since 1.0.0.0
  INSTANCE(SS.StateT s, MonadConc m, fst)
  
  -- | New threads inherit the states of their parent, but do not
  -- communicate results back.
  --
  -- @since 1.0.0.0
  INSTANCE(RL.RWST r w s, (MonadConc m, Monoid w), (\(a,_,_) -> a))
  
  -- | New threads inherit the states of their parent, but do not
  -- communicate results back.
  --
  -- @since 1.0.0.0
  INSTANCE(RS.RWST r w s, (MonadConc m, Monoid w), (\(a,_,_) -> a))
  
  #undef INSTANCE
  
  -------------------------------------------------------------------------------
  
  -- | Given a function to remove the transformer-specific state, lift
  -- a function invocation.
  --
  -- @since 1.0.0.0
  liftedF :: (MonadTransControl t, MonadConc m)
    => (forall x. StT t x -> x)
    -> (m a -> m b)
    -> t m a
    -> t m b
  liftedF unst f ma = liftWith $ \run -> f (unst <$> run ma)
  
  -- | Given a function to remove the transformer-specific state, lift
  -- a @fork(on)WithUnmask@ invocation.
  --
  -- @since 1.0.0.0
  liftedFork :: (MonadTransControl t, MonadConc m)
    => (forall x. StT t x -> x)
    -> (((forall x. m x -> m x) -> m a) -> m b)
    -> ((forall x. t m x -> t m x) -> t m a)
    -> t m b
  liftedFork unst f ma = liftWith $ \run ->
    f (\unmask -> unst <$> run (ma $ liftedF unst unmask))
  