{-# LANGUAGE CPP #-}
{- |
Module      :  Control.Monad.Trans.Peel
Copyright   :  © Anders Kaseorg, 2010
License     :  BSD-style

Maintainer  :  Anders Kaseorg <andersk@mit.edu>
Stability   :  experimental
Portability :  portable

This module defines the class 'MonadTransPeel' of monad transformers
through which control operations can be lifted.  Instances are
included for all the standard monad transformers from the
@transformers@ library except @ContT@.

'idPeel' and 'liftPeel' are provided to assist creation of
@MonadPeelIO@-like classes (see "Control.Monad.IO.Peel") based on core
monads other than 'IO'.

'liftOp' and 'liftOp_' enable convenient lifting of two common special
cases of control operation types.
-}

module Control.Monad.Trans.Peel (
  MonadTransPeel(..),
  idPeel,
  liftPeel,
  liftOp,
  liftOp_,
  ) where

import Prelude hiding (catch)
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Maybe
#if MIN_VERSION_transformers(0,4,0)
import qualified Control.Monad.Trans.Except as Except
#endif
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import qualified Control.Monad.Trans.State.Strict as Strict
import Control.Monad.Trans.Writer
import qualified Control.Monad.Trans.Writer.Strict as Strict
import qualified Control.Monad.Trans.RWS as RWS
import qualified Control.Monad.Trans.RWS.Strict as RWS.Strict
import Data.Monoid


-- |@MonadTransPeel@ is the class of monad transformers supporting an
-- extra operation 'peel', enabling control operations (functions that
-- use monadic actions as input instead of just output) to be lifted
-- through the transformer.
class MonadTrans t => MonadTransPeel t where
  -- |@peel@ is used to peel off the outer layer of a transformed
  -- monadic action, allowing an transformed action @t m a@ to be
  -- treated as a base action @m b@.
  --
  -- More precisely, @peel@ captures the monadic state of @t@ at the
  -- point where it is bound (in @t n@), yielding a function @t m a ->
  -- m (t o a)@; this function runs a transformed monadic action @t m
  -- a@ in the base monad @m@ using the captured state, and leaves the
  -- result @t o a@ in the monad @m@ after all side effects in @m@
  -- have occurred.
  --
  -- This can be used together with 'lift' to lift control operations
  -- with types such as @M a -> M a@ into the transformed monad @t M@:
  --
  -- @
  --    instance Monad M
  --    foo :: M a -> M a
  --    foo' :: ('MonadTransPeel' t, 'Monad' (t M)) => t M a -> t M a
  --    foo' a = do
  --      k \<- 'peel'  -- k :: t M a -> M (t M a)
  --      'join' $ 'lift' $ foo (k a)  -- uses foo :: M (t M a) -> M (t M a)
  -- @
  --
  -- @peel@ is typically used with @m == n == o@, but is required to
  -- be polymorphic for greater type safety: for example, this type
  -- ensures that the result of running the action in @m@ has no
  -- remaining side effects in @m@.
  peel :: (Monad m, Monad n, Monad o) => t n (t m a -> m (t o a))

instance MonadTransPeel IdentityT where
  peel :: forall (m :: * -> *) (n :: * -> *) (o :: * -> *) a.
(Monad m, Monad n, Monad o) =>
IdentityT n (IdentityT m a -> m (IdentityT o a))
peel = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \IdentityT m a
m -> do
    a
x <- forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT IdentityT m a
m
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return a
x

instance MonadTransPeel MaybeT where
  peel :: forall (m :: * -> *) (n :: * -> *) (o :: * -> *) a.
(Monad m, Monad n, Monad o) =>
MaybeT n (MaybeT m a -> m (MaybeT o a))
peel = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \MaybeT m a
m -> do
    Maybe a
xm <- forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MaybeT m a
m
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. MonadPlus m => m a
mzero forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
xm

#if MIN_VERSION_transformers(0,4,0)
instance MonadTransPeel (Except.ExceptT e) where
  peel :: forall (m :: * -> *) (n :: * -> *) (o :: * -> *) a.
(Monad m, Monad n, Monad o) =>
ExceptT e n (ExceptT e m a -> m (ExceptT e o a))
peel = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \ExceptT e m a
m -> do
    Either e a
xe <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT ExceptT e m a
m
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
Except.throwE forall (m :: * -> *) a. Monad m => a -> m a
return Either e a
xe
#endif

instance MonadTransPeel (ReaderT r) where
  peel :: forall (m :: * -> *) (n :: * -> *) (o :: * -> *) a.
(Monad m, Monad n, Monad o) =>
ReaderT r n (ReaderT r m a -> m (ReaderT r o a))
peel = forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks forall a b. (a -> b) -> a -> b
$ \r
r ReaderT r m a
m -> do
    a
x <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r m a
m r
r
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return a
x

instance MonadTransPeel (StateT s) where
  peel :: forall (m :: * -> *) (n :: * -> *) (o :: * -> *) a.
(Monad m, Monad n, Monad o) =>
StateT s n (StateT s m a -> m (StateT s o a))
peel = forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets forall a b. (a -> b) -> a -> b
$ \s
s StateT s m a
m -> do
    (a
x, s
s') <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT s m a
m s
s
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put s
s'
      forall (m :: * -> *) a. Monad m => a -> m a
return a
x
instance MonadTransPeel (Strict.StateT s) where
  peel :: forall (m :: * -> *) (n :: * -> *) (o :: * -> *) a.
(Monad m, Monad n, Monad o) =>
StateT s n (StateT s m a -> m (StateT s o a))
peel = forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
Strict.gets forall a b. (a -> b) -> a -> b
$ \s
s StateT s m a
m -> do
    (a
x, s
s') <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Strict.runStateT StateT s m a
m s
s
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *) s. Monad m => s -> StateT s m ()
Strict.put s
s'
      forall (m :: * -> *) a. Monad m => a -> m a
return a
x

instance Monoid w => MonadTransPeel (WriterT w) where
  peel :: forall (m :: * -> *) (n :: * -> *) (o :: * -> *) a.
(Monad m, Monad n, Monad o) =>
WriterT w n (WriterT w m a -> m (WriterT w o a))
peel = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \WriterT w m a
m -> do
    (a
x, w
w) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT w m a
m
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell w
w
      forall (m :: * -> *) a. Monad m => a -> m a
return a
x
instance Monoid w => MonadTransPeel (Strict.WriterT w) where
  peel :: forall (m :: * -> *) (n :: * -> *) (o :: * -> *) a.
(Monad m, Monad n, Monad o) =>
WriterT w n (WriterT w m a -> m (WriterT w o a))
peel = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \WriterT w m a
m -> do
    (a
x, w
w) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Strict.runWriterT WriterT w m a
m
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Strict.tell w
w
      forall (m :: * -> *) a. Monad m => a -> m a
return a
x

instance Monoid w => MonadTransPeel (RWS.RWST r w s) where
  peel :: forall (m :: * -> *) (n :: * -> *) (o :: * -> *) a.
(Monad m, Monad n, Monad o) =>
RWST r w s n (RWST r w s m a -> m (RWST r w s o a))
peel = do
    r
r <- forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
RWS.ask
    s
s <- forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
RWS.get
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \RWST r w s m a
m -> do
      (a
x, s
s', w
w) <- forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
RWS.runRWST RWST r w s m a
m r
r s
s
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
        forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
RWS.put s
s'
        forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
RWS.tell w
w
        forall (m :: * -> *) a. Monad m => a -> m a
return a
x
instance Monoid w => MonadTransPeel (RWS.Strict.RWST r w s) where
  peel :: forall (m :: * -> *) (n :: * -> *) (o :: * -> *) a.
(Monad m, Monad n, Monad o) =>
RWST r w s n (RWST r w s m a -> m (RWST r w s o a))
peel = do
    r
r <- forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
RWS.Strict.ask
    s
s <- forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
RWS.Strict.get
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \RWST r w s m a
m -> do
      (a
x, s
s', w
w) <- forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
RWS.Strict.runRWST RWST r w s m a
m r
r s
s
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
        forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
RWS.Strict.put s
s'
        forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
RWS.Strict.tell w
w
        forall (m :: * -> *) a. Monad m => a -> m a
return a
x


-- |@idPeel@ acts as the \"identity\" 'peel' operation from a monad
-- @m@ to itself.
--
-- @
--    'idPeel' = 'return' $ 'liftM' 'return'
-- @
--
-- It serves as the base case for a class like @MonadPeelIO@, which
-- allows control operations in some base monad (here @IO@) to be
-- lifted through arbitrary stacks of zero or more monad transformers
-- in one call.  For example, "Control.Monad.IO.Peel" defines
--
-- @
--    class 'MonadIO' m => MonadPeelIO m where
--      peelIO :: m (m a -> 'IO' (m a))
--    instance MonadPeelIO 'IO' where
--      peelIO = 'idPeel'
-- @
idPeel :: (Monad m, Monad n, Monad o) => n (m a -> m (o a))
idPeel :: forall (m :: * -> *) (n :: * -> *) (o :: * -> *) a.
(Monad m, Monad n, Monad o) =>
n (m a -> m (o a))
idPeel = forall (m :: * -> *) a. Monad m => a -> m a
return 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

-- |@liftPeel@ is used to compose two 'peel' operations: the outer
-- provided by a 'MonadTransPeel' instance, and the inner provided as
-- the argument.
--
-- It satisfies @'liftPeel' 'idPeel' == 'peel'@.
--
-- It serves as the induction step of a @MonadPeelIO@-like class.  For
-- example, "Control.Monad.IO.Peel" defines
--
-- @
--    instance MonadPeelIO m => MonadPeelIO ('StateT' s m) where
--      peelIO = 'liftPeel' peelIO
-- @
--
-- using the 'MonadTransPeel' instance of @'StateT' s@.
liftPeel :: (MonadTransPeel t, Monad m, Monad m', Monad n', Monad (t n'),
             Monad o', Monad (t o')) =>
            n' (m' (t o' a) -> m (o' (t o' a))) -> t n' (t m' a -> m (t o' a))
liftPeel :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) (m' :: * -> *)
       (n' :: * -> *) (o' :: * -> *) a.
(MonadTransPeel t, Monad m, Monad m', Monad n', Monad (t n'),
 Monad o', Monad (t o')) =>
n' (m' (t o' a) -> m (o' (t o' a))) -> t n' (t m' a -> m (t o' a))
liftPeel n' (m' (t o' a) -> m (o' (t o' a)))
p = do
  t m' a -> m' (t o' a)
k <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) (n :: * -> *)
       (o :: * -> *) a.
(MonadTransPeel t, Monad m, Monad n, Monad o) =>
t n (t m a -> m (t o a))
peel
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
    m' (t o' a) -> m (o' (t o' a))
k' <- n' (m' (t o' a) -> m (o' (t o' a)))
p
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \t m' a
m -> do
      o' (t o' a)
m' <- m' (t o' a) -> m (o' (t o' a))
k' forall a b. (a -> b) -> a -> b
$ t m' a -> m' (t o' a)
k t m' a
m
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift o' (t o' a)
m'

-- |@liftOp@ is a particular application of 'peel' that allows lifting
-- control operations of type @(a -> m b) -> m b@ to @'MonadTransPeel'
-- t => (a -> t m b) -> t m b@.
--
-- @
--    'liftOp' f g = do
--      k \<- 'peel'
--      'join' $ 'lift' $ f (k . g)
-- @
liftOp :: (MonadTransPeel t, Monad m, Monad n, Monad o, Monad (t n)) =>
          ((a -> m (t o b)) -> n (t n c)) -> (a -> t m b) -> t n c
liftOp :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) (n :: * -> *)
       (o :: * -> *) a b c.
(MonadTransPeel t, Monad m, Monad n, Monad o, Monad (t n)) =>
((a -> m (t o b)) -> n (t n c)) -> (a -> t m b) -> t n c
liftOp (a -> m (t o b)) -> n (t n c)
f a -> t m b
g = do
  t m b -> m (t o b)
k <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) (n :: * -> *)
       (o :: * -> *) a.
(MonadTransPeel t, Monad m, Monad n, Monad o) =>
t n (t m a -> m (t o a))
peel
  forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (a -> m (t o b)) -> n (t n c)
f (t m b -> m (t o b)
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> t m b
g)

-- |@liftOp_@ is a particular application of 'peel' that allows
-- lifting control operations of type @m a -> m a@ to
-- @'MonadTransPeel' m => t m a -> t m a@.
--
-- It can be thought of as a generalization of @mapReaderT@,
-- @mapStateT@, etc.
--
-- @
--    'liftOp_' f m = do
--      k \<- 'peel'
--      'join' $ 'lift' $ f (k m)
-- @
liftOp_ :: (MonadTransPeel t, Monad m, Monad n, Monad o, Monad (t n)) =>
           (m (t o a) -> n (t n b)) -> t m a -> t n b
liftOp_ :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) (n :: * -> *)
       (o :: * -> *) a b.
(MonadTransPeel t, Monad m, Monad n, Monad o, Monad (t n)) =>
(m (t o a) -> n (t n b)) -> t m a -> t n b
liftOp_ m (t o a) -> n (t n b)
f t m a
m = do
  t m a -> m (t o a)
k <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) (n :: * -> *)
       (o :: * -> *) a.
(MonadTransPeel t, Monad m, Monad n, Monad o) =>
t n (t m a -> m (t o a))
peel
  forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ m (t o a) -> n (t n b)
f (t m a -> m (t o a)
k t m a
m)