MonadThrow/MonadCatch

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
{-# LANGUAGE
    DataKinds
  , DefaultSignatures
  , FlexibleInstances
  , FunctionalDependencies
  , MultiParamTypeClasses
  , PolyKinds
  , UndecidableInstances #-}
{-# OPTIONS_GHC -Wall #-}
import Control.Monad.Error hiding (MonadError)
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State

class Monad m => MonadThrow e m | m -> e where
  throw :: e -> m a
  default throw :: (MonadThrow e m, MonadTrans t) => e -> t m a
  throw = lift . throw

class ( Monad (t m)
      , Monad (t' m')
      ) => MonadCatch e m m' t t' | t m -> e, t' m' e -> t m where
  catch :: t m a -> (e -> t' m' a) -> t' m' a

instance (Error e, Monad m) => MonadThrow e (ErrorT e m) where
  throw = throwError
instance ( Error e
         , Error e'
         , Monad m
         ) => MonadCatch e m m (ErrorT e) (ErrorT e') where
  m `catch` h = mapErrorT (>>= either (runErrorT . h) (return . Right)) m

instance MonadThrow e m => MonadThrow e (ReaderT r m)
instance ( Monad (t m)
         , Monad (t' m')
         , MonadCatch e m m' t t'
         ) => MonadCatch e (t m) (t' m') (ReaderT r) (ReaderT r) where
  m `catch` h = ReaderT $ \ r -> runReaderT m r `catch` \ e -> runReaderT (h e) r

instance MonadThrow e m => MonadThrow e (StateT s m)
instance ( Monad (t m)
         , Monad (t' m')
         , MonadCatch e m m' t t'
         ) => MonadCatch e (t m) (t' m') (StateT s) (StateT s) where
  m `catch` h = StateT $ \ s -> runStateT m s `catch` \ e -> runStateT (h e) s

instance MonadThrow e (Either e) where
  throw = Left

data Unused

newtype WrappedEither e (m :: Unused) a = WrapEither { unwrapEither :: Either e a }

instance Monad (WrappedEither e m) where
  return = WrapEither . return
  m >>= f = WrapEither $ unwrapEither m >>= unwrapEither . f

instance MonadThrow e (WrappedEither e m) where
  throw = WrapEither . throw
instance MonadCatch e m m (WrappedEither e) (WrappedEither e') where
  m `catch` h = either h (WrapEither . Right) $ unwrapEither m