{-# 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 :: e -> ViaAlg s Mask m a
throwM = [Char] -> e -> ViaAlg s Mask m a
forall a. HasCallStack => [Char] -> a
error "threadMaskViaClass: Transformers threading Mask \
                 \are not allowed to use throwM."

instance Monad m => MonadCatch (ViaAlg s Mask m) where
  catch :: ViaAlg s Mask m a -> (e -> ViaAlg s Mask m a) -> ViaAlg s Mask m a
catch = [Char]
-> ViaAlg s Mask m a
-> (e -> ViaAlg s Mask m a)
-> ViaAlg s Mask m a
forall a. HasCallStack => [Char] -> a
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 :: ((forall a. ViaAlg s Mask m a -> ViaAlg s Mask m a)
 -> ViaAlg s Mask m b)
-> ViaAlg s Mask m b
mask (forall a. ViaAlg s Mask m a -> ViaAlg s Mask m a)
-> ViaAlg s Mask m b
main = case forall a. Reifies s a => a
forall k (s :: k) a. Reifies s a => a
reflect @s of
    ReifiedEffAlgebra forall x. Mask m x -> m x
alg -> (Mask m b -> m b) -> Mask (ViaAlg s Mask m) b -> ViaAlg s Mask m b
forall (n :: * -> *) (m :: * -> *) (e :: Effect) a b.
(Coercible n m, RepresentationalEff e) =>
(e m a -> m b) -> e n a -> n b
coerceAlg Mask m b -> m b
forall x. Mask m x -> m x
alg (MaskMode
-> ((forall a. ViaAlg s Mask m a -> ViaAlg s Mask m a)
    -> ViaAlg s Mask m b)
-> Mask (ViaAlg s Mask m) b
forall (m :: * -> *) a.
MaskMode -> ((forall x. m x -> m x) -> m a) -> Mask m a
Mask MaskMode
InterruptibleMask (forall a. ViaAlg s Mask m a -> ViaAlg s Mask m a)
-> ViaAlg s Mask m b
main)
  {-# INLINE mask #-}

  uninterruptibleMask :: ((forall a. ViaAlg s Mask m a -> ViaAlg s Mask m a)
 -> ViaAlg s Mask m b)
-> ViaAlg s Mask m b
uninterruptibleMask (forall a. ViaAlg s Mask m a -> ViaAlg s Mask m a)
-> ViaAlg s Mask m b
main = case forall a. Reifies s a => a
forall k (s :: k) a. Reifies s a => a
reflect @s of
    ReifiedEffAlgebra forall x. Mask m x -> m x
alg -> (Mask m b -> m b) -> Mask (ViaAlg s Mask m) b -> ViaAlg s Mask m b
forall (n :: * -> *) (m :: * -> *) (e :: Effect) a b.
(Coercible n m, RepresentationalEff e) =>
(e m a -> m b) -> e n a -> n b
coerceAlg Mask m b -> m b
forall x. Mask m x -> m x
alg (MaskMode
-> ((forall a. ViaAlg s Mask m a -> ViaAlg s Mask m a)
    -> ViaAlg s Mask m b)
-> Mask (ViaAlg s Mask m) b
forall (m :: * -> *) a.
MaskMode -> ((forall x. m x -> m x) -> m a) -> Mask m a
Mask MaskMode
UninterruptibleMask (forall a. ViaAlg s Mask m a -> ViaAlg s Mask m a)
-> ViaAlg s Mask m b
main)
  {-# INLINE uninterruptibleMask #-}

  generalBracket :: ViaAlg s Mask m a
-> (a -> ExitCase b -> ViaAlg s Mask m c)
-> (a -> ViaAlg s Mask m b)
-> ViaAlg s Mask m (b, c)
generalBracket = [Char]
-> ViaAlg s Mask m a
-> (a -> ExitCase b -> ViaAlg s Mask m c)
-> (a -> ViaAlg s Mask m b)
-> ViaAlg s Mask m (b, c)
forall a. HasCallStack => [Char] -> a
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 :: (forall x. Mask m x -> m x) -> Mask (t m) a -> t m a
threadMaskViaClass forall x. Mask m x -> m x
alg (Mask MaskMode
mode (forall x. t m x -> t m x) -> t m a
main) =
  ReifiedEffAlgebra Mask m
-> (forall s (pr :: * -> *).
    (pr ~ Proxy, Reifies s (ReifiedEffAlgebra Mask m)) =>
    pr s -> t m a)
-> t m a
forall a r.
a
-> (forall s (pr :: * -> *).
    (pr ~ Proxy, Reifies s a) =>
    pr s -> r)
-> r
reify ((forall x. Mask m x -> m x) -> ReifiedEffAlgebra Mask m
forall k (e :: (k -> *) -> k -> *) (m :: k -> *).
(forall (x :: k). e m x -> m x) -> ReifiedEffAlgebra e m
ReifiedEffAlgebra forall x. Mask m x -> m x
alg) ((forall s (pr :: * -> *).
  (pr ~ Proxy, Reifies s (ReifiedEffAlgebra Mask m)) =>
  pr s -> t m a)
 -> t m a)
-> (forall s (pr :: * -> *).
    (pr ~ Proxy, Reifies s (ReifiedEffAlgebra Mask m)) =>
    pr s -> t m a)
-> t m a
forall a b. (a -> b) -> a -> b
$ \(pr s
_ :: pr s) ->
    t (ViaAlg s Mask m) a -> t m a
forall s (e :: Effect) (t :: Effect) (m :: * -> *) a.
RepresentationalT t =>
t (ViaAlg s e m) a -> t m a
unViaAlgT (t (ViaAlg s Mask m) a -> t m a) -> t (ViaAlg s Mask m) a -> t m a
forall a b. (a -> b) -> a -> b
$ case MaskMode
mode of
      MaskMode
InterruptibleMask -> ((forall a. t (ViaAlg s Mask m) a -> t (ViaAlg s Mask m) a)
 -> t (ViaAlg s Mask m) a)
-> t (ViaAlg s Mask m) a
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
C.mask (((forall a. t (ViaAlg s Mask m) a -> t (ViaAlg s Mask m) a)
  -> t (ViaAlg s Mask m) a)
 -> t (ViaAlg s Mask m) a)
-> ((forall a. t (ViaAlg s Mask m) a -> t (ViaAlg s Mask m) a)
    -> t (ViaAlg s Mask m) a)
-> t (ViaAlg s Mask m) a
forall a b. (a -> b) -> a -> b
$ \forall a. t (ViaAlg s Mask m) a -> t (ViaAlg s Mask m) a
restore ->
        forall s (e :: Effect) (t :: Effect) (m :: * -> *) a.
RepresentationalT t =>
t m a -> t (ViaAlg s e m) a
forall (t :: Effect) (m :: * -> *) a.
RepresentationalT t =>
t m a -> t (ViaAlg s Mask m) a
viaAlgT @s @Mask (t m a -> t (ViaAlg s Mask m) a) -> t m a -> t (ViaAlg s Mask m) a
forall a b. (a -> b) -> a -> b
$ (forall x. t m x -> t m x) -> t m a
main ((t (ViaAlg s Mask m) x -> t (ViaAlg s Mask m) x) -> t m x -> t m x
forall s (e :: Effect) (t :: Effect) (m :: * -> *) (n :: * -> *) a
       b.
RepresentationalT t =>
(t (ViaAlg s e m) a -> t (ViaAlg s e n) b) -> t m a -> t n b
mapUnViaAlgT t (ViaAlg s Mask m) x -> t (ViaAlg s Mask m) x
forall a. t (ViaAlg s Mask m) a -> t (ViaAlg s Mask m) a
restore)
      MaskMode
UninterruptibleMask -> ((forall a. t (ViaAlg s Mask m) a -> t (ViaAlg s Mask m) a)
 -> t (ViaAlg s Mask m) a)
-> t (ViaAlg s Mask m) a
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
C.uninterruptibleMask (((forall a. t (ViaAlg s Mask m) a -> t (ViaAlg s Mask m) a)
  -> t (ViaAlg s Mask m) a)
 -> t (ViaAlg s Mask m) a)
-> ((forall a. t (ViaAlg s Mask m) a -> t (ViaAlg s Mask m) a)
    -> t (ViaAlg s Mask m) a)
-> t (ViaAlg s Mask m) a
forall a b. (a -> b) -> a -> b
$ \forall a. t (ViaAlg s Mask m) a -> t (ViaAlg s Mask m) a
restore ->
        forall s (e :: Effect) (t :: Effect) (m :: * -> *) a.
RepresentationalT t =>
t m a -> t (ViaAlg s e m) a
forall (t :: Effect) (m :: * -> *) a.
RepresentationalT t =>
t m a -> t (ViaAlg s Mask m) a
viaAlgT @s @Mask (t m a -> t (ViaAlg s Mask m) a) -> t m a -> t (ViaAlg s Mask m) a
forall a b. (a -> b) -> a -> b
$ (forall x. t m x -> t m x) -> t m a
main ((t (ViaAlg s Mask m) x -> t (ViaAlg s Mask m) x) -> t m x -> t m x
forall s (e :: Effect) (t :: Effect) (m :: * -> *) (n :: * -> *) a
       b.
RepresentationalT t =>
(t (ViaAlg s e m) a -> t (ViaAlg s e n) b) -> t m a -> t n b
mapUnViaAlgT t (ViaAlg s Mask m) x -> t (ViaAlg s Mask m) x
forall a. t (ViaAlg s Mask m) a -> t (ViaAlg s Mask m) a
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 :: (forall x. Mask m x -> m x)
-> Mask (WriterT s m) a -> WriterT s m a
threadEff forall x. Mask m x -> m x
alg (Mask MaskMode
mode (forall x. WriterT s m x -> WriterT s m x) -> WriterT s m a
main) = m (a, s) -> WriterT s m a
forall (m :: * -> *) w a.
(Functor m, Monoid w) =>
m (a, w) -> WriterT w m a
CPSWr.writerT (m (a, s) -> WriterT s m a) -> m (a, s) -> WriterT s m a
forall a b. (a -> b) -> a -> b
$ Mask m (a, s) -> m (a, s)
forall x. Mask m x -> m x
alg (Mask m (a, s) -> m (a, s)) -> Mask m (a, s) -> m (a, s)
forall a b. (a -> b) -> a -> b
$ MaskMode -> ((forall x. m x -> m x) -> m (a, s)) -> Mask m (a, s)
forall (m :: * -> *) a.
MaskMode -> ((forall x. m x -> m x) -> m a) -> Mask m a
Mask MaskMode
mode (((forall x. m x -> m x) -> m (a, s)) -> Mask m (a, s))
-> ((forall x. m x -> m x) -> m (a, s)) -> Mask m (a, s)
forall a b. (a -> b) -> a -> b
$ \forall x. m x -> m x
restore ->
    WriterT s m a -> m (a, s)
forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
CPSWr.runWriterT ((forall x. WriterT s m x -> WriterT s m x) -> WriterT s m a
main ((m (x, s) -> m (x, s)) -> WriterT s m x -> WriterT s m x
forall (n :: * -> *) w w' (m :: * -> *) a b.
(Monad n, Monoid w, Monoid w') =>
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
CPSWr.mapWriterT m (x, s) -> m (x, s)
forall x. m x -> m x
restore))
  {-# INLINE threadEff #-}