1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86

module Control.Monad.Trans.Except where

import Data.Functor.Identity
import Control.Monad.Trans.Class
import Control.Monad.IO.Class

newtype ExceptT e m a = ExceptT {
    runExceptT :: m (Either e a)
  }

instance Monad m => Functor (ExceptT e m) where
  fmap f = ExceptT . fmap (either Left (Right . f)) . runExceptT

instance 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 (Monad m, Monoid e) => Alternative (ExceptT e m) where
  empty = ExceptT $ return (Left mempty)
  ExceptT mx <|> ExceptT my = ExceptT $ do
      ex <- mx
      case ex of
          Left e -> fmap (either (Left . mappend e) Right) my
          Right x -> return (Right x)

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)

instance MonadFail m => MonadFail (ExceptT e m) where
  fail = ExceptT . fail

instance MonadTrans (ExceptT e) where
  lift m = ExceptT (fmap Right m)

instance MonadIO m => MonadIO (ExceptT e m) where
  liftIO = lift . liftIO

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 :: (Monad m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT f = mapExceptT $ fmap $ either (Left . f) Right

type Except e = ExceptT e Identity

except :: (Monad m) => Either e a -> ExceptT e m a
except = ExceptT . return

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)

-- | Transform any exceptions thrown by the computation using the given
-- function (a specialization of 'withExceptT').
withExcept :: (e -> e') -> Except e a -> Except e' a
withExcept = withExceptT

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)