{-# LANGUAGE CPP
           , NoImplicitPrelude
           , RankNTypes
           , TypeFamilies
           , TupleSections
           , FunctionalDependencies
           , FlexibleInstances
           , UndecidableInstances
           , MultiParamTypeClasses #-}

{-# LANGUAGE Safe #-}

#if MIN_VERSION_transformers(0,4,0)
-- Hide warnings for the deprecated ErrorT transformer:
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
#endif

{- |
Copyright   :  Bas van Dijk, Anders Kaseorg
License     :  BSD3
Maintainer  :  Bas van Dijk <v.dijk.bas@gmail.com>

This module defines the type class 'MonadBaseControl', a subset of
'MonadBase' into which generic control operations such as @catch@ can be
lifted from @IO@ or any other base monad. Instances are based on monad
transformers in 'MonadTransControl', which includes all standard monad
transformers in the @transformers@ library except @ContT@ and @SelectT@.

See the <http://hackage.haskell.org/package/lifted-base lifted-base>
package which uses @monad-control@ to lift @IO@
operations from the @base@ library (like @catch@ or @bracket@) into any monad
that is an instance of @MonadBase@ or @MonadBaseControl@.

See the following tutorial by Michael Snoyman on how to use this package:

<https://www.yesodweb.com/book/monad-control>

=== Quick implementation guide

Given a base monad @B@ and a stack of transformers @T@:

* Define instances @'MonadTransControl' T@ for all transformers @T@, using the
  @'defaultLiftWith'@ and @'defaultRestoreT'@ functions on the constructor and
  deconstructor of @T@.

* Define an instance @'MonadBaseControl' B B@ for the base monad:

    @
    instance MonadBaseControl B B where
        type StM B a   = a
        liftBaseWith f = f 'id'
        restoreM       = 'return'
    @

* Define instances @'MonadBaseControl' B m => 'MonadBaseControl' B (T m)@ for
  all transformers:

    @
    instance MonadBaseControl b m => MonadBaseControl b (T m) where
        type StM (T m) a = 'ComposeSt' T m a
        liftBaseWith f   = 'defaultLiftBaseWith'
        restoreM         = 'defaultRestoreM'
    @
-}

module Control.Monad.Trans.Control.Aligned
    ( -- * MonadTransControl
      MonadTransControl(..), Run

      -- ** Defaults
      -- $MonadTransControlDefaults
    , RunDefault, defaultLiftWith, defaultRestoreT

      -- * MonadBaseControl
    , MonadBaseControl (..), RunInBase

      -- ** Defaults
      -- $MonadBaseControlDefaults
    , RunInBaseDefault, defaultLiftBaseWith, defaultRestoreM

      -- * Utility functions
    , control, controlT, embed, embed_, captureT, captureM

    , liftBaseOp, liftBaseOp_

    , liftBaseDiscard, liftBaseOpDiscard

    , liftThrough
    ) where


--------------------------------------------------------------------------------
-- Imports
--------------------------------------------------------------------------------

-- from base:
import Data.Function ( (.), ($), const )
import Data.Monoid   ( Monoid, mempty )
import Control.Monad ( Monad, (>>=), return, liftM )
import System.IO     ( IO )
import Data.Maybe    ( Maybe )
import Data.Either   ( Either )
-- <<<<<<< HEAD:src/Control/Monad/Trans/Control.hs
-- import Control.Monad ( void )
-- import Prelude       ( id )
-- =======
import Data.Functor.Identity ( Identity (..) )
import Data.Functor.Compose  ( Compose (..) )
import Data.Tuple    ( swap )
-- >>>>>>> 696e8dd (exposing monadic state for augmentation):Control/Monad/Trans/Control.hs

import           Control.Monad.ST.Lazy.Safe           ( ST )
import qualified Control.Monad.ST.Safe      as Strict ( ST )

-- from stm:
import Control.Monad.STM ( STM )

-- from transformers:
import Control.Monad.Trans.Class    ( MonadTrans )

import Control.Monad.Trans.Identity ( IdentityT(IdentityT), runIdentityT )
import Control.Monad.Trans.Maybe    ( MaybeT   (MaybeT),    runMaybeT )
import Control.Monad.Trans.Reader   ( ReaderT  (ReaderT),   runReaderT )
import Control.Monad.Trans.State    ( StateT   (StateT),    runStateT )
import Control.Monad.Trans.Writer   ( WriterT  (WriterT),   runWriterT )
import Control.Monad.Trans.RWS      ( RWST     (RWST),      runRWST )
import Control.Monad.Trans.Except   ( ExceptT  (ExceptT),   runExceptT )

#if !(MIN_VERSION_transformers(0,6,0))
import Control.Monad.Trans.List     ( ListT    (ListT),     runListT )
import Control.Monad.Trans.Error    ( ErrorT   (ErrorT),    runErrorT, Error )
#endif

import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   (RWST),    runRWST )
import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT (StateT),  runStateT )
import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT(WriterT), runWriterT )

import Data.Functor.Identity ( Identity )

-- from transformers-base:
import Control.Monad.Base ( MonadBase )

-- <<<<<<< HEAD:src/Control/Monad/Trans/Control.hs
-- =======
#if MIN_VERSION_base(4,3,0)
import Control.Monad ( void )
#else
import Data.Functor (Functor, fmap)
void :: Functor f => f a -> f ()
void = fmap (const ())
#endif

import Prelude (id, (<$>), pure)

--------------------------------------------------------------------------------
-- MonadTransControl type class
--------------------------------------------------------------------------------

