-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Trans.Identity
-- Copyright   :  (c) 2009 Henning Thielemann
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Declaration of the 'IdentityT' monad transformer.
-----------------------------------------------------------------------------

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

import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>)), )
import Control.Monad (MonadPlus(mzero, mplus), ap)
import Control.Monad.Trans (MonadIO(liftIO), MonadTrans(lift))

newtype IdentityT m a = IdentityT { runIdentityT :: m a }

mapIdentityT :: (m a -> n b) -> IdentityT m a -> IdentityT n b
mapIdentityT f = IdentityT . f . runIdentityT

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

instance (Functor m, Monad m) => Applicative (IdentityT m) where
    pure = return
    (<*>) = ap
 
instance (Functor m, MonadPlus m) => Alternative (IdentityT m) where
    empty = mzero
    (<|>) = mplus

instance (Monad m) => Monad (IdentityT m) where
    fail   = IdentityT . fail
    return = lift . return
    x >>= f = IdentityT $
        runIdentityT . f =<< runIdentityT x

instance (MonadPlus m) => MonadPlus (IdentityT m) where
    mzero = IdentityT mzero
    mplus x y = IdentityT $
        mplus (runIdentityT x) (runIdentityT y)

instance MonadTrans IdentityT where
    lift = IdentityT

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

-- | 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 @listen@ operation to the new monad.
liftListen :: Monad m =>
    (m a -> m (a,w)) -> IdentityT m a -> IdentityT m (a,w)
liftListen listen = mapIdentityT $ \ m -> do
    (a, w) <- listen m
    return $! (a, w)

-- | Lift a @pass@ operation to the new monad.
liftPass :: Monad m => (m (a, w -> w) -> m a) ->
    IdentityT m (a, w -> w) -> IdentityT m a
liftPass pass = mapIdentityT $ \ m -> pass $ do
    (v, f) <- m
    return $! (v, f)