content: {-# LANGUAGE CPP #-}
  {-# OPTIONS_HADDOCK not-home #-}
  module Control.Effect.Type.Mask
   ( -- * Effects
     Mask(..)
   , MaskMode(..)
  
     -- * Threading utilities
   , threadMaskViaClass
   ) where
  
  import Control.Effect.Internal.Union
  import Control.Effect.Internal.Reflection
  import Control.Effect.Internal.ViaAlg
  import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
  import qualified Control.Monad.Catch as C
  import Control.Monad.Trans.Reader (ReaderT)
  import Control.Monad.Trans.Except (ExceptT)
  import qualified Control.Monad.Trans.State.Strict as SSt
  import qualified Control.Monad.Trans.State.Lazy as LSt
  import qualified Control.Monad.Trans.Writer.Lazy as LWr
  import qualified Control.Monad.Trans.Writer.Strict as SWr
  import qualified Control.Monad.Trans.Writer.CPS as CPSWr
  
  
  data MaskMode
    = InterruptibleMask
    | UninterruptibleMask
  
  -- | An effect for masking asynchronous exceptions.
  --
  -- __'Mask' is typically used as a primitive effect.__
  -- If you define a 'Control.Effect.Carrier' that relies on a novel
  -- non-trivial monad transformer @t@, then you need to make
  -- a @'ThreadsEff' t 'Mask'@ instance (if possible).
  -- 'threadMaskViaClass' can help you with that.
  --
  -- The following threading constraints accept 'Mask':
  --
  -- * 'Control.Effect.ReaderThreads'
  -- * 'Control.Effect.State.StateThreads'
  -- * 'Control.Effect.State.StateLazyThreads'
  -- * 'Control.Effect.Error.ErrorThreads'
  -- * 'Control.Effect.Writer.WriterThreads'
  -- * 'Control.Effect.Writer.WriterLazyThreads'
  data Mask :: Effect where
    Mask :: MaskMode
         -> ((forall x. m x -> m x) -> m a)
         -> Mask m a
  
  instance Monad m => MonadThrow (ViaAlg s Mask m) where
    throwM = error "threadMaskViaClass: Transformers threading Mask \
                   \are not allowed to use throwM."
  
  instance Monad m => MonadCatch (ViaAlg s Mask m) where
    catch = error "threadMaskViaClass: Transformers threading Mask \
                   \are not allowed to use catch."
  
  instance ( Reifies s (ReifiedEffAlgebra Mask m)
           , Monad m
           )
        => MonadMask (ViaAlg s Mask m) where
    mask main = case reflect @s of
      ReifiedEffAlgebra alg -> coerceAlg alg (Mask InterruptibleMask main)
    {-# INLINE mask #-}
  
    uninterruptibleMask main = case reflect @s of
      ReifiedEffAlgebra alg -> coerceAlg alg (Mask UninterruptibleMask main)
    {-# INLINE uninterruptibleMask #-}
  
    generalBracket = error "threadMaskViaClass: Transformers threading Mask \
                           \are not allowed to use generalBracket."
  
  -- | A valid definition of 'threadEff' for a @'ThreadsEff' t 'Mask'@ instance,
  -- given that @t@ lifts @'MonadMask'@.
  --
  -- __BEWARE__: 'threadMaskViaClass' is only safe if the implementation of
  -- 'Control.Monad.Catch.mask' and 'Control.Monad.Catch.uninterruptibleMask'
  -- for @t m@ only makes use of 'Conrol.Monad.Catch.mask'
  -- and 'Control.Monad.Catch.uninterruptibleMask' for @m@, and no other methods of
  -- 'MonadThrow', 'MonadCatch', and 'MonadMask'.
  threadMaskViaClass :: forall t m a
                      . Monad m
                     => ( RepresentationalT t
                        , forall b. MonadMask b => MonadMask (t b)
                        )
                     => (forall x. Mask m x -> m x)
                     -> Mask (t m) a -> t m a
  threadMaskViaClass alg (Mask mode main) =
    reify (ReifiedEffAlgebra alg) $ \(_ :: pr s) ->
      unViaAlgT $ case mode of
        InterruptibleMask -> C.mask $ \restore ->
          viaAlgT @s @Mask $ main (mapUnViaAlgT restore)
        UninterruptibleMask -> C.uninterruptibleMask $ \restore ->
          viaAlgT @s @Mask $ main (mapUnViaAlgT restore)
  {-# INLINE threadMaskViaClass #-}
  
  #define THREAD_MASK(monadT)             \
  instance ThreadsEff (monadT) Mask where \
    threadEff = threadMaskViaClass;       \
    {-# INLINE threadEff #-}
  
  #define THREAD_MASK_CTX(ctx, monadT)             \
  instance (ctx) => ThreadsEff (monadT) Mask where \
    threadEff = threadMaskViaClass;                \
    {-# INLINE threadEff #-}
  
  THREAD_MASK(ReaderT i)
  THREAD_MASK(ExceptT e)
  THREAD_MASK(LSt.StateT s)
  THREAD_MASK(SSt.StateT s)
  THREAD_MASK_CTX(Monoid s, LWr.WriterT s)
  THREAD_MASK_CTX(Monoid s, SWr.WriterT s)
  
  instance Monoid s => ThreadsEff (CPSWr.WriterT s) Mask where
    threadEff alg (Mask mode main) = CPSWr.writerT $ alg $ Mask mode $ \restore ->
      CPSWr.runWriterT (main (CPSWr.mapWriterT restore))
    {-# INLINE threadEff #-}
  