{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK not-home #-}
module Control.Effect.Type.Bracket
 ( -- * Effects
   Bracket(..)
 , ExitCase(..)

   -- * Threading utilities
 , threadBracketViaClass
 ) where

import Control.Effect.Internal.Union
import Control.Effect.Internal.Utils
import Control.Effect.Internal.Reflection
import Control.Effect.Internal.ViaAlg
-- import qualified Control.Exception as X
import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask, ExitCase(..))
import qualified Control.Monad.Catch as C
-- import Control.Applicative
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


-- | An effect for exception-safe acquisition and release of resources.
--
-- __'Bracket' 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 'Bracket'@ instance (if possible).
-- 'threadBracketViaClass' can help you with that.
--
-- The following threading constraints accept 'Bracket':
--
-- * 'Control.Effect.ReaderThreads'
-- * 'Control.Effect.State.StateThreads'
-- * 'Control.Effect.State.StateLazyThreads'
-- * 'Control.Effect.Error.ErrorThreads'
-- * 'Control.Effect.Writer.WriterThreads'
-- * 'Control.Effect.Writer.WriterLazyThreads'
data Bracket :: Effect where
  GeneralBracket :: m a
                 -> (a -> ExitCase b -> m c)
                 -> (a -> m b)
                 -> Bracket m (b, c)

instance Monad m => MonadThrow (ViaAlg s Bracket m) where
  throwM :: e -> ViaAlg s Bracket m a
throwM = [Char] -> e -> ViaAlg s Bracket m a
forall a. HasCallStack => [Char] -> a
error "threadBracketViaClass: Transformers threading Bracket \
                 \are not allowed to use throwM."
instance Monad m => MonadCatch (ViaAlg s Bracket m) where
  catch :: ViaAlg s Bracket m a
-> (e -> ViaAlg s Bracket m a) -> ViaAlg s Bracket m a
catch = [Char]
-> ViaAlg s Bracket m a
-> (e -> ViaAlg s Bracket m a)
-> ViaAlg s Bracket m a
forall a. HasCallStack => [Char] -> a
error "threadBracketViaClass: Transformers threading Bracket \
                 \are not allowed to use catch."

instance ( Reifies s (ReifiedEffAlgebra Bracket m)
         , Monad m
         )
       => MonadMask (ViaAlg s Bracket m) where
  mask :: ((forall a. ViaAlg s Bracket m a -> ViaAlg s Bracket m a)
 -> ViaAlg s Bracket m b)
-> ViaAlg s Bracket m b
mask (forall a. ViaAlg s Bracket m a -> ViaAlg s Bracket m a)
-> ViaAlg s Bracket m b
m = (forall a. ViaAlg s Bracket m a -> ViaAlg s Bracket m a)
-> ViaAlg s Bracket m b
m forall a. a -> a
forall a. ViaAlg s Bracket m a -> ViaAlg s Bracket m a
id
  uninterruptibleMask :: ((forall a. ViaAlg s Bracket m a -> ViaAlg s Bracket m a)
 -> ViaAlg s Bracket m b)
-> ViaAlg s Bracket m b
uninterruptibleMask (forall a. ViaAlg s Bracket m a -> ViaAlg s Bracket m a)
-> ViaAlg s Bracket m b
m = (forall a. ViaAlg s Bracket m a -> ViaAlg s Bracket m a)
-> ViaAlg s Bracket m b
m forall a. a -> a
forall a. ViaAlg s Bracket m a -> ViaAlg s Bracket m a
id

  generalBracket :: ViaAlg s Bracket m a
-> (a -> ExitCase b -> ViaAlg s Bracket m c)
-> (a -> ViaAlg s Bracket m b)
-> ViaAlg s Bracket m (b, c)
generalBracket ViaAlg s Bracket m a
acquire a -> ExitCase b -> ViaAlg s Bracket m c
release a -> ViaAlg s Bracket m b
use = case forall a. Reifies s a => a
forall k (s :: k) a. Reifies s a => a
reflect @s of
    ReifiedEffAlgebra forall x. Bracket m x -> m x
