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
|
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Foundation.Monad.Except
( ExceptT(..)
) where
import Basement.Imports
import Foundation.Monad.Base
import Foundation.Monad.Reader
#if MIN_VERSION_base(4,13,0)
import Control.Monad.Fail
#endif
newtype ExceptT e m a = ExceptT { runExceptT :: m (Either e a) }
instance Functor m => Functor (ExceptT e m) where
fmap f = ExceptT . fmap (fmap f) . runExceptT
instance Monad m => Applicative (ExceptT e m) where
pure a = ExceptT $ pure (Right a)
ExceptT f <*> ExceptT v = ExceptT $ do
mf <- f
case mf of
Left e -> pure (Left e)
Right k -> do
mv <- v
case mv of
Left e -> pure (Left e)
Right x -> pure (Right (k x))
instance Monad m => MonadFailure (ExceptT e m) where
type Failure (ExceptT e m) = e
mFail = ExceptT . pure . Left
instance Monad m => Monad (ExceptT e m) where
return = pure
m >>= k = ExceptT $ do
a <- runExceptT m
case a of
Left e -> return (Left e)
Right x -> runExceptT (k x)
#if !MIN_VERSION_base(4,13,0)
fail = ExceptT . fail
#else
instance MonadFail m => MonadFail (ExceptT e m) where
fail = ExceptT . fail
#endif
instance (Monad m, MonadFix m) => MonadFix (ExceptT e m) where
mfix f = ExceptT (mfix (runExceptT . f . fromEither))
where
fromEither (Right x) = x
fromEither (Left _) = error "mfix (ExceptT): inner computation returned Left value"
{-# INLINE mfix #-}
instance MonadReader m => MonadReader (ExceptT e m) where
type ReaderContext (ExceptT e m) = ReaderContext m
ask = ExceptT (Right <$> ask)
instance MonadTrans (ExceptT e) where
lift f = ExceptT (Right <$> f)
instance MonadIO m => MonadIO (ExceptT e m) where
liftIO f = ExceptT (Right <$> liftIO f)
|