class MonadTrans t => MonadTransControl t stT | t -> stT where
  -- | @liftWith@ is similar to 'lift' in that it lifts a computation from
  -- the argument monad to the constructed monad.
  --
  -- Instances should satisfy similar laws as the 'MonadTrans' laws:
  --
  -- @liftWith (\\_ -> return a) = return a@
  --
  -- @liftWith (\\_ -> m >>= f)  =  liftWith (\\_ -> m) >>= (\\a -> liftWith (\\_ -> f a))@
  --
  -- The difference with 'lift' is that before lifting the @m@ computation
  -- @liftWith@ captures the state of @t@. It then provides the @m@
  -- computation with a 'Run' function that allows running @t n@ computations in
  -- @n@ (for all @n@) on the captured state.
  liftWith :: Monad m => (Run t stT -> m a) -> t m a

  -- | Construct a @t@ computation from the monadic state of @t@ that is
  -- returned from a 'Run' function.
  --
  -- Instances should satisfy:
  --
  -- @liftWith (\\run -> run t) >>= restoreT . return = t@
  restoreT :: Monad m => m (stT a) -> t m a

-- | A function that runs a transformed monad @t n@ on the monadic state that
-- was captured by 'liftWith'
--
-- A @Run t@ function yields a computation in @n@ that returns the monadic state
-- of @t@. This state can later be used to restore a @t@ computation using
-- 'restoreT'.
type Run t stT = forall n b. Monad n => t n b -> n (stT b)


--------------------------------------------------------------------------------
-- Defaults for MonadTransControl
--------------------------------------------------------------------------------

-- $MonadTransControlDefaults
--
-- The following functions can be used to define a 'MonadTransControl' instance
-- for a monad transformer which simply is a newtype around another monad
-- transformer which already has a @MonadTransControl@ instance. For example:
--
-- @
-- {-\# LANGUAGE GeneralizedNewtypeDeriving \#-}
-- {-\# LANGUAGE UndecidableInstances \#-}
-- {-\# LANGUAGE TypeFamilies \#-}
--
-- newtype CounterT m a = CounterT {unCounterT :: StateT Int m a}
--   deriving (Monad, MonadTrans)
--
-- instance MonadTransControl CounterT where
--     type StT CounterT a = StT (StateT Int) a
--     liftWith = 'defaultLiftWith' CounterT unCounterT
--     restoreT = 'defaultRestoreT' CounterT
-- @

-- | A function like 'Run' that runs a monad transformer @t@ which wraps the
-- monad transformer @t'@. This is used in 'defaultLiftWith'.
type RunDefault t stT = forall n b. Monad n => t n b -> n (stT b)

-- | Default definition for the 'liftWith' method.
defaultLiftWith :: (Monad m, MonadTransControl n stT)
                => (forall b.   n m b -> t m b)     -- ^ Monad constructor
                -> (forall o b. t o b -> n o b)     -- ^ Monad deconstructor
                -> (RunDefault t stT -> m a)
                -> t m a
defaultLiftWith :: forall (m :: * -> *) (n :: (* -> *) -> * -> *) (stT :: * -> *)
       (t :: (* -> *) -> * -> *) a.
(Monad m, MonadTransControl n stT) =>
(forall b. n m b -> t m b)
-> (forall (o :: * -> *) b. t o b -> n o b)
-> (RunDefault t stT -> m a)
-> t m a
defaultLiftWith forall b. n m b -> t m b
t forall (o :: * -> *) b. t o b -> n o b
unT = \RunDefault t stT -> m a
f -> forall b. n m b -> t m b
t forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (m :: * -> *) a.
(MonadTransControl t stT, Monad m) =>
(Run t stT -> m a) -> t m a
liftWith forall a b. (a -> b) -> a -> b
$ \Run n stT
run -> RunDefault t stT -> m a
f forall a b. (a -> b) -> a -> b
$ Run n stT
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (o :: * -> *) b. t o b -> n o b
unT
{-# INLINABLE defaultLiftWith #-}

-- | Default definition for the 'restoreT' method.
defaultRestoreT :: (Monad m, MonadTransControl n stT)
                => (n m a -> t m a)     -- ^ Monad constructor
                -> m (stT a)
                -> t m a
defaultRestoreT :: forall (m :: * -> *) (n :: (* -> *) -> * -> *) (stT :: * -> *) a
       (t :: (* -> *) -> * -> *).
(Monad m, MonadTransControl n stT) =>
(n m a -> t m a) -> m (stT a) -> t m a
defaultRestoreT n m a -> t m a
t = n m a -> t m a
t forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (m :: * -> *) a.
(MonadTransControl t stT, Monad m) =>
m (stT a) -> t m a
restoreT
{-# INLINABLE defaultRestoreT #-}


--------------------------------------------------------------------------------
-- MonadTransControl instances
--------------------------------------------------------------------------------

instance MonadTransControl IdentityT Identity where
    liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run IdentityT Identity -> m a) -> IdentityT m a
liftWith Run IdentityT Identity -> m a
f = forall {k} (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT forall a b. (a -> b) -> a -> b
$ Run IdentityT Identity -> m a
f forall a b. (a -> b) -> a -> b
$ \IdentityT n b
mx -> forall a. a -> Identity a
Identity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT IdentityT n b
mx
    restoreT :: forall (m :: * -> *) a. Monad m => m (Identity a) -> IdentityT m a
restoreT m (Identity a)
mx = forall {k} (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT forall a b. (a -> b) -> a -> b
$ forall a. Identity a -> a
runIdentity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Identity a)
mx
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance MonadTransControl MaybeT Maybe where
    liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run MaybeT Maybe -> m a) -> MaybeT m a
liftWith Run MaybeT Maybe -> m a
f = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Run MaybeT Maybe -> m a
f forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
    restoreT :: forall (m :: * -> *) a. Monad m => m (Maybe a) -> MaybeT m a
restoreT = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance Error e => MonadTransControl (ErrorT e) (Either e) where
    liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run (ErrorT e) (Either e) -> m a) -> ErrorT e m a
liftWith Run (ErrorT e) (Either e) -> m a
f = forall e (m :: * -> *) a. m (Either e a) -> ErrorT e m a
ErrorT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Run (ErrorT e) (Either e) -> m a
f forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
runErrorT
    restoreT :: forall (m :: * -> *) a. Monad m => m (Either e a) -> ErrorT e m a
restoreT = forall e (m :: * -> *) a. m (Either e a) -> ErrorT e m a
ErrorT
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance MonadTransControl (ExceptT e) (Either e) where
    liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run (ExceptT e) (Either e) -> m a) -> ExceptT e m a
liftWith Run (ExceptT e) (Either e) -> m a
f = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Run (ExceptT e) (Either e) -> m a
f forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
    restoreT :: forall (m :: * -> *) a. Monad m => m (Either e a) -> ExceptT e m a
restoreT = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance MonadTransControl ListT [] where
    liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run ListT [] -> m a) -> ListT m a
liftWith Run ListT [] -> m a
f = forall (m :: * -> *) a. m [a] -> ListT m a
ListT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Run ListT [] -> m a
f forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. ListT m a -> m [a]
runListT
    restoreT :: forall (m :: * -> *) a. Monad m => m [a] -> ListT m a
restoreT = forall (m :: * -> *) a. m [a] -> ListT m a
ListT
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance MonadTransControl (ReaderT r) Identity where
    liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run (ReaderT r) Identity -> m a) -> ReaderT r m a
