{-# LANGUAGE CPP
           , NoImplicitPrelude
           , RankNTypes
           , TypeFamilies
           , 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@.

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
    ( -- * MonadTransControl
      MonadTransControl(..), Run

      -- ** Defaults
      -- $MonadTransControlDefaults
    , RunDefault, defaultLiftWith, defaultRestoreT
      -- *** Defaults for a stack of two
      -- $MonadTransControlDefaults2
    , RunDefault2, defaultLiftWith2, defaultRestoreT2

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

      -- ** Defaults
      -- $MonadBaseControlDefaults
    , ComposeSt, 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 )
import Control.Monad ( void )
import Prelude       ( id )

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.List     ( ListT    (ListT),     runListT )
import Control.Monad.Trans.Maybe    ( MaybeT   (MaybeT),    runMaybeT )
import Control.Monad.Trans.Error    ( ErrorT   (ErrorT),    runErrorT, Error )
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 )

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 )


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

-- | The @MonadTransControl@ type class is a stronger version of @'MonadTrans'@:
--
-- Instances of @'MonadTrans'@ know how to @'lift'@ actions in the base monad to
-- the transformed monad. These lifted actions, however, are completely unaware
-- of the monadic state added by the transformer.
--
-- @'MonadTransControl'@ instances are aware of the monadic state of the
-- transformer and allow to save and restore this state.
--
-- This allows to lift functions that have a monad transformer in both positive
-- and negative position. Take, for example, the function
--
-- @
-- withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
-- @
--
-- @'MonadTrans'@ instances can only lift the return type of the @withFile@
-- function:
--
-- @
-- withFileLifted :: MonadTrans t => FilePath -> IOMode -> (Handle -> IO r) -> t IO r
-- withFileLifted file mode action = lift (withFile file mode action)
-- @
--
-- However, @'MonadTrans'@ is not powerful enough to make @withFileLifted@
-- accept a function that returns @t IO@. The reason is that we need to take
-- away the transformer layer in order to pass the function to @'withFile'@.
-- @'MonadTransControl'@ allows us to do this:
--
-- @
-- withFileLifted' :: (Monad (t IO), MonadTransControl t) => FilePath -> IOMode -> (Handle -> t IO r) -> t IO r
-- withFileLifted' file mode action = liftWith (\\run -> withFile file mode (run . action)) >>= restoreT . return
-- @
class MonadTrans t => MonadTransControl t where
  -- | Monadic state of @t@.
  --
  -- The monadic state of a monad transformer is the result type of its @run@
  -- function, e.g.:
  --
  -- @
  -- 'runReaderT' :: 'ReaderT' r m a -> r -> m a
  -- 'StT' ('ReaderT' r) a ~ a
  --
  -- 'runStateT' :: 'StateT' s m a -> s -> m (a, s)
  -- 'StT' ('StateT' s) a ~ (a, s)
  --
  -- 'runMaybeT' :: 'MaybeT' m a -> m ('Maybe' a)
  -- 'StT' 'MaybeT' a ~ 'Maybe' a
  -- @
  --
  -- Provided type instances:
  --
  -- @
  -- StT 'IdentityT'    a ~ a
  -- StT 'MaybeT'       a ~ 'Maybe' a
  -- StT ('ErrorT' e)   a ~ 'Error' e => 'Either' e a
  -- StT ('ExceptT' e)  a ~ 'Either' e a
  -- StT 'ListT'        a ~ [a]
  -- StT ('ReaderT' r)  a ~ a
  -- StT ('StateT' s)   a ~ (a, s)
  -- StT ('WriterT' w)  a ~ 'Monoid' w => (a, w)
  -- StT ('RWST' r w s) a ~ 'Monoid' w => (a, s, w)
  -- @
  type StT t a :: *

  -- | @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, e.g.
  --
  -- @
  -- withFileLifted :: (Monad (t IO), MonadTransControl t) => FilePath -> IOMode -> (Handle -> t IO r) -> t IO r
  -- withFileLifted file mode action = liftWith (\\run -> withFile file mode (run . action)) >>= restoreT . return
  -- @
  --
  -- If the @Run@ function is ignored, @liftWith@ coincides with @lift@:
  --
  -- @lift f = liftWith (\\_ -> f)@
  --
  -- Implementations use the @'Run'@ function associated with a transformer:
  --
  -- @
  -- liftWith :: 'Monad' m => (('Monad' n => 'ReaderT' r n b -> n b) -> m a) -> 'ReaderT' r m a
  -- liftWith f = 'ReaderT' (\\r -> f (\\action -> 'runReaderT' action r))
  --
  -- liftWith :: 'Monad' m => (('Monad' n => 'StateT' s n b -> n (b, s)) -> m a) -> 'StateT' s m a
  -- liftWith f = 'StateT' (\\s -> 'liftM' (\\x -> (x, s)) (f (\\action -> 'runStateT' action s)))
  --
  -- liftWith :: 'Monad' m => (('Monad' n => 'MaybeT' n b -> n ('Maybe' b)) -> m a) -> 'MaybeT' m a
  -- liftWith f = 'MaybeT' ('liftM' 'Just' (f 'runMaybeT'))
  -- @
  liftWith :: Monad m => (Run t -> 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@ is usually implemented through the constructor of the monad
  -- transformer:
  --
  -- @
  -- 'ReaderT'  :: (r -> m a) -> 'ReaderT' r m a
  -- restoreT ::       m a  -> 'ReaderT' r m a
  -- restoreT action = 'ReaderT' { runReaderT = 'const' action }
  --
  -- 'StateT'   :: (s -> m (a, s)) -> 'StateT' s m a
  -- restoreT ::       m (a, s)  -> 'StateT' s m a
  -- restoreT action = 'StateT' { runStateT = 'const' action }
  --
  -- 'MaybeT'   :: m ('Maybe' a) -> 'MaybeT' m a
  -- restoreT :: m ('Maybe' a) -> 'MaybeT' m a
  -- restoreT action = 'MaybeT' action
  -- @
  --
  -- Example type signatures:
  --
  -- @
  -- restoreT :: 'Monad' m             => m a            -> 'IdentityT' m a
  -- restoreT :: 'Monad' m             => m ('Maybe' a)    -> 'MaybeT' m a
  -- restoreT :: ('Monad' m, 'Error' e)  => m ('Either' e a) -> 'ErrorT' e m a
  -- restoreT :: 'Monad' m             => m ('Either' e a) -> 'ExceptT' e m a
  -- restoreT :: 'Monad' m             => m [a]          -> 'ListT' m a
  -- restoreT :: 'Monad' m             => m a            -> 'ReaderT' r m a
  -- restoreT :: 'Monad' m             => m (a, s)       -> 'StateT' s m a
  -- restoreT :: ('Monad' m, 'Monoid' w) => m (a, w)       -> 'WriterT' w m a
  -- restoreT :: ('Monad' m, 'Monoid' w) => m (a, s, w)    -> 'RWST' r w s m a
  -- @
  restoreT :: Monad m => m (StT t 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'.
--
-- Example type equalities:
--
-- @
-- Run 'IdentityT'    ~ forall n b. 'Monad' n             => 'IdentityT'  n b -> n b
-- Run 'MaybeT'       ~ forall n b. 'Monad' n             => 'MaybeT'     n b -> n ('Maybe' b)
-- Run ('ErrorT' e)   ~ forall n b. ('Monad' n, 'Error' e)  => 'ErrorT' e   n b -> n ('Either' e b)
-- Run ('ExceptT' e)  ~ forall n b. 'Monad' n             => 'ExceptT' e  n b -> n ('Either' e b)
-- Run 'ListT'        ~ forall n b. 'Monad' n             => 'ListT'      n b -> n [b]
-- Run ('ReaderT' r)  ~ forall n b. 'Monad' n             => 'ReaderT' r  n b -> n b
-- Run ('StateT' s)   ~ forall n b. 'Monad' n             => 'StateT' s   n b -> n (a, s)
-- Run ('WriterT' w)  ~ forall n b. ('Monad' n, 'Monoid' w) => 'WriterT' w  n b -> n (a, w)
-- Run ('RWST' r w s) ~ forall n b. ('Monad' n, 'Monoid' w) => 'RWST' r w s n b -> n (a, s, w)
-- @
--
-- This type is usually satisfied by the @run@ function of a transformer:
--
-- @
-- 'flip' 'runReaderT' :: r -> Run ('ReaderT' r)
-- 'flip' 'runStateT'  :: s -> Run ('StateT' s)
-- 'runMaybeT'       ::      Run 'MaybeT'
-- @
type Run t = forall n b. Monad n => t n b -> n (StT t 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 t' = forall n b. Monad n => t n b -> n (StT t' b)

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

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

-------------------------------------------------------------------------------
--
-------------------------------------------------------------------------------

-- $MonadTransControlDefaults2
--
-- The following functions can be used to define a 'MonadTransControl' instance
-- for a monad transformer stack of two.
--
-- @
-- {-\# LANGUAGE GeneralizedNewtypeDeriving \#-}
--
-- newtype CalcT m a = CalcT { unCalcT :: StateT Int (ExceptT String m) a }
--   deriving (Monad, MonadTrans)
--
-- instance MonadTransControl CalcT where
--     type StT CalcT a = StT (ExceptT String) (StT (StateT Int) a)
--     liftWith = 'defaultLiftWith2' CalcT unCalcT
--     restoreT = 'defaultRestoreT2' CalcT
-- @

-- | A function like 'Run' that runs a monad transformer @t@ which wraps the
-- monad transformers @n@ and @n'@. This is used in 'defaultLiftWith2'.
type RunDefault2 t n n' = forall m b. (Monad m, Monad (n' m)) => t m b -> m (StT n' (StT n b))

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

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

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

instance MonadTransControl IdentityT where
    type StT IdentityT a = a
    liftWith :: (Run IdentityT -> m a) -> IdentityT m a
liftWith Run IdentityT -> m a
f = m a -> IdentityT m a
forall k (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT (m a -> IdentityT m a) -> m a -> IdentityT m a
forall a b. (a -> b) -> a -> b
$ Run IdentityT -> m a
f (Run IdentityT -> m a) -> Run IdentityT -> m a
forall a b. (a -> b) -> a -> b
$ forall k (f :: k -> *) (a :: k). IdentityT f a -> f a
Run IdentityT
runIdentityT
    restoreT :: m (StT IdentityT a) -> IdentityT m a
restoreT = m (StT IdentityT a) -> IdentityT m a
forall k (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

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

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

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

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

instance MonadTransControl (ReaderT r) where
    type StT (ReaderT r) a = a
    liftWith :: (Run (ReaderT r) -> m a) -> ReaderT r m a
liftWith Run (ReaderT r) -> m a
f = (r -> m a) -> ReaderT r m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m a) -> ReaderT r m a) -> (r -> m a) -> ReaderT r m a
forall a b. (a -> b) -> a -> b
$ \r
r -> Run (ReaderT r) -> m a
f (Run (ReaderT r) -> m a) -> Run (ReaderT r) -> m a
forall a b. (a -> b) -> a -> b
$ \ReaderT r n b
t -> ReaderT r n b -> r -> n b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r n b
t r
r
    restoreT :: m (StT (ReaderT r) a) -> ReaderT r m a
restoreT = (r -> m a) -> ReaderT r m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m a) -> ReaderT r m a)
-> (m a -> r -> m a) -> m a -> ReaderT r m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> r -> m a
forall a b. a -> b -> a
const
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance MonadTransControl (StateT s) where
    type StT (StateT s) a = (a, s)
    liftWith :: (Run (StateT s) -> m a) -> StateT s m a
