1{-# LANGUAGE CPP #-}
2
3#ifndef MIN_VERSION_base
4#define MIN_VERSION_base(x,y,z) 1
5#endif
6
7#ifndef MIN_VERSION_mtl
8#define MIN_VERSION_mtl(x,y,z) 1
9#endif
10
11#ifndef HASKELL98
12{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE TypeOperators #-}
14# ifdef MTL
15{-# LANGUAGE FlexibleInstances #-}
16{-# LANGUAGE MultiParamTypeClasses #-}
17{-# LANGUAGE UndecidableInstances #-}
18#  if __GLASGOW_HASKELL__ >= 704
19{-# LANGUAGE Safe #-}
20#  elif __GLASGOW_HASKELL__ >= 702
21{-# LANGUAGE Trustworthy #-}
22#  endif
23# endif
24#endif
25-----------------------------------------------------------------------------
26-- |
27-- Module      :  Control.Monad.Trans.Except
28-- Copyright   :  (C) 2013 Ross Paterson
29--                (C) 2015 Edward Kmett
30-- License     :  BSD-style (see the file LICENSE)
31--
32-- Maintainer  :  ross@soi.city.ac.uk
33-- Stability   :  experimental
34-- Portability :  portable
35--
36-- This monad transformer extends a monad with the ability throw exceptions.
37--
38-- A sequence of actions terminates normally, producing a value,
39-- only if none of the actions in the sequence throws an exception.
40-- If one throws an exception, the rest of the sequence is skipped and
41-- the composite action exits with that exception.
42--
43-- If the value of the exception is not required, the variant in
44-- "Control.Monad.Trans.Maybe" may be used instead.
45-----------------------------------------------------------------------------
46
47module Control.Monad.Trans.Except (
48    -- * The Except monad
49    Except,
50    except,
51    runExcept,
52    mapExcept,
53    withExcept,
54    -- * The ExceptT monad transformer
55    ExceptT(..),
56    mapExceptT,
57    withExceptT,
58    -- * Exception operations
59    throwE,
60    catchE,
61    handleE,
62    tryE,
63    finallyE,
64    -- * Lifting other operations
65    liftCallCC,
66    liftListen,
67    liftPass,
68  ) where
69
70import Control.Applicative
71import Control.Monad
72import qualified Control.Monad.Fail as Fail
73import Control.Monad.Fix
74import Control.Monad.IO.Class
75import Control.Monad.Signatures
76import Control.Monad.Trans.Class
77#if MIN_VERSION_base(4,4,0)
78import Control.Monad.Zip (MonadZip(mzipWith))
79#endif
80
81#ifdef MTL
82import Control.Monad.Writer.Class
83import Control.Monad.State.Class
84import Control.Monad.Reader.Class
85import Control.Monad.Cont.Class
86import Control.Monad.Error.Class
87import Control.Monad.RWS.Class
88#endif
89
90import Data.Foldable (Foldable(foldMap))
91import Data.Functor.Classes
92import Data.Functor.Identity
93import Data.Monoid
94import Data.Traversable (Traversable(traverse))
95
96#ifndef HASKELL98
97# ifdef GENERIC_DERIVING
98import Generics.Deriving.Base
99# elif __GLASGOW_HASKELL__ >= 702
100import GHC.Generics
101# endif
102#endif
103
104-- | The parameterizable exception monad.
105--
106-- Computations are either exceptions or normal values.
107--
108-- The 'return' function returns a normal value, while @>>=@ exits
109-- on the first exception.
110type Except e = ExceptT e Identity
111
112-- | Constructor for computations in the exception monad.
113-- (The inverse of 'runExcept').
114except :: (Monad m) => Either e a -> ExceptT e m a
115except m = ExceptT (return m)
116{-# INLINE except #-}
117
118-- | Extractor for computations in the exception monad.
119-- (The inverse of 'except').
120runExcept :: Except e a -> Either e a
121runExcept (ExceptT m) = runIdentity m
122{-# INLINE runExcept #-}
123
124-- | Map the unwrapped computation using the given function.
125--
126-- * @'runExcept' ('mapExcept' f m) = f ('runExcept' m)@
127mapExcept :: (Either e a -> Either e' b)
128        -> Except e a
129        -> Except e' b
130mapExcept f = mapExceptT (Identity . f . runIdentity)
131{-# INLINE mapExcept #-}
132
133-- | Transform any exceptions thrown by the computation using the given
134-- function (a specialization of 'withExceptT').
135withExcept :: (e -> e') -> Except e a -> Except e' a
136withExcept = withExceptT
137{-# INLINE withExcept #-}
138
139-- | A monad transformer that adds exceptions to other monads.
140--
141-- @ExceptT@ constructs a monad parameterized over two things:
142--
143-- * e - The exception type.
144--
145-- * m - The inner monad.
146--
147-- The 'return' function yields a computation that produces the given
148-- value, while @>>=@ sequences two subcomputations, exiting on the
149-- first exception.
150newtype ExceptT e m a = ExceptT { runExceptT :: m (Either e a) }
151
152#ifndef HASKELL98
153# if __GLASGOW_HASKELL__ >= 702 || defined(GENERIC_DERIVING)
154-- Generic(1) instances for ExceptT
155instance Generic (ExceptT e m a) where
156  type Rep (ExceptT e m a) = D1 D1'ExceptT (C1 C1_0'ExceptT (S1 NoSelector (Rec0 (m (Either e a)))))
157  from (ExceptT x) = M1 (M1 (M1 (K1 x)))
158  to (M1 (M1 (M1 (K1 x)))) = ExceptT x
159
160instance Functor m => Generic1 (ExceptT e m) where
161  type Rep1 (ExceptT e m) = D1 D1'ExceptT (C1 C1_0'ExceptT (S1 NoSelector (m :.: Rec1 (Either e))))
162  from1 (ExceptT x) = M1 (M1 (M1 ((.) Comp1 (fmap Rec1) x)))
163  to1 (M1 (M1 (M1 x))) = ExceptT ((.) (fmap unRec1) unComp1 x)
164
165instance Datatype D1'ExceptT where
166  datatypeName _ = "ExceptT"
167  moduleName _ = "Control.Monad.Trans.Except"
168#  if MIN_VERSION_base(4,7,0)
169  isNewtype _ = True
170#  endif
171
172instance Constructor C1_0'ExceptT where
173  conName _ = "ExceptT"
174
175data D1'ExceptT
176data C1_0'ExceptT
177# endif
178#endif
179
180instance (Eq e, Eq1 m) => Eq1 (ExceptT e m) where
181    liftEq eq (ExceptT x) (ExceptT y) = liftEq (liftEq eq) x y
182    {-# INLINE liftEq #-}
183
184instance (Ord e, Ord1 m) => Ord1 (ExceptT e m) where
185    liftCompare comp (ExceptT x) (ExceptT y) =
186        liftCompare (liftCompare comp) x y
187    {-# INLINE liftCompare #-}
188
189instance (Read e, Read1 m) => Read1 (ExceptT e m) where
190    liftReadsPrec rp rl = readsData $
191        readsUnaryWith (liftReadsPrec rp' rl') "ExceptT" ExceptT
192      where
193        rp' = liftReadsPrec rp rl
194        rl' = liftReadList rp rl
195
196instance (Show e, Show1 m) => Show1 (ExceptT e m) where
197    liftShowsPrec sp sl d (ExceptT m) =
198        showsUnaryWith (liftShowsPrec sp' sl') "ExceptT" d m
199      where
200        sp' = liftShowsPrec sp sl
201        sl' = liftShowList sp sl
202
203instance (Eq e, Eq1 m, Eq a) => Eq (ExceptT e m a) where (==) = eq1
204instance (Ord e, Ord1 m, Ord a) => Ord (ExceptT e m a) where compare = compare1
205instance (Read e, Read1 m, Read a) => Read (ExceptT e m a) where
206    readsPrec = readsPrec1
207instance (Show e, Show1 m, Show a) => Show (ExceptT e m a) where
208    showsPrec = showsPrec1
209
210-- | Map the unwrapped computation using the given function.
211--
212-- * @'runExceptT' ('mapExceptT' f m) = f ('runExceptT' m)@
213mapExceptT :: (m (Either e a) -> n (Either e' b))
214        -> ExceptT e m a
215        -> ExceptT e' n b
216mapExceptT f m = ExceptT $ f (runExceptT m)
217{-# INLINE mapExceptT #-}
218
219-- | Transform any exceptions thrown by the computation using the
220-- given function.
221withExceptT :: (Functor m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a
222withExceptT f = mapExceptT $ fmap $ either (Left . f) Right
223{-# INLINE withExceptT #-}
224
225instance (Functor m) => Functor (ExceptT e m) where
226    fmap f = ExceptT . fmap (fmap f) . runExceptT
227    {-# INLINE fmap #-}
228
229instance (Foldable f) => Foldable (ExceptT e f) where
230    foldMap f (ExceptT a) = foldMap (either (const mempty) f) a
231    {-# INLINE foldMap #-}
232
233instance (Traversable f) => Traversable (ExceptT e f) where
234    traverse f (ExceptT a) =
235        ExceptT <$> traverse (either (pure . Left) (fmap Right . f)) a
236    {-# INLINE traverse #-}
237
238instance (Functor m, Monad m) => Applicative (ExceptT e m) where
239    pure a = ExceptT $ return (Right a)
240    {-# INLINE pure #-}
241    ExceptT f <*> ExceptT v = ExceptT $ do
242        mf <- f
243        case mf of
244            Left e -> return (Left e)
245            Right k -> do
246                mv <- v
247                case mv of
248                    Left e -> return (Left e)
249                    Right x -> return (Right (k x))
250    {-# INLINEABLE (<*>) #-}
251    m *> k = m >>= \_ -> k
252    {-# INLINE (*>) #-}
253
254instance (Functor m, Monad m, Monoid e) => Alternative (ExceptT e m) where
255    empty = ExceptT $ return (Left mempty)
256    {-# INLINE empty #-}
257    ExceptT mx <|> ExceptT my = ExceptT $ do
258        ex <- mx
259        case ex of
260            Left e -> liftM (either (Left . mappend e) Right) my
261            Right x -> return (Right x)
262    {-# INLINEABLE (<|>) #-}
263
264instance (Monad m) => Monad (ExceptT e m) where
265    return a = ExceptT $ return (Right a)
266    {-# INLINE return #-}
267    m >>= k = ExceptT $ do
268        a <- runExceptT m
269        case a of
270            Left e -> return (Left e)
271            Right x -> runExceptT (k x)
272    {-# INLINE (>>=) #-}
273#if !(MIN_VERSION_base(4,13,0))
274    fail = ExceptT . fail
275    {-# INLINE fail #-}
276#endif
277
278instance (Fail.MonadFail m) => Fail.MonadFail (ExceptT e m) where
279    fail = ExceptT . Fail.fail
280    {-# INLINE fail #-}
281
282instance (Monad m, Monoid e) => MonadPlus (ExceptT e m) where
283    mzero = ExceptT $ return (Left mempty)
284    {-# INLINE mzero #-}
285    ExceptT m `mplus` ExceptT n = ExceptT $ do
286        a <- m
287        case a of
288            Left e -> liftM (either (Left . mappend e) Right) n
289            Right x -> return (Right x)
290    {-# INLINEABLE mplus #-}
291
292instance (MonadFix m) => MonadFix (ExceptT e m) where
293    mfix f = ExceptT (mfix (runExceptT . f . either (const bomb) id))
294      where bomb = error "mfix (ExceptT): inner computation returned Left value"
295    {-# INLINE mfix #-}
296
297instance MonadTrans (ExceptT e) where
298    lift = ExceptT . liftM Right
299    {-# INLINE lift #-}
300
301instance (MonadIO m) => MonadIO (ExceptT e m) where
302    liftIO = lift . liftIO
303    {-# INLINE liftIO #-}
304
305#if MIN_VERSION_base(4,4,0)
306instance (MonadZip m) => MonadZip (ExceptT e m) where
307    mzipWith f (ExceptT a) (ExceptT b) = ExceptT $ mzipWith (liftA2 f) a b
308    {-# INLINE mzipWith #-}
309#endif
310
311-- | Signal an exception value @e@.
312--
313-- * @'runExceptT' ('throwE' e) = 'return' ('Left' e)@
314--
315-- * @'throwE' e >>= m = 'throwE' e@
316throwE :: (Monad m) => e -> ExceptT e m a
317throwE = ExceptT . return . Left
318{-# INLINE throwE #-}
319
320-- | Handle an exception.
321--
322-- * @'catchE' h ('lift' m) = 'lift' m@
323--
324-- * @'catchE' h ('throwE' e) = h e@
325catchE :: (Monad m) =>
326    ExceptT e m a               -- ^ the inner computation
327    -> (e -> ExceptT e' m a)    -- ^ a handler for exceptions in the inner
328                                -- computation
329    -> ExceptT e' m a
330m `catchE` h = ExceptT $ do
331    a <- runExceptT m
332    case a of
333        Left  l -> runExceptT (h l)
334        Right r -> return (Right r)
335{-# INLINE catchE #-}
336
337-- | The same as @'flip' 'catchE'@, which is useful in situations where
338-- the code for the handler is shorter.
339handleE :: Monad m => (e -> ExceptT e' m a) -> ExceptT e m a -> ExceptT e' m a
340handleE = flip catchE
341{-# INLINE handleE #-}
342
343-- | Similar to 'catchE', but returns an 'Either' result which is
344-- @('Right' a)@ if no exception was thown, or @('Left' ex)@ if an
345-- exception @ex@ was thrown.
346tryE :: Monad m => ExceptT e m a -> ExceptT e m (Either e a)
347tryE m = catchE (liftM Right m) (return . Left)
348{-# INLINE tryE #-}
349
350-- | @'finallyE' a b@ executes computation @a@ followed by computation @b@,
351-- even if @a@ exits early by throwing an exception.  In the latter case,
352-- the exception is re-thrown after @b@ has been executed.
353finallyE :: Monad m => ExceptT e m a -> ExceptT e m () -> ExceptT e m a
354finallyE m closer = do
355    res <- tryE m
356    closer
357    either throwE return res
358{-# INLINE finallyE #-}
359
360-- | Lift a @callCC@ operation to the new monad.
361liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ExceptT e m) a b
362liftCallCC callCC f = ExceptT $
363    callCC $ \ c ->
364    runExceptT (f (\ a -> ExceptT $ c (Right a)))
365{-# INLINE liftCallCC #-}
366
367-- | Lift a @listen@ operation to the new monad.
368liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ExceptT e m) a
369liftListen listen = mapExceptT $ \ m -> do
370    (a, w) <- listen m
371    return $! fmap (\ r -> (r, w)) a
372{-# INLINE liftListen #-}
373
374-- | Lift a @pass@ operation to the new monad.
375liftPass :: (Monad m) => Pass w m (Either e a) -> Pass w (ExceptT e m) a
376liftPass pass = mapExceptT $ \ m -> pass $ do
377    a <- m
378    return $! case a of
379        Left l -> (Left l, id)
380        Right (r, f) -> (Right r, f)
381{-# INLINE liftPass #-}
382
383-- incurring the mtl dependency for these avoids packages that need them introducing orphans.
384
385#ifdef MTL
386
387instance Monad m => MonadError e (ExceptT e m) where
388    throwError = throwE
389    catchError = catchE
390
391instance MonadWriter w m => MonadWriter w (ExceptT e m) where
392    tell   = lift . tell
393    listen = liftListen listen
394    pass   = liftPass pass
395#if MIN_VERSION_mtl(2,1,0)
396    writer = lift . writer
397#endif
398
399instance MonadState s m => MonadState s (ExceptT e m) where
400  get = lift get
401  put = lift . put
402#if MIN_VERSION_mtl(2,1,0)
403  state = lift . state
404#endif
405
406instance MonadReader r m => MonadReader r (ExceptT e m) where
407  ask    = lift ask
408  local  = mapExceptT . local
409#if MIN_VERSION_mtl(2,1,0)
410  reader = lift . reader
411#endif
412
413instance MonadRWS r w s m => MonadRWS r w s (ExceptT e m)
414
415instance MonadCont m => MonadCont (ExceptT e m) where
416  callCC = liftCallCC callCC
417
418#endif
419