liftWith Run (ReaderT r) Identity -> m a
f = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \r
r -> Run (ReaderT r) Identity -> m a
f forall a b. (a -> b) -> a -> b
$ \ReaderT r n b
t -> forall a. a -> Identity a
Identity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r n b
t r
r
    restoreT :: forall (m :: * -> *) a. Monad m => m (Identity a) -> ReaderT r m a
restoreT m (Identity a)
mx = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \r
_ -> forall a. Identity a -> a
runIdentity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Identity a)
mx
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance MonadTransControl (StateT s) ((,) s) where
    liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run (StateT s) ((,) s) -> m a) -> StateT s m a
liftWith Run (StateT s) ((,) s) -> m a
f = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT forall a b. (a -> b) -> a -> b
$ \s
s -> (,s
s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Run (StateT s) ((,) s) -> m a
f (\StateT s n b
t -> forall a b. (a, b) -> (b, a)
swap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT s n b
t s
s)
    restoreT :: forall (m :: * -> *) a. Monad m => m (s, a) -> StateT s m a
restoreT m (s, a)
mx = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT forall a b. (a -> b) -> a -> b
$ \s
_ -> forall a b. (a, b) -> (b, a)
swap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (s, a)
mx
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance MonadTransControl (Strict.StateT s) ((,) s) where
    liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run (StateT s) ((,) s) -> m a) -> StateT s m a
liftWith Run (StateT s) ((,) s) -> m a
f = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
Strict.StateT forall a b. (a -> b) -> a -> b
$ \s
s -> (,s
s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Run (StateT s) ((,) s) -> m a
f (\StateT s n b
t -> forall a b. (a, b) -> (b, a)
swap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Strict.runStateT StateT s n b
t s
s)
    restoreT :: forall (m :: * -> *) a. Monad m => m (s, a) -> StateT s m a
restoreT m (s, a)
mx = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
Strict.StateT forall a b. (a -> b) -> a -> b
$ \s
_ -> forall a b. (a, b) -> (b, a)
swap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (s, a)
mx
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance Monoid w => MonadTransControl (WriterT w) ((,) w) where
    liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run (WriterT w) ((,) w) -> m a) -> WriterT w m a
liftWith Run (WriterT w) ((,) w) -> m a
f = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT forall a b. (a -> b) -> a -> b
$ (,forall a. Monoid a => a
mempty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Run (WriterT w) ((,) w) -> m a
f forall a b. (a -> b) -> a -> b
$ \WriterT w n b
t -> forall a b. (a, b) -> (b, a)
swap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT w n b
t)
    restoreT :: forall (m :: * -> *) a. Monad m => m (w, a) -> WriterT w m a
restoreT m (w, a)
mx = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> (b, a)
swap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (w, a)
mx
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance Monoid w => MonadTransControl (Strict.WriterT w) ((,) w) where
    liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run (WriterT w) ((,) w) -> m a) -> WriterT w m a
liftWith Run (WriterT w) ((,) w) -> m a
f = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Strict.WriterT forall a b. (a -> b) -> a -> b
$ (,forall a. Monoid a => a
mempty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Run (WriterT w) ((,) w) -> m a
f forall a b. (a -> b) -> a -> b
$ \WriterT w n b
t -> forall a b. (a, b) -> (b, a)
swap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Strict.runWriterT WriterT w n b
t)
    restoreT :: forall (m :: * -> *) a. Monad m => m (w, a) -> WriterT w m a
restoreT m (w, a)
mx = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Strict.WriterT forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> (b, a)
swap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (w, a)
mx
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance Monoid w => MonadTransControl (RWST r w s) ((,,) w s) where
    liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run (RWST r w s) ((,,) w s) -> m a) -> RWST r w s m a
