ExceptMT.hs

module ExceptMT (HasExcept(..), MT(..), WithExcept, removeExcept, mapExcept) 
  where

import MT
import Control_Monad_Fix 

import Monad(liftM,MonadPlus(..))

newtype WithExcept x m a   = E { removeExcept :: m (Either x a) } 
iso f = E . f . removeExcept


mapExcept :: Monad m => (x -> y) -> WithExcept x m a -> WithExcept y m a
mapExcept f = iso (liftM (either (Left . f) Right))


--------------------------------------------------------------------------------
instance Monad m => Functor (WithExcept x m) where
  fmap = liftM

instance Monad m => Monad (WithExcept x m) where
  return    = lift . return
  E m >>= f = E $ do x <- m
                     case x of 
                       Left x  -> return (Left x)
                       Right a -> removeExcept (f a)
            
instance MT (WithExcept x) where
  lift m    = E (m >>= return . Right)

instance MonadPlus m => MonadPlus (WithExcept x m) where
  mzero             = lift mzero   
  E m1 `mplus` E m2 = E (m1 `mplus` m2)
--------------------------------------------------------------------------------


--------------------------------------------------------------------------------
instance HasEnv m ix e => HasEnv (WithExcept x m) ix e where
  getEnv ix       = lift (getEnv ix)
  inModEnv ix f   = iso (inModEnv ix f)

instance HasState m ix s => HasState (WithExcept x m) ix s where
  updSt ix        = lift . updSt ix

instance HasOutput m ix o => HasOutput (WithExcept x m) ix o where
  outputTree ix   = lift . outputTree ix

instance Monad m => HasExcept (WithExcept x m) x where
  raise           = E . return . Left
  handle h (E m)  = E (m >>= either (removeExcept . h) (return . Right))

instance HasCont m => HasCont (WithExcept x m) where
  callcc f        = E $ callcc $ \k -> removeExcept $ f $ E . k . Right
  

instance HasBaseMonad m n => HasBaseMonad (WithExcept e m) n where
  inBase          = lift . inBase

instance HasRefs m r => HasRefs (WithExcept x m) r where
  newRef          = lift . newRef
  readRef         = lift . readRef
  writeRef r      = lift . writeRef r


instance MonadFix m => MonadFix (WithExcept x m) where
  mfix f          = E $ mfix (removeExcept . f . either undefined id)