liftWith Run (StateT s) -> m a
f = (s -> m (a, s)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((s -> m (a, s)) -> StateT s m a)
-> (s -> m (a, s)) -> StateT s m a
forall a b. (a -> b) -> a -> b
$ \s
s ->
                   (a -> (a, s)) -> m a -> m (a, s)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\a
x -> (a
x, s
s))
                         (Run (StateT s) -> m a
f (Run (StateT s) -> m a) -> Run (StateT s) -> m a
forall a b. (a -> b) -> a -> b
$ \StateT s n b
t -> StateT s n b -> s -> n (b, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT s n b
t s
s)
    restoreT :: m (StT (StateT s) a) -> StateT s m a
restoreT = (s -> m (a, s)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((s -> m (a, s)) -> StateT s m a)
-> (m (a, s) -> s -> m (a, s)) -> m (a, s) -> StateT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (a, s) -> s -> m (a, s)
forall a b. a -> b -> a
const
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance MonadTransControl (Strict.StateT s) where
    type StT (Strict.StateT s) a = (a, s)
    liftWith :: (Run (StateT s) -> m a) -> StateT s m a
liftWith Run (StateT s) -> m a
f = (s -> m (a, s)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
Strict.StateT ((s -> m (a, s)) -> StateT s m a)
-> (s -> m (a, s)) -> StateT s m a
forall a b. (a -> b) -> a -> b
$ \s
s ->
                   (a -> (a, s)) -> m a -> m (a, s)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\a
x -> (a
x, s
s))
                         (Run (StateT s) -> m a
f (Run (StateT s) -> m a) -> Run (StateT s) -> m a
forall a b. (a -> b) -> a -> b
$ \StateT s n b
t -> StateT s n b -> s -> n (b, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Strict.runStateT StateT s n b
t s
s)
    restoreT :: m (StT (StateT s) a) -> StateT s m a
restoreT = (s -> m (a, s)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
Strict.StateT ((s -> m (a, s)) -> StateT s m a)
-> (m (a, s) -> s -> m (a, s)) -> m (a, s) -> StateT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (a, s) -> s -> m (a, s)
forall a b. a -> b -> a
const
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance Monoid w => MonadTransControl (WriterT w) where
    type StT (WriterT w) a = (a, w)
    liftWith :: (Run (WriterT w) -> m a) -> WriterT w m a
liftWith Run (WriterT w) -> m a
f = m (a, w) -> WriterT w m a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (m (a, w) -> WriterT w m a) -> m (a, w) -> WriterT w m a
forall a b. (a -> b) -> a -> b
$ (a -> (a, w)) -> m a -> m (a, w)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\a
x -> (a
x, w
forall a. Monoid a => a
mempty))
                                 (Run (WriterT w) -> m a
f (Run (WriterT w) -> m a) -> Run (WriterT w) -> m a
forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Run (WriterT w)
runWriterT)
    restoreT :: m (StT (WriterT w) a) -> WriterT w m a
restoreT = m (StT (WriterT w) a) -> WriterT w m a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance Monoid w => MonadTransControl (Strict.WriterT w) where
    type StT (Strict.WriterT w) a = (a, w)
    liftWith :: (Run (WriterT w) -> m a) -> WriterT w m a
liftWith Run (WriterT w) -> m a
f = m (a, w) -> WriterT w m a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Strict.WriterT (m (a, w) -> WriterT w m a) -> m (a, w) -> WriterT w m a
forall a b. (a -> b) -> a -> b
$ (a -> (a, w)) -> m a -> m (a, w)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\a
x -> (a
x, w
forall a. Monoid a => a
mempty))
                                        (Run (WriterT w) -> m a
f (Run (WriterT w) -> m a) -> Run (WriterT w) -> m a
forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Run (WriterT w)
Strict.runWriterT)
    restoreT :: m (StT (WriterT w) a) -> WriterT w m a
restoreT = m (StT (WriterT w) a) -> WriterT w m a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Strict.WriterT
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance Monoid w => MonadTransControl (RWST r w s) where
    type StT (RWST r w s) a = (a, s, w)
    liftWith :: (Run (RWST r w s) -> m a) -> RWST r w s m a
liftWith Run (RWST r w s) -> m a
f = (r -> s -> m (a, s, w)) -> RWST r w s m a
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWST ((r -> s -> m (a, s, w)) -> RWST r w s m a)
-> (r -> s -> m (a, s, w)) -> RWST r w s m a
forall a b. (a -> b) -> a -> b
$ \r
r s
s -> (a -> (a, s, w)) -> m a -> m (a, s, w)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\a
x -> (a
x, s
s, w
forall a. Monoid a => a
mempty))
                                      (Run (RWST r w s) -> m a
f (Run (RWST r w s) -> m a) -> Run (RWST r w s) -> m a
forall a b. (a -> b) -> a -> b
$ \RWST r w s n b
t -> RWST r w s n b -> r -> s -> n (b, s, w)
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 :: m (StT (RWST r w s) a) -> RWST r w s m a
restoreT m (StT (RWST r w s) a)
mSt = (r -> s -> m (a, s, w)) -> RWST r w s m a
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWST ((r -> s -> m (a, s, w)) -> RWST r w s m a)
-> (r -> s -> m (a, s, w)) -> RWST r w s m a
forall a b. (a -> b) -> a -> b
$ \r
_ s
_ -> m (a, s, w)
m (StT (RWST r w s) a)
mSt
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance Monoid w => MonadTransControl (Strict.RWST r w s) where
    type StT (Strict.RWST r w s) a = (a, s, w)
    liftWith :: (Run (RWST r w s) -> m a) -> RWST r w s m a
liftWith Run (RWST r w s) -> m a
f =
        (r -> s -> m (a, s, w)) -> RWST r w s m a
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
Strict.RWST ((r -> s -> m (a, s, w)) -> RWST r w s m a)
-> (r -> s -> m (a, s, w)) -> RWST r w s m a
forall a b. (a -> b) -> a -> b
$ \r
r s
s -> (a -> (a, s, w)) -> m a -> m (a, s, w)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\a
x -> (a
x, s
s, w
forall a. Monoid a => a
mempty))
                                    (Run (RWST r w s) -> m a
f (Run (RWST r w s) -> m a) -> Run (RWST r w s) -> m a
forall a b. (a -> b) -> a -> b
$ \RWST r w s n b
t -> RWST r w s n b -> r -> s -> n (b, s, w)
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 :: m (StT (RWST r w s) a) -> RWST r w s m a
restoreT m (StT (RWST r w s) a)
mSt = (r -> s -> m (a, s, w)) -> RWST r w s m a
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
Strict.RWST ((r -> s -> m (a, s, w)) -> RWST r w s m a)
-> (r -> s -> m (a, s, w)) -> RWST r w s m a
forall a b. (a -> b) -> a -> b
$ \r
_ s
_ -> m (a, s, w)
m (StT (RWST r w s) a)
mSt
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}


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

-- |
-- == Writing instances
--
-- The usual way to write a @'MonadBaseControl'@ instance for a transformer
-- stack over a base monad @B@ is to write an instance @MonadBaseControl B B@
-- for the base monad, and @MonadTransControl T@ instances for every transformer
-- @T@. Instances for @'MonadBaseControl'@ are then simply implemented using
-- @'ComposeSt'@, @'defaultLiftBaseWith'@, @'defaultRestoreM'@.
class MonadBase b m => MonadBaseControl b m | m -> b where
    -- | Monadic state that @m@ adds to the base monad @b@.
    --
    -- For all base (non-transformed) monads, @StM m a ~ a@:
    --
    -- @
    -- StM 'IO'         a ~ a
    -- StM 'Maybe'      a ~ a
    -- StM ('Either' e) a ~ a
    -- StM []         a ~ a
    -- StM ((->) r)   a ~ a
    -- StM 'Identity'   a ~ a
    -- StM 'STM'        a ~ a
    -- StM ('ST' s)     a ~ a
    -- @
    --
    -- If @m@ is a transformed monad, @m ~ t b@, @'StM'@ is the monadic state of
    -- the transformer @t@ (given by its 'StT' from 'MonadTransControl'). For a
    -- transformer stack, @'StM'@ is defined recursively:
    --
    -- @
    -- StM ('IdentityT'  m) a ~ 'ComposeSt' 'IdentityT' m a ~ StM m a
    -- StM ('MaybeT'     m) a ~ 'ComposeSt' 'MaybeT'    m a ~ StM m ('Maybe' a)
    -- StM ('ErrorT' e   m) a ~ 'ComposeSt' 'ErrorT'    m a ~ 'Error' e => StM m ('Either' e a)
    -- StM ('ExceptT' e  m) a ~ 'ComposeSt' 'ExceptT'   m a ~ StM m ('Either' e a)
    -- StM ('ListT'      m) a ~ 'ComposeSt' 'ListT'     m a ~ StM m [a]
    -- StM ('ReaderT' r  m) a ~ 'ComposeSt' 'ReaderT'   m a ~ StM m a
    -- StM ('StateT' s   m) a ~ 'ComposeSt' 'StateT'    m a ~ StM m (a, s)
    -- StM ('WriterT' w  m) a ~ 'ComposeSt' 'WriterT'   m a ~ 'Monoid' w => StM m (a, w)
    -- StM ('RWST' r w s m) a ~ 'ComposeSt' 'RWST'      m a ~ 'Monoid' w => StM m (a, s, w)
    -- @
    type StM m a :: *

    -- | @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:
    --
    -- @
    -- withFileLifted :: MonadBaseControl IO m => FilePath -> IOMode -> (Handle -> m a) -> m a
    -- withFileLifted file mode action = liftBaseWith (\\runInBase -> withFile file mode (runInBase . action)) >>= restoreM
    --                              -- = control $ \\runInBase -> withFile file mode (runInBase . action)
    --                              -- = liftBaseOp (withFile file mode) action
    -- @
    --
    -- @'liftBaseWith'@ is usually not implemented directly, but using
    -- @'defaultLiftBaseWith'@.
    liftBaseWith :: (RunInBase m b -> 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'@ is usually not implemented directly, but using
    -- @'defaultRestoreM'@.
    restoreM :: StM m 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'.
--
-- Example type equalities:
--
-- @
-- RunInBase ('IdentityT'  m) b ~ forall a.             'IdentityT'  m a -> b ('StM' m a)
-- RunInBase ('MaybeT'     m) b ~ forall a.             'MaybeT'     m a -> b ('StM' m ('Maybe' a))
-- RunInBase ('ErrorT' e   m) b ~ forall a. 'Error' e =>  'ErrorT' e   m a -> b ('StM' m ('Either' e a))
-- RunInBase ('ExceptT' e  m) b ~ forall a.             'ExceptT' e  m a -> b ('StM' m ('Either' e a))
-- RunInBase ('ListT'      m) b ~ forall a.             'ListT'      m a -> b ('StM' m [a])
-- RunInBase ('ReaderT' r  m) b ~ forall a.             'ReaderT'    m a -> b ('StM' m a)
-- RunInBase ('StateT' s   m) b ~ forall a.             'StateT' s   m a -> b ('StM' m (a, s))
-- RunInBase ('WriterT' w  m) b ~ forall a. 'Monoid' w => 'WriterT' w  m a -> b ('StM' m (a, w))
-- RunInBase ('RWST' r w s m) b ~ forall a. 'Monoid' w => 'RWST' r w s m a -> b ('StM' m (a, s, w))
-- @
--
-- For a transformed base monad @m ~ t b@, @'RunInBase m b' ~ 'Run' t@.
type RunInBase m b = forall a. m a -> b (StM m a)


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

#define BASE(M)                           \
instance MonadBaseControl (M) (M) where { \
    type StM (M) a = a;                   \
    liftBaseWith f = f id;                \
    restoreM = return;                    \
    {-# INLINABLE liftBaseWith #-};       \
    {-# INLINABLE restoreM #-}}

BASE(IO)
BASE(Maybe)
BASE(Either e)
BASE([])
BASE((->) r)
BASE(Identity)

BASE(STM)

BASE(Strict.ST s)
BASE(       ST s)

#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'
-- @

-- | Handy type synonym that composes the monadic states of @t@ and @m@.
--
-- It can be used to define the 'StM' for new 'MonadBaseControl' instances.
type ComposeSt t m a = StM m (StT t a)

-- | 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 = forall a. t m a -> b (ComposeSt t m 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, MonadBaseControl b m)
                    => (RunInBaseDefault t m b -> b a) -> t m a
defaultLiftBaseWith :: (RunInBaseDefault t m b -> b a) -> t m a
defaultLiftBaseWith = \RunInBaseDefault t m b -> b a
f -> (Run t -> m a) -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith ((Run t -> m a) -> t m a) -> (Run t -> m a) -> t m a
forall a b. (a -> b) -> a -> b
$ \Run t
run ->
                              (RunInBase m b -> b a) -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith ((RunInBase m b -> b a) -> m a) -> (RunInBase m b -> b a) -> m a
forall a b. (a -> b) -> a -> b
$ \RunInBase m b
runInBase ->
                                RunInBaseDefault t m b -> b a
f (RunInBaseDefault t m b -> b a) -> RunInBaseDefault t m b -> b a
forall a b. (a -> b) -> a -> b
$ m (StT t a) -> b (StM m (StT t a))
RunInBase m b
runInBase (m (StT t a) -> b (StM m (StT t a)))
-> (t m a -> m (StT t a)) -> t m a -> b (StM m (StT t a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t m a -> m (StT t a)
Run t
run
{-# INLINABLE defaultLiftBaseWith #-}

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


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

#define BODY(T) {                         \
    type StM (T m) a = ComposeSt (T) m a; \
    liftBaseWith = defaultLiftBaseWith;   \
    restoreM     = defaultRestoreM;       \
    {-# INLINABLE liftBaseWith #-};       \
    {-# INLINABLE restoreM #-}}

#define TRANS(         T) \
  instance (     MonadBaseControl b m) => MonadBaseControl b (T m) where BODY(T)
#define TRANS_CTX(CTX, T) \
  instance (CTX, MonadBaseControl b m) => MonadBaseControl b (T m) where BODY(T)

TRANS(IdentityT)
TRANS(MaybeT)
TRANS(ListT)
TRANS(ReaderT r)
TRANS(Strict.StateT s)
TRANS(       StateT s)
TRANS(ExceptT e)

TRANS_CTX(Error e,         ErrorT e)
TRANS_CTX(Monoid w, Strict.WriterT w)
TRANS_CTX(Monoid w,        WriterT w)
TRANS_CTX(Monoid w, Strict.RWST r w s)
TRANS_CTX(Monoid w,        RWST r w s)

#undef BODY
#undef TRANS
#undef TRANS_CTX

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

-- | An often used composition: @control f = 'liftBaseWith' f >>= 'restoreM'@
--
-- Example:
--
-- @
-- liftedBracket :: MonadBaseControl IO m => m a -> (a -> m b) -> (a -> m c) -> m c
-- liftedBracket acquire release action = control $ \\runInBase ->
--     bracket (runInBase acquire)
--             (\\saved -> runInBase (restoreM saved >>= release))
--             (\\saved -> runInBase (restoreM saved >>= action))
-- @
control :: MonadBaseControl b m => (RunInBase m b -> b (StM m a)) -> m a
control :: (RunInBase m b -> b (StM m a)) -> m a
control RunInBase m b -> b (StM m a)
f = (RunInBase m b -> b (StM m a)) -> m (StM m a)
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith RunInBase m b -> b (StM m a)
f m (StM m a) -> (StM m a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StM m a -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM
{-# INLINABLE control #-}

-- | Lift a computation and restore the monadic state immediately:
-- @controlT f = 'liftWith' f >>= 'restoreT' . return@.
controlT :: (MonadTransControl t, Monad (t m), Monad m)
         => (Run t -> m (StT t a)) -> t m a
controlT :: (Run t -> m (StT t a)) -> t m a
controlT Run t -> m (StT t a)
f = (Run t -> m (StT t a)) -> t m (StT t a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith Run t -> m (StT t a)
f t m (StT t a) -> (StT t a -> t m a) -> t m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (StT t a) -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT t a) -> t m a
restoreT (m (StT t a) -> t m a)
-> (StT t a -> m (StT t a)) -> StT t a -> t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StT t a -> m (StT t a)
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 => (a -> m c) -> m (a -> b (StM m c))
embed :: (a -> m c) -> m (a -> b (StM m c))
embed a -> m c
f = (RunInBase m b -> b (a -> b (StM m c))) -> m (a -> b (StM m c))
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith ((RunInBase m b -> b (a -> b (StM m c))) -> m (a -> b (StM m c)))
-> (RunInBase m b -> b (a -> b (StM m c))) -> m (a -> b (StM m c))
forall a b. (a -> b) -> a -> b
$ \RunInBase m b
runInBase -> (a -> b (StM m c)) -> b (a -> b (StM m c))
forall (m :: * -> *) a. Monad m => a -> m a
return (m c -> b (StM m c)
RunInBase m b
runInBase (m c -> b (StM m c)) -> (a -> m c) -> a -> b (StM m c)
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 => (a -> m ()) -> m (a -> b ())
embed_ :: (a -> m ()) -> m (a -> b ())
embed_ a -> m ()
f = (RunInBase m b -> b (a -> b ())) -> m (a -> b ())
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith ((RunInBase m b -> b (a -> b ())) -> m (a -> b ()))
-> (RunInBase m b -> b (a -> b ())) -> m (a -> b ())
forall a b. (a -> b) -> a -> b
$ \RunInBase m b
runInBase -> (a -> b ()) -> b (a -> b ())
forall (m :: * -> *) a. Monad m => a -> m a
return (b (StM m ()) -> b ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (b (StM m ()) -> b ()) -> (a -> b (StM m ())) -> a -> b ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> b (StM m ())
RunInBase m b
runInBase (m () -> b (StM m ())) -> (a -> m ()) -> a -> b (StM m ())
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, Monad (t m), Monad m) => t m (StT t ())
captureT :: t m (StT t ())
captureT = (Run t -> m (StT t ())) -> t m (StT t ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith ((Run t -> m (StT t ())) -> t m (StT t ()))
-> (Run t -> m (StT t ())) -> t m (StT t ())
forall a b. (a -> b) -> a -> b
$ \Run t
runInM -> t m () -> m (StT t ())
Run t
runInM (() -> t m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
{-# INLINABLE captureT #-}

-- | Capture the current state above the base monad
captureM :: MonadBaseControl b m => m (StM m ())
captureM :: m (StM m ())
captureM = (RunInBase m b -> b (StM m ())) -> m (StM m ())
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith ((RunInBase m b -> b (StM m ())) -> m (StM m ()))
-> (RunInBase m b -> b (StM m ())) -> m (StM m ())
forall a b. (a -> b) -> a -> b
$ \RunInBase m b
runInBase -> m () -> b (StM m ())
RunInBase m b
runInBase (() -> m ()
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 :: (Storable a, 'MonadBaseControl' 'IO' m) => (Ptr a -> m c) -> m c@
liftBaseOp :: MonadBaseControl b m
           => ((a -> b (StM m c)) -> b (StM m d))
           -> ((a ->        m c)  ->        m d)
liftBaseOp :: ((a -> b (StM m c)) -> b (StM m d)) -> (a -> m c) -> m d
liftBaseOp (a -> b (StM m c)) -> b (StM m d)
f = \a -> m c
g -> (RunInBase m b -> b (StM m d)) -> m d
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b (StM m a)) -> m a
control ((RunInBase m b -> b (StM m d)) -> m d)
-> (RunInBase m b -> b (StM m d)) -> m d
forall a b. (a -> b) -> a -> b
$ \RunInBase m b
runInBase -> (a -> b (StM m c)) -> b (StM m d)
f ((a -> b (StM m c)) -> b (StM m d))
-> (a -> b (StM m c)) -> b (StM m d)
forall a b. (a -> b) -> a -> b
$ m c -> b (StM m c)
RunInBase m b
runInBase (m c -> b (StM m c)) -> (a -> m c) -> a -> b (StM m c)
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
            => (b (StM m a) -> b (StM m c))
            -> (       m a  ->        m c)
liftBaseOp_ :: (b (StM m a) -> b (StM m c)) -> m a -> m c
liftBaseOp_ b (StM m a) -> b (StM m c)
f = \m a
m -> (RunInBase m b -> b (StM m c)) -> m c
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b (StM m a)) -> m a
control ((RunInBase m b -> b (StM m c)) -> m c)
-> (RunInBase m b -> b (StM m c)) -> m c
forall a b. (a -> b) -> a -> b
$ \RunInBase m b
runInBase -> b (StM m a) -> b (StM m c)
f (b (StM m a) -> b (StM m c)) -> b (StM m a) -> b (StM m c)
forall a b. (a -> b) -> a -> b
$ m a -> b (StM m a)
RunInBase m b
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 => (b () -> b a) -> (m () -> m a)
liftBaseDiscard :: (b () -> b a) -> m () -> m a
liftBaseDiscard b () -> b a
f = \m ()
m -> (RunInBase m b -> b a) -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith ((RunInBase m b -> b a) -> m a) -> (RunInBase m b -> b a) -> m a
forall a b. (a -> b) -> a -> b
$ \RunInBase m b
runInBase -> b () -> b a
f (b () -> b a) -> b () -> b a
forall a b. (a -> b) -> a -> b
$ b (StM m ()) -> b ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (b (StM m ()) -> b ()) -> b (StM m ()) -> b ()
forall a b. (a -> b) -> a -> b
$ m () -> b (StM m ())
RunInBase m b
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
                  => ((a -> b ()) -> b c)
                  ->  (a -> m ()) -> m c
liftBaseOpDiscard :: ((a -> b ()) -> b c) -> (a -> m ()) -> m c
liftBaseOpDiscard (a -> b ()) -> b c
f a -> m ()
g = (RunInBase m b -> b c) -> m c
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith ((RunInBase m b -> b c) -> m c) -> (RunInBase m b -> b c) -> m c
forall a b. (a -> b) -> a -> b
$ \RunInBase m b
runInBase -> (a -> b ()) -> b c
f ((a -> b ()) -> b c) -> (a -> b ()) -> b c
forall a b. (a -> b) -> a -> b
$ b (StM m ()) -> b ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (b (StM m ()) -> b ()) -> (a -> b (StM m ())) -> a -> b ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> b (StM m ())
RunInBase m b
runInBase (m () -> b (StM m ())) -> (a -> m ()) -> a -> b (StM m ())
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, Monad (t m), Monad m)
    => (m (StT t a) -> m (StT t b)) -- ^
    -> t m a -> t m b
liftThrough :: (m (StT t a) -> m (StT t b)) -> t m a -> t m b
liftThrough m (StT t a) -> m (StT t b)
f t m a
t = do
  StT t b
st <- (Run t -> m (StT t b)) -> t m (StT t b)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith ((Run t -> m (StT t b)) -> t m (StT t b))
-> (Run t -> m (StT t b)) -> t m (StT t b)
forall a b. (a -> b) -> a -> b
$ \Run t
run -> do
    m (StT t a) -> m (StT t b)
f (m (StT t a) -> m (StT t b)) -> m (StT t a) -> m (StT t b)
forall a b. (a -> b) -> a -> b
$ t m a -> m (StT t a)
Run t
run t m a
t
  m (StT t b) -> t m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT t a) -> t m a
restoreT (m (StT t b) -> t m b) -> m (StT t b) -> t m b
forall a b. (a -> b) -> a -> b
$ StT t b -> m (StT t b)
forall (m :: * -> *) a. Monad m => a -> m a
return StT t b
st