liftWith Run (RWST r w s) ((,,) w s) -> m a
f = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWST forall a b. (a -> b) -> a -> b
$ \r
r s
s -> (,s
s,forall a. Monoid a => a
mempty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Run (RWST r w s) ((,,) w s) -> m a
f forall a b. (a -> b) -> a -> b
$ \RWST r w s n b
t -> (\(b
a,s
s,w
w) -> (w
w,s
s,b
a)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST RWST r w s n b
t r
r s
s)
    restoreT :: forall (m :: * -> *) a. Monad m => m (w, s, a) -> RWST r w s m a
restoreT m (w, s, a)
mSt = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWST forall a b. (a -> b) -> a -> b
$ \r
_ s
_ -> (\(w
w,s
s,a
a) -> (a
a,s
s,w
w)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (w, s, a)
mSt
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance Monoid w => MonadTransControl (Strict.RWST r w s) ((,,) w s) where
    liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run (RWST r w s) ((,,) w s) -> m a) -> RWST r w s m a
liftWith Run (RWST r w s) ((,,) w s) -> m a
f = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
Strict.RWST forall a b. (a -> b) -> a -> b
$ \r
r s
s -> (,s
s,forall a. Monoid a => a
mempty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Run (RWST r w s) ((,,) w s) -> m a
f forall a b. (a -> b) -> a -> b
$ \RWST r w s n b
t -> (\(b
a,s
s,w
w) -> (w
w,s
s,b
a)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
Strict.runRWST RWST r w s n b
t r
r s
s)
    restoreT :: forall (m :: * -> *) a. Monad m => m (w, s, a) -> RWST r w s m a
restoreT m (w, s, a)
mSt = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
Strict.RWST forall a b. (a -> b) -> a -> b
$ \r
_ s
_ -> (\(w
w,s
s,a
a) -> (a
a,s
s,w
w)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (w, s, a)
mSt
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}


--------------------------------------------------------------------------------
-- MonadBaseControl type class
--------------------------------------------------------------------------------

class MonadBase b m => MonadBaseControl b m stM | m -> b stM where

    -- | @liftBaseWith@ is similar to 'liftIO' and 'liftBase' in that it
    -- lifts a base computation to the constructed monad.
    --
    -- Instances should satisfy similar laws as the 'MonadIO' and 'MonadBase' laws:
    --
    -- @liftBaseWith (\\_ -> return a) = return a@
    --
    -- @liftBaseWith (\\_ -> m >>= f)  =  liftBaseWith (\\_ -> m) >>= (\\a -> liftBaseWith (\\_ -> f a))@
    --
    -- As <https://stackoverflow.com/a/58106822/1477667 Li-yao Xia explains>, parametricity
    -- guarantees that
    --
    -- @f <$> liftBaseWith q = liftBaseWith $ \runInBase -> f <$> q runInBase@
    --
    -- The difference with 'liftBase' is that before lifting the base computation
    -- @liftBaseWith@ captures the state of @m@. It then provides the base
    -- computation with a 'RunInBase' function that allows running @m@
    -- computations in the base monad on the captured state.
    liftBaseWith :: (RunInBase m b stM -> b a) -> m a

    -- | Construct a @m@ computation from the monadic state of @m@ that is
    -- returned from a 'RunInBase' function.
    --
    -- Instances should satisfy:
    --
    -- @liftBaseWith (\\runInBase -> runInBase m) >>= restoreM = m@
    restoreM :: stM a -> m a

-- | A function that runs a @m@ computation on the monadic state that was
-- captured by 'liftBaseWith'
--
-- A @RunInBase m@ function yields a computation in the base monad of @m@ that
-- returns the monadic state of @m@. This state can later be used to restore the
-- @m@ computation using 'restoreM'.
type RunInBase m b stM = forall a. m a -> b (stM a)


--------------------------------------------------------------------------------
-- MonadBaseControl instances for all monads in the base library
--------------------------------------------------------------------------------

instance MonadBaseControl IO IO Identity where
  liftBaseWith :: forall a. (RunInBase IO IO Identity -> IO a) -> IO a
liftBaseWith RunInBase IO IO Identity -> IO a
f = RunInBase IO IO Identity -> IO a
f (\IO a
x -> forall a. a -> Identity a
Identity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
x)
  restoreM :: forall a. Identity a -> IO a
restoreM Identity a
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Identity a -> a
runIdentity Identity a
x)
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance MonadBaseControl Maybe Maybe Identity where
  liftBaseWith :: forall a. (RunInBase Maybe Maybe Identity -> Maybe a) -> Maybe a
liftBaseWith RunInBase Maybe Maybe Identity -> Maybe a
f = RunInBase Maybe Maybe Identity -> Maybe a
f (\Maybe a
x -> forall a. a -> Identity a
Identity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
x)
  restoreM :: forall a. Identity a -> Maybe a
restoreM Identity a
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Identity a -> a
runIdentity Identity a
x)
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance MonadBaseControl (Either e) (Either e) Identity where
  liftBaseWith :: forall a.
(RunInBase (Either e) (Either e) Identity -> Either e a)
-> Either e a
liftBaseWith RunInBase (Either e) (Either e) Identity -> Either e a
f = RunInBase (Either e) (Either e) Identity -> Either e a
f (\Either e a
x -> forall a. a -> Identity a
Identity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either e a
x)
  restoreM :: forall a. Identity a -> Either e a
restoreM Identity a
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Identity a -> a
runIdentity Identity a
x)
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance MonadBaseControl [] [] Identity where
  liftBaseWith :: forall a. (RunInBase [] [] Identity -> [a]) -> [a]
liftBaseWith RunInBase [] [] Identity -> [a]
f = RunInBase [] [] Identity -> [a]
f (\[a]
x -> forall a. a -> Identity a
Identity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
x)
  restoreM :: forall a. Identity a -> [a]
restoreM Identity a
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Identity a -> a
runIdentity Identity a
x)
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance MonadBaseControl ((->) r) ((->) r) Identity where
  liftBaseWith :: forall a.
