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

#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Safe #-}
#endif

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

{- |
Module      :  Control.Monad.Trans.Control
Copyright   :  Bas van Dijk, Anders Kaseorg
License     :  BSD-style

Maintainer  :  Bas van Dijk <v.dijk.bas@gmail.com>
Stability   :  experimental
-}

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, 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 Data.Functor.Identity ( Identity (..) )
import Data.Functor.Compose  ( Compose (..) )
import Data.Tuple    ( swap )

#if MIN_VERSION_base(4,4,0)
import           Control.Monad.ST.Lazy.Safe           ( ST )
import qualified Control.Monad.ST.Safe      as Strict ( ST )
#endif

-- 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 )

#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 . const . return = return@
  --
  -- @liftWith (const (m >>= f)) = liftWith (const m) >>= liftWith . const . f@
  --
  -- 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 wraps another monad transformer which
-- already has a @MonadTransControl@ instance. For example:
--
-- @
-- {-\# LANGUAGE GeneralizedNewtypeDeriving \#-}
--
-- 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 t unT = \f -> t $ liftWith $ \run -> f $ run . 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 t = t . restoreT
{-# INLINABLE defaultRestoreT #-}


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

instance MonadTransControl IdentityT Identity where
    liftWith f = IdentityT $ f $ \mx -> Identity <$> runIdentityT mx
    restoreT mx = IdentityT $ runIdentity <$> mx
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance MonadTransControl MaybeT Maybe where
    liftWith f = MaybeT $ liftM return $ f $ runMaybeT
    restoreT = MaybeT
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance Error e => MonadTransControl (ErrorT e) (Either e) where
    liftWith f = ErrorT $ liftM return $ f $ runErrorT
    restoreT = ErrorT
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance MonadTransControl (ExceptT e) (Either e) where
    liftWith f = ExceptT $ liftM return $ f $ runExceptT
    restoreT = ExceptT
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance MonadTransControl ListT [] where
    liftWith f = ListT $ liftM return $ f $ runListT
    restoreT = ListT
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance MonadTransControl (ReaderT r) Identity where
    liftWith f = ReaderT $ \r -> f $ \t -> Identity <$> runReaderT t r
    restoreT mx = ReaderT $ \_ -> runIdentity <$> mx
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance MonadTransControl (StateT s) ((,) s) where
    liftWith f = StateT $ \s -> (,s) <$> f (\t -> swap <$> runStateT t s)
    restoreT mx = StateT $ \_ -> swap <$> mx
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance MonadTransControl (Strict.StateT s) ((,) s) where
    liftWith f = Strict.StateT $ \s -> (,s) <$> f (\t -> swap <$> Strict.runStateT t s)
    restoreT mx = Strict.StateT $ \_ -> swap <$> mx
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance Monoid w => MonadTransControl (WriterT w) ((,) w) where
    liftWith f = WriterT $ (,mempty) <$> (f $ \t -> swap <$> runWriterT t)
    restoreT mx = WriterT $ swap <$> mx
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance Monoid w => MonadTransControl (Strict.WriterT w) ((,) w) where
    liftWith f = Strict.WriterT $ (,mempty) <$> (f $ \t -> swap <$> Strict.runWriterT t)
    restoreT mx = Strict.WriterT $ swap <$> mx
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance Monoid w => MonadTransControl (RWST r w s) ((,,) w s) where
    liftWith f = RWST $ \r s -> (,s,mempty) <$> (f $ \t -> (\(a,s,w) -> (w,s,a)) <$> runRWST t r s)
    restoreT mSt = RWST $ \_ _ -> (\(w,s,a) -> (a,s,w)) <$> mSt
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}

instance Monoid w => MonadTransControl (Strict.RWST r w s) ((,,) w s) where
    liftWith f = Strict.RWST $ \r s -> (,s,mempty) <$> (f $ \t -> (\(a,s,w) -> (w,s,a)) <$> Strict.runRWST t r s)
    restoreT mSt = Strict.RWST $ \_ _ -> (\(w,s,a) -> (a,s,w)) <$> 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 . const . return = return@
    --
    -- @liftBaseWith (const (m >>= f)) = liftBaseWith (const m) >>= liftBaseWith . const . f@
    --
    -- 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 f = f (\x -> Identity <$> x)
  restoreM x = pure (runIdentity x)
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance MonadBaseControl Maybe Maybe Identity where
  liftBaseWith f = f (\x -> Identity <$> x)
  restoreM x = pure (runIdentity x)
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance MonadBaseControl (Either e) (Either e) Identity where
  liftBaseWith f = f (\x -> Identity <$> x)
  restoreM x = pure (runIdentity x)
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance MonadBaseControl [] [] Identity where
  liftBaseWith f = f (\x -> Identity <$> x)
  restoreM x = pure (runIdentity x)
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance MonadBaseControl ((->) r) ((->) r) Identity where
  liftBaseWith f = f (\x -> Identity <$> x)
  restoreM x = pure (runIdentity x)
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance MonadBaseControl Identity Identity Identity where
  liftBaseWith f = f (\x -> Identity <$> x)
  restoreM x = pure (runIdentity x)
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance MonadBaseControl STM STM Identity where
  liftBaseWith f = f (\x -> Identity <$> x)
  restoreM x = pure (runIdentity x)
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

#if MIN_VERSION_base(4,4,0)
instance MonadBaseControl (Strict.ST s) (Strict.ST s) Identity where
  liftBaseWith f = f (\x -> Identity <$> x)
  restoreM x = pure (runIdentity x)
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance MonadBaseControl (ST s) (ST s) Identity where
  liftBaseWith f = f (\x -> Identity <$> x)
  restoreM x = pure (runIdentity 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 defintion 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 f = liftWith $ \run ->
                          liftBaseWith $ \runInBase ->
                            f (\t -> Compose <$> runInBase (run 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 (Compose x) = restoreT (restoreM x)
{-# INLINABLE defaultRestoreM #-}


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

instance (MonadBaseControl b m stM) => MonadBaseControl b (IdentityT m) (Compose stM Identity) where
  liftBaseWith = defaultLiftBaseWith
  restoreM     = defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance (MonadBaseControl b m stM) => MonadBaseControl b (MaybeT m) (Compose stM Maybe) where
  liftBaseWith = defaultLiftBaseWith
  restoreM     = defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance (MonadBaseControl b m stM) => MonadBaseControl b (ListT m) (Compose stM []) where
  liftBaseWith = defaultLiftBaseWith
  restoreM     = defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance (MonadBaseControl b m stM) => MonadBaseControl b (ReaderT r m) (Compose stM Identity) where
  liftBaseWith = defaultLiftBaseWith
  restoreM     = defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance (MonadBaseControl b m stM) => MonadBaseControl b (Strict.StateT s m) (Compose stM ((,) s)) where
  liftBaseWith = defaultLiftBaseWith
  restoreM     = defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance (MonadBaseControl b m stM) => MonadBaseControl b (StateT s m) (Compose stM ((,) s)) where
  liftBaseWith = defaultLiftBaseWith
  restoreM     = defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance (MonadBaseControl b m stM) => MonadBaseControl b (ExceptT e m) (Compose stM (Either e)) where
  liftBaseWith = defaultLiftBaseWith
  restoreM     = defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}



instance (MonadBaseControl b m stM, Error e) => MonadBaseControl b (ErrorT e m) (Compose stM (Either e)) where
  liftBaseWith = defaultLiftBaseWith
  restoreM     = defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance (MonadBaseControl b m stM, Monoid w) => MonadBaseControl b (Strict.WriterT w m) (Compose stM ((,) w)) where
  liftBaseWith = defaultLiftBaseWith
  restoreM     = defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}

instance (MonadBaseControl b m stM, Monoid w) => MonadBaseControl b (WriterT w m) (Compose stM ((,) w)) where
  liftBaseWith = defaultLiftBaseWith
  restoreM     = 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 = defaultLiftBaseWith
  restoreM     = 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 = defaultLiftBaseWith
  restoreM     = defaultRestoreM
  {-# INLINABLE liftBaseWith #-}
  {-# INLINABLE restoreM #-}


--------------------------------------------------------------------------------
-- * 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 f = liftBaseWith f >>= restoreM
{-# INLINABLE control #-}

-- | 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 f = liftBaseWith $ \runInBase -> return (runInBase . 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_ f = liftBaseWith $ \runInBase -> return (void . runInBase . f)
{-# INLINABLE embed_ #-}

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

-- | Capture the current state above the base monad
captureM :: MonadBaseControl b m stM => m (stM ())
captureM = liftBaseWith $ \runInBase -> runInBase (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 f = \g -> control $ \runInBase -> f $ runInBase . 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_ f = \m -> control $ \runInBase -> f $ runInBase 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 f = \m -> liftBaseWith $ \runInBase -> f $ void $ runInBase 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 f g = liftBaseWith $ \runInBase -> f $ void . runInBase . 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 f t = do
  st <- liftWith $ \run -> do
    f $ run t
  restoreT $ return st