Identity.hs

module Foundation.Monad.Identity
    ( IdentityT
    ) where

import Foundation.Internal.Base hiding (throw)
import Foundation.Monad.MonadIO
import Foundation.Monad.Exception
import Foundation.Monad.Transformer

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

instance Functor m => Functor (IdentityT m) where
    fmap f (IdentityT m) = IdentityT (f `fmap` m)
    {-# INLINE fmap #-}

instance Applicative m => Applicative (IdentityT m) where
    pure x = IdentityT (pure x)
    {-# INLINE pure #-}
    fab <*> fa = IdentityT (runIdentityT fab <*> runIdentityT fa)
    {-# INLINE (<*>) #-}

instance Monad m => Monad (IdentityT m) where
    return x = IdentityT (return x)
    {-# INLINE return #-}
    ma >>= mb = IdentityT $ runIdentityT ma >>= runIdentityT . mb
    {-# INLINE (>>=) #-}

instance MonadTrans IdentityT where
    lift = IdentityT
    {-# INLINE lift #-}

instance MonadIO m => MonadIO (IdentityT m) where
    liftIO f = lift (liftIO f)
    {-# INLINE liftIO #-}

instance MonadFailure m => MonadFailure (IdentityT m) where
    type Failure (IdentityT m) = Failure m
    mFail = IdentityT . mFail

instance MonadThrow m => MonadThrow (IdentityT m) where
    throw e = IdentityT (throw e)

instance MonadCatch m => MonadCatch (IdentityT m) where
    catch (IdentityT m) c = IdentityT $ m `catch` (runIdentityT . c)