Control/Monad/Trans/Identity.hs

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Control.Monad.Trans.Identity
    -- Copyright   :  (c) 2007 Magnus Therning
    -- License     :  BSD-style (see the file LICENSE)
    --
    -- Maintainer  :  ross@soi.city.ac.uk
    -- Stability   :  experimental
    -- Portability :  portable
    --
    -- The identity monad transformer.
    --
    -- This is useful for functions parameterized by a monad transformer.
    -----------------------------------------------------------------------------

    module Control.Monad.Trans.Identity (
        -- * The identity monad transformer
        IdentityT(..),
        mapIdentityT,
        -- * Lifting other operations
        liftCatch,
        liftCallCC,
      ) where

    import Control.Applicative
    import Control.Monad (MonadPlus(mzero, mplus))
    import Control.Monad.Fix (MonadFix(mfix))
    import Control.Monad.IO.Class (MonadIO(liftIO))
    import Control.Monad.Trans.Class (MonadTrans(lift))
    import Data.Foldable (Foldable(foldMap))
    import Data.Traversable (Traversable(traverse))

    -- | The trivial monad transformer, which maps a monad to an equivalent monad.
    newtype IdentityT m a = IdentityT { runIdentityT :: m a }

    instance (Functor m) => Functor (IdentityT m) where
        fmap f = mapIdentityT (fmap f)

    instance (Foldable f) => Foldable (IdentityT f) where
        foldMap f (IdentityT a) = foldMap f a

    instance (Traversable f) => Traversable (IdentityT f) where
        traverse f (IdentityT a) = IdentityT <$> traverse f a

    instance (Applicative m) => Applicative (IdentityT m) where
        pure x = IdentityT (pure x)
        (<*>) = lift2IdentityT (<*>)

    instance (Alternative m) => Alternative (IdentityT m) where
        empty = IdentityT empty
        (<|>) = lift2IdentityT (<|>)

    instance (Monad m) => Monad (IdentityT m) where
        return = IdentityT . return
        m >>= k = IdentityT $ runIdentityT . k =<< runIdentityT m
        fail msg = IdentityT $ fail msg

    instance (MonadPlus m) => MonadPlus (IdentityT m) where
        mzero = IdentityT mzero
        mplus = lift2IdentityT mplus

    instance (MonadFix m) => MonadFix (IdentityT m) where
        mfix f = IdentityT (mfix (runIdentityT . f))

    instance (MonadIO m) => MonadIO (IdentityT m) where
        liftIO = IdentityT . liftIO

    instance MonadTrans IdentityT where
        lift = IdentityT

    -- | Lift a unary operation to the new monad.
    mapIdentityT :: (m a -> n b) -> IdentityT m a -> IdentityT n b
    mapIdentityT f = IdentityT . f . runIdentityT

    -- | Lift a binary operation to the new monad.
    lift2IdentityT ::
        (m a -> n b -> p c) -> IdentityT m a -> IdentityT n b -> IdentityT p c
    lift2IdentityT f a b = IdentityT (f (runIdentityT a) (runIdentityT b))

    -- | Lift a @callCC@ operation to the new monad.
    liftCallCC :: (((a -> m b) -> m a) ->
        m a) -> ((a -> IdentityT m b) -> IdentityT m a) -> IdentityT m a
    liftCallCC callCC f =
        IdentityT $ callCC $ \ c -> runIdentityT (f (IdentityT . c))

    -- | Lift a @catchError@ operation to the new monad.
    liftCatch :: (m a -> (e -> m a) -> m a) ->
        IdentityT m a -> (e -> IdentityT m a) -> IdentityT m a
    liftCatch f m h = IdentityT $ f (runIdentityT m) (runIdentityT . h)