(RunInBase ((->) r) ((->) r) Identity -> r -> a) -> r -> a
liftBaseWith RunInBase ((->) r) ((->) r) Identity -> r -> a
f = RunInBase ((->) r) ((->) r) Identity -> r -> a
f (\r -> a
x -> forall a. a -> Identity a
Identity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> r -> a
x)
  restoreM :: forall a. Identity a -> r -> a
restoreM Identity a
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Identity a -> a
runIdentity Identity a
x)
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance MonadBaseControl Identity Identity Identity where
  liftBaseWith :: forall a.
(RunInBase Identity Identity Identity -> Identity a) -> Identity a
liftBaseWith RunInBase Identity Identity Identity -> Identity a
f = RunInBase Identity Identity Identity -> Identity a
f (\Identity a
x -> forall a. a -> Identity a
Identity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identity a
x)
  restoreM :: forall a. Identity a -> Identity a
restoreM Identity a
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Identity a -> a
runIdentity Identity a
x)
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance MonadBaseControl STM STM Identity where
  liftBaseWith :: forall a. (RunInBase STM STM Identity -> STM a) -> STM a
liftBaseWith RunInBase STM STM Identity -> STM a
f = RunInBase STM STM Identity -> STM a
f (\STM a
x -> forall a. a -> Identity a
Identity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM a
x)
  restoreM :: forall a. Identity a -> STM a
restoreM Identity a
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Identity a -> a
runIdentity Identity a
x)
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

#if MIN_VERSION_base(4,4,0)
instance MonadBaseControl (Strict.ST s) (Strict.ST s) Identity where
  liftBaseWith :: forall a. (RunInBase (ST s) (ST s) Identity -> ST s a) -> ST s a
liftBaseWith RunInBase (ST s) (ST s) Identity -> ST s a
f = RunInBase (ST s) (ST s) Identity -> ST s a
f (\ST s a
x -> forall a. a -> Identity a
Identity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ST s a
x)
  restoreM :: forall a. Identity a -> ST s a
restoreM Identity a
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Identity a -> a
runIdentity Identity a
x)
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance MonadBaseControl (ST s) (ST s) Identity where
  liftBaseWith :: forall a. (RunInBase (ST s) (ST s) Identity -> ST s a) -> ST s a
liftBaseWith RunInBase (ST s) (ST s) Identity -> ST s a
f = RunInBase (ST s) (ST s) Identity -> ST s a
f (\ST s a
x -> forall a. a -> Identity a
Identity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ST s a
x)
  restoreM :: forall a. Identity a -> ST s a
restoreM Identity a
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Identity a -> a
runIdentity Identity a
x)
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}
#endif

#undef BASE


--------------------------------------------------------------------------------
-- Defaults for MonadBaseControl
--------------------------------------------------------------------------------

-- $MonadBaseControlDefaults
--
-- Note that by using the following default definitions it's easy to make a
-- monad transformer @T@ an instance of 'MonadBaseControl':
--
-- @
-- instance MonadBaseControl b m => MonadBaseControl b (T m) where
--     type StM (T m) a = 'ComposeSt' T m a
--     liftBaseWith     = 'defaultLiftBaseWith'
--     restoreM         = 'defaultRestoreM'
-- @
--
-- Defining an instance for a base monad @B@ is equally straightforward:
--
-- @
-- instance MonadBaseControl B B where
--     type StM B a   = a
--     liftBaseWith f = f 'id'
--     restoreM       = 'return'
-- @

-- | A function like 'RunInBase' that runs a monad transformer @t@ in its base
-- monad @b@. It is used in 'defaultLiftBaseWith'.
type RunInBaseDefault (t :: (* -> *) -> * -> *) (m :: * -> *) (b :: * -> *) (stM :: * -> *) (stT :: * -> *) = forall a. t m a -> b (Compose stM stT a)

-- | Default definition for the 'liftBaseWith' method.
--
-- Note that it composes a 'liftWith' of @t@ with a 'liftBaseWith' of @m@ to
-- give a 'liftBaseWith' of @t m@:
--
-- @
-- defaultLiftBaseWith = \\f -> 'liftWith' $ \\run ->
--                               'liftBaseWith' $ \\runInBase ->
--                                 f $ runInBase . run
-- @
defaultLiftBaseWith :: (MonadTransControl t stT, MonadBaseControl b m stM)
                    => (RunInBaseDefault t m b stM stT -> b a) -> t m a
defaultLiftBaseWith :: forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
(RunInBaseDefault t m b stM stT -> b a) -> t m a
defaultLiftBaseWith RunInBaseDefault t m b stM stT -> b a
f = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (m :: * -> *) a.
(MonadTransControl t stT, Monad m) =>
(Run t stT -> m a) -> t m a
liftWith forall a b. (a -> b) -> a -> b
$ \Run t stT
run ->
                          forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a.
MonadBaseControl b m stM =>
(RunInBase m b stM -> b a) -> m a
liftBaseWith forall a b. (a -> b) -> a -> b
$ \RunInBase m b stM
runInBase ->
                            RunInBaseDefault t m b stM stT -> b a
