@@ -0,0 +1,123 @@
1+{-# LANGUAGE MultiParamTypeClasses #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE UndecidableInstances #-}
6+{-# LANGUAGE DataKinds #-}
7+{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9+module Control.Monad.Trans.Ether.Except
10+ (
11+ -- * The Except monad
12+ Except
13+ , runExcept
14+ -- * The ExceptT monad transformer
15+ , ExceptT
16+ , exceptT
17+ , runExceptT
18+ , mapExceptT
19+ -- * Lifting other operations
20+ , liftCallCC
21+ , liftListen
22+ , liftPass
23+ ) where
24+
25+import Data.Proxy (Proxy(Proxy))
26+import Data.Functor.Identity (Identity(..))
27+import Data.Coerce (coerce)
28+import Control.Applicative (Alternative)
29+import Control.Monad (MonadPlus)
30+import Control.Monad.Fix (MonadFix)
31+import Control.Monad.Trans.Class (MonadTrans, lift)
32+import Control.Monad.IO.Class (MonadIO)
33+import Control.Ether.Tags (Tags)
34+
35+import qualified Control.Monad.Signatures as Sig
36+import qualified Control.Monad.Trans.Except as Trans
37+
38+import qualified Control.Monad.Cont.Class as Class
39+import qualified Control.Monad.Reader.Class as Class
40+import qualified Control.Monad.State.Class as Class
41+import qualified Control.Monad.Writer.Class as Class
42+import qualified Control.Monad.Error.Class as Class
43+
44+
45+-- | The parameterizable exception monad.
46+--
47+-- Computations are either exceptions or normal values.
48+--
49+-- The 'return' function returns a normal value, while '>>=' exits on
50+-- the first exception.
51+type Except tag e = ExceptT tag e Identity
52+
53+-- | Runs an 'Except' and returns either an exception or a normal value.
54+runExcept :: proxy tag -> Except tag e a -> Either e a
55+runExcept proxy m = runIdentity (runExceptT proxy m)
56+
57+-- | The exception monad transformer.
58+--
59+-- The 'return' function returns a normal value, while '>>=' exits on
60+-- the first exception.
61+
62+newtype ExceptT tag e m a = ExceptT (Trans.ExceptT e m a)
63+ deriving ( Functor, Applicative, Alternative, Monad, MonadPlus
64+ , MonadFix, MonadTrans, MonadIO )
65+
66+type instance Tags (ExceptT tag r m) = tag ': Tags m
67+
68+-- | Constructor for computations in the exception monad transformer.
69+exceptT :: proxy tag -> m (Either e a) -> ExceptT tag e m a
70+exceptT _proxy = ExceptT . Trans.ExceptT
71+
72+-- | Runs an 'ExceptT' and returns either an exception or a normal value.
73+runExceptT :: proxy tag -> ExceptT tag e m a -> m (Either e a)
74+runExceptT _proxy (ExceptT (Trans.ExceptT f)) = f
75+
76+-- | Transform the computation inside an 'ExceptT'.
77+--
78+-- * @'runExceptT' tag ('mapExceptT' tag f m) = f ('runExceptT' tag m)@
79+mapExceptT
80+ :: proxy tag
81+ -> (m (Either e a) -> n (Either e' b))
82+ -> ExceptT tag e m a
83+ -> ExceptT tag e' n b
84+mapExceptT _proxy f m = ExceptT $ Trans.mapExceptT f (coerce m)
85+
86+-- | Lift a @callCC@ operation to the new monad.
87+liftCallCC :: proxy tag -> Sig.CallCC m (Either e a) (Either e b) -> Sig.CallCC (ExceptT tag e m) a b
88+liftCallCC _proxy callCC f = ExceptT $ Trans.liftCallCC callCC (coerce f)
89+
90+-- | Lift a @listen@ operation to the new monad.
91+liftListen :: Monad m => proxy tag -> Sig.Listen w m (Either e a) -> Sig.Listen w (ExceptT tag e m) a
92+liftListen _proxy listen m = ExceptT $ Trans.liftListen listen (coerce m)
93+
94+-- | Lift a @pass@ operation to the new monad.
95+liftPass :: Monad m => proxy tag -> Sig.Pass w m (Either e a) -> Sig.Pass w (ExceptT tag e m) a
96+liftPass _proxy pass m = ExceptT $ Trans.liftPass pass (coerce m)
97+
98+-- | Lift a @catchE@ operation to the new monad.
99+liftCatch :: proxy tag -> Sig.Catch e m (Either e' a) -> Sig.Catch e (ExceptT tag e' m) a
100+liftCatch proxy catchE m h = exceptT proxy $ catchE (runExceptT proxy m) (runExceptT proxy . h)
101+
102+instance Class.MonadCont m => Class.MonadCont (ExceptT tag e m) where
103+ callCC = liftCallCC Proxy Class.callCC
104+
105+instance Class.MonadReader r m => Class.MonadReader r (ExceptT tag e m) where
106+ ask = lift Class.ask
107+ local = mapExceptT Proxy . Class.local
108+ reader = lift . Class.reader
109+
110+instance Class.MonadState s m => Class.MonadState s (ExceptT tag e m) where
111+ get = lift Class.get
112+ put = lift . Class.put
113+ state = lift . Class.state
114+
115+instance Class.MonadWriter w m => Class.MonadWriter w (ExceptT tag e m) where
116+ writer = lift . Class.writer
117+ tell = lift . Class.tell
118+ listen = liftListen Proxy Class.listen
119+ pass = liftPass Proxy Class.pass
120+
121+instance Class.MonadError e' m => Class.MonadError e' (ExceptT tag e m) where
122+ throwError = lift . Class.throwError
123+ catchError = liftCatch Proxy Class.catchError