#if __GLASGOW_HASKELL__ >= 709
#endif
module Control.Monad.Trans.Except (
Except,
except,
runExcept,
mapExcept,
withExcept,
ExceptT(ExceptT),
runExceptT,
mapExceptT,
withExceptT,
throwE,
catchE,
liftCallCC,
liftListen,
liftPass,
) where
import Control.Monad.IO.Class
import Control.Monad.Signatures
import Control.Monad.Trans.Class
import Data.Functor.Classes
import Data.Functor.Identity
import Control.Applicative
import Control.Monad
import Control.Monad.Fix
import Data.Foldable (Foldable(foldMap))
import Data.Monoid
import Data.Traversable (Traversable(traverse))
type Except e = ExceptT e Identity
except :: Either e a -> Except e a
except m = ExceptT (Identity m)
runExcept :: Except e a -> Either e a
runExcept (ExceptT m) = runIdentity m
mapExcept :: (Either e a -> Either e' b)
-> Except e a
-> Except e' b
mapExcept f = mapExceptT (Identity . f . runIdentity)
withExcept :: (e -> e') -> Except e a -> Except e' a
withExcept = withExceptT
newtype ExceptT e m a = ExceptT (m (Either e a))
instance (Eq e, Eq1 m, Eq a) => Eq (ExceptT e m a) where
ExceptT x == ExceptT y = eq1 x y
instance (Ord e, Ord1 m, Ord a) => Ord (ExceptT e m a) where
compare (ExceptT x) (ExceptT y) = compare1 x y
instance (Read e, Read1 m, Read a) => Read (ExceptT e m a) where
readsPrec = readsData $ readsUnary1 "ExceptT" ExceptT
instance (Show e, Show1 m, Show a) => Show (ExceptT e m a) where
showsPrec d (ExceptT m) = showsUnary1 "ExceptT" d m
instance (Eq e, Eq1 m) => Eq1 (ExceptT e m) where eq1 = (==)
instance (Ord e, Ord1 m) => Ord1 (ExceptT e m) where compare1 = compare
instance (Read e, Read1 m) => Read1 (ExceptT e m) where readsPrec1 = readsPrec
instance (Show e, Show1 m) => Show1 (ExceptT e m) where showsPrec1 = showsPrec
runExceptT :: ExceptT e m a -> m (Either e a)
runExceptT (ExceptT m) = m
mapExceptT :: (m (Either e a) -> n (Either e' b))
-> ExceptT e m a
-> ExceptT e' n b
mapExceptT f m = ExceptT $ f (runExceptT m)
withExceptT :: (Functor m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT f = mapExceptT $ fmap $ either (Left . f) Right
instance (Functor m) => Functor (ExceptT e m) where
fmap f = ExceptT . fmap (fmap f) . runExceptT
instance (Foldable f) => Foldable (ExceptT e f) where
foldMap f (ExceptT a) = foldMap (either (const mempty) f) a
instance (Traversable f) => Traversable (ExceptT e f) where
traverse f (ExceptT a) =
ExceptT <$> traverse (either (pure . Left) (fmap Right . f)) a
instance (Functor m, Monad m) => Applicative (ExceptT e m) where
pure a = ExceptT $ return (Right a)
ExceptT f <*> ExceptT v = ExceptT $ do
mf <- f
case mf of
Left e -> return (Left e)
Right k -> do
mv <- v
case mv of
Left e -> return (Left e)
Right x -> return (Right (k x))
instance (Functor m, Monad m, Monoid e) => Alternative (ExceptT e m) where
empty = mzero
(<|>) = mplus
instance (Monad m) => Monad (ExceptT e m) where
return a = ExceptT $ return (Right a)
m >>= k = ExceptT $ do
a <- runExceptT m
case a of
Left e -> return (Left e)
Right x -> runExceptT (k x)
fail = ExceptT . fail
instance (Monad m, Monoid e) => MonadPlus (ExceptT e m) where
mzero = ExceptT $ return (Left mempty)
ExceptT m `mplus` ExceptT n = ExceptT $ do
a <- m
case a of
Left e -> liftM (either (Left . mappend e) Right) n
Right x -> return (Right x)
instance (MonadFix m) => MonadFix (ExceptT e m) where
mfix f = ExceptT (mfix (runExceptT . f . either (const bomb) id))
where bomb = error "mfix (ExceptT): inner computation returned Left value"
instance MonadTrans (ExceptT e) where
lift = ExceptT . liftM Right
instance (MonadIO m) => MonadIO (ExceptT e m) where
liftIO = lift . liftIO
throwE :: (Monad m) => e -> ExceptT e m a
throwE = ExceptT . return . Left
catchE :: (Monad m) =>
ExceptT e m a
-> (e -> ExceptT e' m a)
-> ExceptT e' m a
m `catchE` h = ExceptT $ do
a <- runExceptT m
case a of
Left l -> runExceptT (h l)
Right r -> return (Right r)
liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ExceptT e m) a b
liftCallCC callCC f = ExceptT $
callCC $ \ c ->
runExceptT (f (\ a -> ExceptT $ c (Right a)))
liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ExceptT e m) a
liftListen listen = mapExceptT $ \ m -> do
(a, w) <- listen m
return $! fmap (\ r -> (r, w)) a
liftPass :: (Monad m) => Pass w m (Either e a) -> Pass w (ExceptT e m) a
liftPass pass = mapExceptT $ \ m -> pass $ do
a <- m
return $! case a of
Left l -> (Left l, id)
Right (r, f) -> (Right r, f)