alg -> (Bracket m (b, c) -> m (b, c))
-> Bracket (ViaAlg s Bracket m) (b, c) -> ViaAlg s Bracket m (b, c)
forall (n :: * -> *) (m :: * -> *) (e :: Effect) a b.
(Coercible n m, RepresentationalEff e) =>
(e m a -> m b) -> e n a -> n b
coerceAlg Bracket m (b, c) -> m (b, c)
forall x. Bracket m x -> m x
alg (ViaAlg s Bracket m a
-> (a -> ExitCase b -> ViaAlg s Bracket m c)
-> (a -> ViaAlg s Bracket m b)
-> Bracket (ViaAlg s Bracket m) (b, c)
forall (m :: * -> *) a b c.
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> Bracket m (b, c)
GeneralBracket ViaAlg s Bracket m a
acquire a -> ExitCase b -> ViaAlg s Bracket m c
release a -> ViaAlg s Bracket m b
use)
  {-# INLINE generalBracket #-}

-- | A valid definition of 'threadEff' for a @'ThreadsEff' t 'Bracket'@ instance,
-- given that @t@ lifts @'MonadMask'@.
--
-- __BEWARE__: 'threadBracketViaClass' is only safe if the implementation of
-- 'C.generalBracket' for @t m@ only makes use of 'C.generalBracket' for @m@,
-- and no other methods of 'MonadThrow', 'MonadCatch', or 'MonadMask'.
threadBracketViaClass :: forall t m a
                       . Monad m
                      => ( RepresentationalT t
                         , forall b. MonadMask b => MonadMask (t b)
                         )
                      => (forall x. Bracket m x -> m x)
                      -> Bracket (t m) a -> t m a
threadBracketViaClass :: (forall x. Bracket m x -> m x) -> Bracket (t m) a -> t m a
threadBracketViaClass forall x. Bracket m x -> m x
alg (GeneralBracket t m a
acquire a -> ExitCase b -> t m c
release a -> t m b
use) =
  ReifiedEffAlgebra Bracket m
-> (forall s (pr :: * -> *).
    (pr ~ Proxy, Reifies s (ReifiedEffAlgebra Bracket 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. Bracket m x -> m x) -> ReifiedEffAlgebra Bracket m
forall k (e :: (k -> *) -> k -> *) (m :: k -> *).
(forall (x :: k). e m x -> m x) -> ReifiedEffAlgebra e m
ReifiedEffAlgebra forall x. Bracket m x -> m x
alg) ((forall s (pr :: * -> *).
  (pr ~ Proxy, Reifies s (ReifiedEffAlgebra Bracket m)) =>
  pr s -> t m a)
 -> t m a)
-> (forall s (pr :: * -> *).
    (pr ~ Proxy, Reifies s (ReifiedEffAlgebra Bracket m)) =>
    pr s -> t m a)
-> t m a
forall a b. (a -> b) -> a -> b
$ \(pr s
_ :: pr s) ->
    forall s (e :: Effect) (t :: Effect) (m :: * -> *) a.
RepresentationalT t =>
t (ViaAlg s e m) a -> t m a
forall (t :: Effect) (m :: * -> *) a.
RepresentationalT t =>
t (ViaAlg s Bracket m) a -> t m a
unViaAlgT @s @Bracket (t (ViaAlg s Bracket m) (b, c) -> t m (b, c))
-> t (ViaAlg s Bracket m) (b, c) -> t m (b, c)
forall a b. (a -> b) -> a -> b
$
      t (ViaAlg s Bracket m) a
-> (a -> ExitCase b -> t (ViaAlg s Bracket m) c)
-> (a -> t (ViaAlg s Bracket m) b)
-> t (ViaAlg s Bracket m) (b, c)
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
C.generalBracket
        (t m a -> t (ViaAlg s Bracket m) a
forall s (e :: Effect) (t :: Effect) (m :: * -> *) a.
RepresentationalT t =>
t m a -> t (ViaAlg s e m) a
viaAlgT t m a
acquire)
        ((t m c -> t (ViaAlg s Bracket m) c
forall s (e :: Effect) (t :: Effect) (m :: * -> *) a.
RepresentationalT t =>
t m a -> t (ViaAlg s e m) a
viaAlgT (t m c -> t (ViaAlg s Bracket m) c)
-> (ExitCase b -> t m c) -> ExitCase b -> t (ViaAlg s Bracket m) c
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((ExitCase b -> t m c) -> ExitCase b -> t (ViaAlg s Bracket m) c)
-> (a -> ExitCase b -> t m c)
-> a
-> ExitCase b
-> t (ViaAlg s Bracket m) c
forall c b a. Coercible c b => (b -> c) -> (a -> b) -> a -> c
#. a -> ExitCase b -> t m c
release)
        (t m b -> t (ViaAlg s Bracket m) b
forall s (e :: Effect) (t :: Effect) (m :: * -> *) a.
RepresentationalT t =>
t m a -> t (ViaAlg s e m) a
viaAlgT (t m b -> t (ViaAlg s Bracket m) b)
-> (a -> t m b) -> a -> t (ViaAlg s Bracket m) b
forall c b a. Coercible c b => (b -> c) -> (a -> b) -> a -> c
#. a -> t m b
use)
{-# INLINE threadBracketViaClass #-}


#define THREAD_BRACKET(monadT)             \
instance ThreadsEff (monadT) Bracket where \
  threadEff = threadBracketViaClass;       \
  {-# INLINE threadEff #-}

#define THREAD_BRACKET_CTX(ctx, monadT)             \
instance (ctx) => ThreadsEff (monadT) Bracket where \
  threadEff = threadBracketViaClass;                \
  {-# INLINE threadEff #-}


THREAD_BRACKET(ReaderT i)
THREAD_BRACKET(ExceptT e)
THREAD_BRACKET(LSt.StateT s)
THREAD_BRACKET(SSt.StateT s)
THREAD_BRACKET_CTX(Monoid s, LWr.WriterT s)
THREAD_BRACKET_CTX(Monoid s, SWr.WriterT s)

instance Monoid s => ThreadsEff (CPSWr.WriterT s) Bracket where
  threadEff :: (forall x. Bracket m x -> m x)
-> Bracket (WriterT s m) a -> WriterT s m a
threadEff forall x. Bracket m x -> m x
alg (GeneralBracket WriterT s m a
acq a -> ExitCase b -> WriterT s m c
rel a -> WriterT s m b
use) = m ((b, c), s) -> WriterT s m (b, c)
forall (m :: * -> *) w a.
(Functor m, Monoid w) =>
m (a, w) -> WriterT w m a
CPSWr.writerT (m ((b, c), s) -> WriterT s m (b, c))
-> m ((b, c), s) -> WriterT s m (b, c)
forall a b. (a -> b) -> a -> b
$
      (((b, s), (c, s)) -> ((b, c), s))
-> m ((b, s), (c, s)) -> m ((b, c), s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\( (b
b,s
sUse), (c
c,s
sEnd) ) -> ((b
b, c
c), s
sUse s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
sEnd))
    (m ((b, s), (c, s)) -> m ((b, c), s))
-> (Bracket m ((b, s), (c, s)) -> m ((b, s), (c, s)))
-> Bracket m ((b, s), (c, s))
-> m ((b, c), s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bracket m ((b, s), (c, s)) -> m ((b, s), (c, s))
forall x. Bracket m x -> m x
alg (Bracket m ((b, s), (c, s)) -> m ((b, c), s))
-> Bracket m ((b, s), (c, s)) -> m ((b, c), s)
forall a b. (a -> b) -> a -> b
$
      m (a, s)
-> ((a, s) -> ExitCase (b, s) -> m (c, s))
-> ((a, s) -> m (b, s))
-> Bracket m ((b, s), (c, s))
forall (m :: * -> *) a b c.
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> Bracket m (b, c)
GeneralBracket
        (WriterT s m a -> m (a, s)
forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
CPSWr.runWriterT WriterT s m a
acq)
        (\(a
a, s
_) ExitCase (b, s)
ec -> WriterT s m c -> m (c, s)
forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
CPSWr.runWriterT (WriterT s m c -> m (c, s)) -> WriterT s m c -> m (c, s)
forall a b. (a -> b) -> a -> b
$ a -> ExitCase b -> WriterT s m c
rel a
a (ExitCase b -> WriterT s m c) -> ExitCase b -> WriterT s m c
forall a b. (a -> b) -> a -> b
$ case ExitCase (b, s)
ec of
          ExitCaseSuccess (b
b, s
_) -> b -> ExitCase b
forall a. a -> ExitCase a
ExitCaseSuccess b
b
          ExitCaseException SomeException
exc  -> SomeException -> ExitCase b
forall a. SomeException -> ExitCase a
ExitCaseException SomeException
exc
          ExitCase (b, s)
ExitCaseAbort          -> ExitCase b
forall a. ExitCase a
ExitCaseAbort
        )
        (\(a
a, s
s) -> WriterT s m b -> m (b, s)
forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
CPSWr.runWriterT (s -> WriterT s m ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
CPSWr.tell s
s WriterT s m () -> WriterT s m b -> WriterT s m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> WriterT s m b
use a
a))
  {-# INLINE threadEff #-}