Control/Monad/X/ErrorT.hs

   1 module Control.Monad.X.ErrorT (
   2         ErrorT,
   3         runError,
   4         runErrorT,
   5         mapErrorT,
   6         module T
   7   ) where
   8
   9 import Prelude(Functor(..),Monad(..),Either(..),either,(.),id,error)
  10
  11 import Control.Monad(MonadPlus(..),liftM)
  12
  13 import Control.Monad.X.Trans as T
  14 import Control.Monad.X.Utils
  15 import Control.Monad.X.Types(ErrorT(..))
  16
  17
  18 instance MonadTrans (ErrorT e) where
  19   lift m    = E (liftM Right m)
  20
  21 instance HasBaseMonad m n => HasBaseMonad (ErrorT e m) n where
  22   inBase    = inBase'
  23
  24 instance (Monad m) => Functor (ErrorT e m) where
  25   fmap      = liftM
  26
  27 instance (Monad m) => Monad (ErrorT e m) where
  28   return    = return'
  29   m >>= k   = E (do a <- unE m
  30                     case a of
  31                       Left  l -> return (Left l)
  32                       Right r -> unE (k r))
  33   fail      = fail'   -- use 'throwErorr' to throw errors.
  34
  35
  36 --------------------------------------------------------------------------------
  37
  38 runError    = unE
  39 runErrorT   = unE
  40
  41 mapErrorT :: (m (Either e a) -> n (Either e' b)) -> ErrorT e m a -> ErrorT e' n b
  42 mapErrorT f m = E (f (unE m))
  43
  44 --------------------------------------------------------------------------------
  45
  46 instance (MonadReader r m) => MonadReader r (ErrorT e m) where
  47   ask       = ask'
  48   local     = local' mapErrorT
  49
  50 instance (MonadWriter w m) => MonadWriter w (ErrorT e m) where
  51   tell      = tell'
  52   listen    = listen1' E unE (\w -> either Left (\r -> Right (r,w)))
  53
  54 instance (MonadState s m) => MonadState s (ErrorT e m) where
  55   get       = get'
  56   put       = put'
  57
  58 instance (Monad m) => MonadError e (ErrorT e m) where
  59   throwError       = E . return . Left
  60   m `catchError` h = E (do a <- unE m
  61                            case a of
  62                              Left  l -> unE (h l)
  63                              Right r -> return (Right r))
  64
  65 -- MonadPlus is used for Nondet, these should be moved in the nondet class
  66 instance MonadPlus m => MonadPlus (ErrorT e m) where
  67   mzero       = mzero'
  68   mplus       = mplus1' E unE
  69
  70 -- `findAll` is like catMaybes, it will aways succeed, but will only return
  71 -- results that didn't raise an exception.
  72 -- if all results a required, use handle to turn the failures into (tagged) successes.
  73 instance MonadNondet m => MonadNondet (ErrorT e m) where
  74   findAll     = mapErrorT (liftM res . findAll)
  75     where res xs = Right [ x | Right x <- xs ]
  76   commit      = mapErrorT commit
  77
  78 instance MonadResume m => MonadResume (ErrorT e m) where
  79   delay       = mapErrorT delay
  80   force       = mapErrorT force
  81
  82 instance (MonadCont m) => MonadCont (ErrorT e m) where
  83   callCC            = callCC1' E unE Right
  84
  85
  86