f (\t m a
t -> forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RunInBase m b stM
runInBase (Run t stT
run t m a
t))
{-# INLINABLE defaultLiftBaseWith #-}

-- | Default definition for the 'restoreM' method.
--
-- Note that: @defaultRestoreM = 'restoreT' . 'restoreM'@
defaultRestoreM :: (MonadTransControl t stT, MonadBaseControl b m stM)
                => Compose stM stT a -> t m a
defaultRestoreM :: forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
Compose stM stT a -> t m a
defaultRestoreM (Compose stM (stT a)
x) = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (m :: * -> *) a.
(MonadTransControl t stT, Monad m) =>
m (stT a) -> t m a
restoreT (forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a.
MonadBaseControl b m stM =>
stM a -> m a
restoreM stM (stT a)
x)
{-# INLINABLE defaultRestoreM #-}


--------------------------------------------------------------------------------
-- MonadBaseControl transformer instances
--------------------------------------------------------------------------------

instance (MonadBaseControl b m stM) => MonadBaseControl b (IdentityT m) (Compose stM Identity) where
  liftBaseWith :: forall a.
(RunInBase (IdentityT m) b (Compose stM Identity) -> b a)
-> IdentityT m a
liftBaseWith = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
(RunInBaseDefault t m b stM stT -> b a) -> t m a
defaultLiftBaseWith
  restoreM :: forall a. Compose stM Identity a -> IdentityT m a
restoreM     = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
Compose stM stT a -> t m a
defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance (MonadBaseControl b m stM) => MonadBaseControl b (MaybeT m) (Compose stM Maybe) where
  liftBaseWith :: forall a.
(RunInBase (MaybeT m) b (Compose stM Maybe) -> b a) -> MaybeT m a
liftBaseWith = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
(RunInBaseDefault t m b stM stT -> b a) -> t m a
defaultLiftBaseWith
  restoreM :: forall a. Compose stM Maybe a -> MaybeT m a
restoreM     = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
Compose stM stT a -> t m a
defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance (MonadBaseControl b m stM) => MonadBaseControl b (ListT m) (Compose stM []) where
  liftBaseWith :: forall a.
(RunInBase (ListT m) b (Compose stM []) -> b a) -> ListT m a
liftBaseWith = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
(RunInBaseDefault t m b stM stT -> b a) -> t m a
defaultLiftBaseWith
  restoreM :: forall a. Compose stM [] a -> ListT m a
restoreM     = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
Compose stM stT a -> t m a
defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance (MonadBaseControl b m stM) => MonadBaseControl b (ReaderT r m) (Compose stM Identity) where
  liftBaseWith :: forall a.
(RunInBase (ReaderT r m) b (Compose stM Identity) -> b a)
-> ReaderT r m a
liftBaseWith = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
(RunInBaseDefault t m b stM stT -> b a) -> t m a
defaultLiftBaseWith
  restoreM :: forall a. Compose stM Identity a -> ReaderT r m a
restoreM     = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
Compose stM stT a -> t m a
defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance (MonadBaseControl b m stM) => MonadBaseControl b (Strict.StateT s m) (Compose stM ((,) s)) where
  liftBaseWith :: forall a.
(RunInBase (StateT s m) b (Compose stM ((,) s)) -> b a)
-> StateT s m a
liftBaseWith = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
(RunInBaseDefault t m b stM stT -> b a) -> t m a
defaultLiftBaseWith
  restoreM :: forall a. Compose stM ((,) s) a -> StateT s m a
restoreM     = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
Compose stM stT a -> t m a
defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance (MonadBaseControl b m stM) => MonadBaseControl b (StateT s m) (Compose stM ((,) s)) where
  liftBaseWith :: forall a.
(RunInBase (StateT s m) b (Compose stM ((,) s)) -> b a)
-> StateT s m a
liftBaseWith = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
(RunInBaseDefault t m b stM stT -> b a) -> t m a
defaultLiftBaseWith
  restoreM :: forall a. Compose stM ((,) s) a -> StateT s m a
restoreM     = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
Compose stM stT a -> t m a
defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance (MonadBaseControl b m stM) => MonadBaseControl b (ExceptT e m) (Compose stM (Either e)) where
  liftBaseWith :: forall a.
(RunInBase (ExceptT e m) b (Compose stM (Either e)) -> b a)
-> ExceptT e m a
liftBaseWith = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
(RunInBaseDefault t m b stM stT -> b a) -> t m a
defaultLiftBaseWith
  restoreM :: forall a. Compose stM (Either e) a -> ExceptT e m a
restoreM     = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
Compose stM stT a -> t m a
defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}



instance (MonadBaseControl b m stM, Error e) => MonadBaseControl b (ErrorT e m) (Compose stM (Either e)) where
  liftBaseWith :: forall a.
(RunInBase (ErrorT e m) b (Compose stM (Either e)) -> b a)
-> ErrorT e m a
liftBaseWith = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
(RunInBaseDefault t m b stM stT -> b a) -> t m a
defaultLiftBaseWith
  restoreM :: forall a. Compose stM (Either e) a -> ErrorT e m a
restoreM     = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
Compose stM stT a -> t m a
defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance (MonadBaseControl b m stM, Monoid w) => MonadBaseControl b (Strict.WriterT w m) (Compose stM ((,) w)) where
  liftBaseWith :: forall a.
(RunInBase (WriterT w m) b (Compose stM ((,) w)) -> b a)
-> WriterT w m a
liftBaseWith = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
(RunInBaseDefault t m b stM stT -> b a) -> t m a
defaultLiftBaseWith
  restoreM :: forall a. Compose stM ((,) w) a -> WriterT w m a
restoreM     = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
Compose stM stT a -> t m a
defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance (MonadBaseControl b m stM, Monoid w) => MonadBaseControl b (WriterT w m) (Compose stM ((,) w)) where
  liftBaseWith :: forall a.
(RunInBase (WriterT w m) b (Compose stM ((,) w)) -> b a)
-> WriterT w m a
liftBaseWith = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
(RunInBaseDefault t m b stM stT -> b a) -> t m a
defaultLiftBaseWith
  restoreM :: forall a. Compose stM ((,) w) a -> WriterT w m a
restoreM     = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
Compose stM stT a -> t m a
defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance (MonadBaseControl b m stM, Monoid w) => MonadBaseControl b (Strict.RWST r w s m) (Compose stM ((,,) w s)) where
  liftBaseWith :: forall a.
(RunInBase (RWST r w s m) b (Compose stM ((,,) w s)) -> b a)
-> RWST r w s m a
liftBaseWith = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
(RunInBaseDefault t m b stM stT -> b a) -> t m a
defaultLiftBaseWith
  restoreM :: forall a. Compose stM ((,,) w s) a -> RWST r w s m a
restoreM     = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
Compose stM stT a -> t m a
defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance (MonadBaseControl b m stM, Monoid w) => MonadBaseControl b (RWST r w s m) (Compose stM ((,,) w s)) where
  liftBaseWith :: forall a.
(RunInBase (RWST r w s m) b (Compose stM ((,,) w s)) -> b a)
-> RWST r w s m a
liftBaseWith = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
(RunInBaseDefault t m b stM stT -> b a) -> t m a
defaultLiftBaseWith
  restoreM :: forall a. Compose stM ((,,) w s) a -> RWST r w s m a
restoreM     = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (b :: * -> *)
       (m :: * -> *) (stM :: * -> *) a.
(MonadTransControl t stT, MonadBaseControl b m stM) =>
Compose stM stT a -> t m a
defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

#undef BODY
#undef TRANS
#undef TRANS_CTX

--------------------------------------------------------------------------------
-- * Utility functions
--------------------------------------------------------------------------------

-- | An often used composition: @control f = 'liftBaseWith' f >>= 'restoreM'@
control :: MonadBaseControl b m stM => (RunInBase m b stM -> b (stM a)) -> m a
control :: forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a.
MonadBaseControl b m stM =>
(RunInBase m b stM -> b (stM a)) -> m a
control RunInBase m b stM -> b (stM a)
f = forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a.
MonadBaseControl b m stM =>
(RunInBase m b stM -> b a) -> m a
liftBaseWith RunInBase m b stM -> b (stM a)
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a.
MonadBaseControl b m stM =>
stM a -> m a
restoreM
{-# INLINABLE control #-}

-- | Lift a computation and restore the monadic state immediately:
-- @controlT f = 'liftWith' f >>= 'restoreT' . return@.
controlT :: (MonadTransControl t stT, Monad (t m), Monad m)
         => (Run t stT -> m (stT a)) -> t m a
controlT :: forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (m :: * -> *) a.
(MonadTransControl t stT, Monad (t m), Monad m) =>
(Run t stT -> m (stT a)) -> t m a
controlT Run t stT -> m (stT a)
f = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (m :: * -> *) a.
(MonadTransControl t stT, Monad m) =>
(Run t stT -> m a) -> t m a
liftWith Run t stT -> m (stT a)
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (m :: * -> *) a.
(MonadTransControl t stT, Monad m) =>
m (stT a) -> t m a
restoreT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return
{-# INLINABLE controlT #-}

-- | Embed a transformer function as an function in the base monad returning a
-- mutated transformer state.
embed :: MonadBaseControl b m stM => (a -> m c) -> m (a -> b (stM c))
embed :: forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a c.
MonadBaseControl b m stM =>
(a -> m c) -> m (a -> b (stM c))
embed a -> m c
f = forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a.
MonadBaseControl b m stM =>
(RunInBase m b stM -> b a) -> m a
liftBaseWith forall a b. (a -> b) -> a -> b
$ \RunInBase m b stM
runInBase -> forall (m :: * -> *) a. Monad m => a -> m a
return (RunInBase m b stM
runInBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m c
f)
{-# INLINABLE embed #-}

-- | Performs the same function as 'embed', but discards transformer state
-- from the embedded function.
embed_ :: MonadBaseControl b m stM => (a -> m ()) -> m (a -> b ())
embed_ :: forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a.
MonadBaseControl b m stM =>
(a -> m ()) -> m (a -> b ())
embed_ a -> m ()
f = forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a.
MonadBaseControl b m stM =>
(RunInBase m b stM -> b a) -> m a
liftBaseWith forall a b. (a -> b) -> a -> b
$ \RunInBase m b stM
runInBase -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunInBase m b stM
runInBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m ()
f)
{-# INLINABLE embed_ #-}

-- | Capture the current state of a transformer
captureT :: (MonadTransControl t stT, Monad (t m), Monad m) => t m (stT ())
captureT :: forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (m :: * -> *).
(MonadTransControl t stT, Monad (t m), Monad m) =>
t m (stT ())
captureT = forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (m :: * -> *) a.
(MonadTransControl t stT, Monad m) =>
(Run t stT -> m a) -> t m a
liftWith forall a b. (a -> b) -> a -> b
$ \Run t stT
runInM -> Run t stT
runInM (forall (m :: * -> *) a. Monad m => a -> m a
return ())
{-# INLINABLE captureT #-}

-- | Capture the current state above the base monad
captureM :: MonadBaseControl b m stM => m (stM ())
captureM :: forall (b :: * -> *) (m :: * -> *) (stM :: * -> *).
MonadBaseControl b m stM =>
m (stM ())
captureM = forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a.
MonadBaseControl b m stM =>
(RunInBase m b stM -> b a) -> m a
liftBaseWith forall a b. (a -> b) -> a -> b
$ \RunInBase m b stM
runInBase -> RunInBase m b stM
runInBase (forall (m :: * -> *) a. Monad m => a -> m a
return ())
{-# INLINABLE captureM #-}

-- | @liftBaseOp@ is a particular application of 'liftBaseWith' that allows
-- lifting control operations of type:
--
-- @((a -> b c) -> b c)@
--
-- to:
--
-- @('MonadBaseControl' b m => (a -> m c) -> m c)@
--
-- For example:
--
-- @liftBaseOp alloca :: 'MonadBaseControl' 'IO' m => (Ptr a -> m c) -> m c@
liftBaseOp :: MonadBaseControl b m stM
           => ((a -> b (stM c)) -> b (stM d))
           -> ((a ->      m c)  ->      m d)
liftBaseOp :: forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a c d.
MonadBaseControl b m stM =>
((a -> b (stM c)) -> b (stM d)) -> (a -> m c) -> m d
liftBaseOp (a -> b (stM c)) -> b (stM d)
f = \a -> m c
g -> forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a.
MonadBaseControl b m stM =>
(RunInBase m b stM -> b (stM a)) -> m a
control forall a b. (a -> b) -> a -> b
$ \RunInBase m b stM
runInBase -> (a -> b (stM c)) -> b (stM d)
f forall a b. (a -> b) -> a -> b
$ RunInBase m b stM
runInBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m c
g
{-# INLINABLE liftBaseOp #-}

-- | @liftBaseOp_@ is a particular application of 'liftBaseWith' that allows
-- lifting control operations of type:
--
-- @(b a -> b a)@
--
-- to:
--
-- @('MonadBaseControl' b m => m a -> m a)@
--
-- For example:
--
-- @liftBaseOp_ mask_ :: 'MonadBaseControl' 'IO' m => m a -> m a@
liftBaseOp_ :: MonadBaseControl b m stM
            => (b (stM a) -> b (stM c))
            -> (     m a  ->      m c)
liftBaseOp_ :: forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a c.
MonadBaseControl b m stM =>
(b (stM a) -> b (stM c)) -> m a -> m c
liftBaseOp_ b (stM a) -> b (stM c)
f = \m a
m -> forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a.
MonadBaseControl b m stM =>
(RunInBase m b stM -> b (stM a)) -> m a
control forall a b. (a -> b) -> a -> b
$ \RunInBase m b stM
runInBase -> b (stM a) -> b (stM c)
f forall a b. (a -> b) -> a -> b
$ RunInBase m b stM
runInBase m a
m
{-# INLINABLE liftBaseOp_ #-}

-- | @liftBaseDiscard@ is a particular application of 'liftBaseWith' that allows
-- lifting control operations of type:
--
-- @(b () -> b a)@
--
-- to:
--
-- @('MonadBaseControl' b m => m () -> m a)@
--
-- Note that, while the argument computation @m ()@ has access to the captured
-- state, all its side-effects in @m@ are discarded. It is run only for its
-- side-effects in the base monad @b@.
--
-- For example:
--
-- @liftBaseDiscard forkIO :: 'MonadBaseControl' 'IO' m => m () -> m ThreadId@
liftBaseDiscard :: MonadBaseControl b m stM => (b () -> b a) -> (m () -> m a)
liftBaseDiscard :: forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a.
MonadBaseControl b m stM =>
(b () -> b a) -> m () -> m a
liftBaseDiscard b () -> b a
f = \m ()
m -> forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a.
MonadBaseControl b m stM =>
(RunInBase m b stM -> b a) -> m a
liftBaseWith forall a b. (a -> b) -> a -> b
$ \RunInBase m b stM
runInBase -> b () -> b a
f forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ RunInBase m b stM
runInBase m ()
m
{-# INLINABLE liftBaseDiscard #-}

-- | @liftBaseOpDiscard@ is a particular application of 'liftBaseWith' that allows
-- lifting control operations of type:
--
-- @((a -> b ()) -> b c)@
--
-- to:
--
-- @('MonadBaseControl' b m => (a -> m ()) -> m c)@
--
-- Note that, while the argument computation @m ()@ has access to the captured
-- state, all its side-effects in @m@ are discarded. It is run only for its
-- side-effects in the base monad @b@.
--
-- For example:
--
-- @liftBaseDiscard (runServer addr port) :: 'MonadBaseControl' 'IO' m => m () -> m ()@
liftBaseOpDiscard :: MonadBaseControl b m stM
                  => ((a -> b ()) -> b c)
                  ->  (a -> m ()) -> m c
liftBaseOpDiscard :: forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a c.
MonadBaseControl b m stM =>
((a -> b ()) -> b c) -> (a -> m ()) -> m c
liftBaseOpDiscard (a -> b ()) -> b c
f a -> m ()
g = forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a.
MonadBaseControl b m stM =>
(RunInBase m b stM -> b a) -> m a
liftBaseWith forall a b. (a -> b) -> a -> b
$ \RunInBase m b stM
runInBase -> (a -> b ()) -> b c
f forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunInBase m b stM
runInBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m ()
g
{-# INLINABLE liftBaseOpDiscard #-}

-- | Transform an action in @t m@ using a transformer that operates on the underlying monad @m@
liftThrough
    :: (MonadTransControl t stT, Monad (t m), Monad m)
    => (m (stT a) -> m (stT b)) -- ^
    -> t m a -> t m b
liftThrough :: forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (m :: * -> *) a b.
(MonadTransControl t stT, Monad (t m), Monad m) =>
(m (stT a) -> m (stT b)) -> t m a -> t m b
liftThrough m (stT a) -> m (stT b)
f t m a
t = do
  stT b
st <- forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (m :: * -> *) a.
(MonadTransControl t stT, Monad m) =>
(Run t stT -> m a) -> t m a
liftWith forall a b. (a -> b) -> a -> b
$ \Run t stT
run -> do
    m (stT a) -> m (stT b)
f forall a b. (a -> b) -> a -> b
$ Run t stT
run t m a
t
  forall (t :: (* -> *) -> * -> *) (stT :: * -> *) (m :: * -> *) a.
(MonadTransControl t stT, Monad m) =>
m (stT a) -> t m a
restoreT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return stT b
st