1{-# LANGUAGE CPP #-}
2#if __GLASGOW_HASKELL__ >= 702
3{-# LANGUAGE Safe #-}
4#endif
5#if __GLASGOW_HASKELL__ >= 710
6{-# LANGUAGE AutoDeriveTypeable #-}
7#endif
8#if !(MIN_VERSION_base(4,9,0))
9{-# OPTIONS_GHC -fno-warn-orphans #-}
10#endif
11-----------------------------------------------------------------------------
12-- |
13-- Module      :  Control.Monad.Trans.Error
14-- Copyright   :  (c) Michael Weber <michael.weber@post.rwth-aachen.de> 2001,
15--                (c) Jeff Newbern 2003-2006,
16--                (c) Andriy Palamarchuk 2006
17-- License     :  BSD-style (see the file LICENSE)
18--
19-- Maintainer  :  R.Paterson@city.ac.uk
20-- Stability   :  experimental
21-- Portability :  portable
22--
23-- This monad transformer adds the ability to fail or throw exceptions
24-- to a monad.
25--
26-- A sequence of actions succeeds, producing a value, only if all the
27-- actions in the sequence are successful.  If one fails with an error,
28-- the rest of the sequence is skipped and the composite action fails
29-- with that error.
30--
31-- If the value of the error is not required, the variant in
32-- "Control.Monad.Trans.Maybe" may be used instead.
33--
34-- /Note:/ This module will be removed in a future release.
35-- Instead, use "Control.Monad.Trans.Except", which does not restrict
36-- the exception type, and also includes a base exception monad.
37-----------------------------------------------------------------------------
38
39module Control.Monad.Trans.Error
40  {-# DEPRECATED "Use Control.Monad.Trans.Except instead" #-} (
41    -- * The ErrorT monad transformer
42    Error(..),
43    ErrorList(..),
44    ErrorT(..),
45    mapErrorT,
46    -- * Error operations
47    throwError,
48    catchError,
49    -- * Lifting other operations
50    liftCallCC,
51    liftListen,
52    liftPass,
53    -- * Examples
54    -- $examples
55  ) where
56
57import Control.Monad.IO.Class
58import Control.Monad.Signatures
59import Control.Monad.Trans.Class
60import Data.Functor.Classes
61#if MIN_VERSION_base(4,12,0)
62import Data.Functor.Contravariant
63#endif
64
65import Control.Applicative
66import Control.Exception (IOException)
67import Control.Monad
68#if MIN_VERSION_base(4,9,0)
69import qualified Control.Monad.Fail as Fail
70#endif
71import Control.Monad.Fix
72#if !(MIN_VERSION_base(4,6,0))
73import Control.Monad.Instances ()  -- deprecated from base-4.6
74#endif
75import Data.Foldable (Foldable(foldMap))
76import Data.Monoid (mempty)
77import Data.Traversable (Traversable(traverse))
78import System.IO.Error
79
80#if !(MIN_VERSION_base(4,9,0))
81-- These instances are in base-4.9.0
82
83instance MonadPlus IO where
84    mzero       = ioError (userError "mzero")
85    m `mplus` n = m `catchIOError` \ _ -> n
86
87instance Alternative IO where
88    empty = mzero
89    (<|>) = mplus
90
91# if !(MIN_VERSION_base(4,4,0))
92-- exported by System.IO.Error from base-4.4
93catchIOError :: IO a -> (IOError -> IO a) -> IO a
94catchIOError = catch
95# endif
96#endif
97
98instance (Error e) => Alternative (Either e) where
99    empty        = Left noMsg
100    Left _ <|> n = n
101    m      <|> _ = m
102
103instance (Error e) => MonadPlus (Either e) where
104    mzero            = Left noMsg
105    Left _ `mplus` n = n
106    m      `mplus` _ = m
107
108#if !(MIN_VERSION_base(4,3,0))
109-- These instances are in base-4.3
110
111instance Applicative (Either e) where
112    pure          = Right
113    Left  e <*> _ = Left e
114    Right f <*> r = fmap f r
115
116instance Monad (Either e) where
117    return        = Right
118    Left  l >>= _ = Left l
119    Right r >>= k = k r
120
121instance MonadFix (Either e) where
122    mfix f = let
123        a = f $ case a of
124            Right r -> r
125            _       -> error "empty mfix argument"
126        in a
127
128#endif /* base to 4.2.0.x */
129
130-- | An exception to be thrown.
131--
132-- Minimal complete definition: 'noMsg' or 'strMsg'.
133class Error a where
134    -- | Creates an exception without a message.
135    -- The default implementation is @'strMsg' \"\"@.
136    noMsg  :: a
137    -- | Creates an exception with a message.
138    -- The default implementation of @'strMsg' s@ is 'noMsg'.
139    strMsg :: String -> a
140
141    noMsg    = strMsg ""
142    strMsg _ = noMsg
143
144instance Error IOException where
145    strMsg = userError
146
147-- | A string can be thrown as an error.
148instance (ErrorList a) => Error [a] where
149    strMsg = listMsg
150
151-- | Workaround so that we can have a Haskell 98 instance @'Error' 'String'@.
152class ErrorList a where
153    listMsg :: String -> [a]
154
155instance ErrorList Char where
156    listMsg = id
157
158-- | The error monad transformer. It can be used to add error handling
159-- to other monads.
160--
161-- The @ErrorT@ Monad structure is parameterized over two things:
162--
163-- * e - The error type.
164--
165-- * m - The inner monad.
166--
167-- The 'return' function yields a successful computation, while @>>=@
168-- sequences two subcomputations, failing on the first error.
169newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }
170
171instance (Eq e, Eq1 m) => Eq1 (ErrorT e m) where
172    liftEq eq (ErrorT x) (ErrorT y) = liftEq (liftEq eq) x y
173
174instance (Ord e, Ord1 m) => Ord1 (ErrorT e m) where
175    liftCompare comp (ErrorT x) (ErrorT y) = liftCompare (liftCompare comp) x y
176
177instance (Read e, Read1 m) => Read1 (ErrorT e m) where
178    liftReadsPrec rp rl = readsData $
179        readsUnaryWith (liftReadsPrec rp' rl') "ErrorT" ErrorT
180      where
181        rp' = liftReadsPrec rp rl
182        rl' = liftReadList rp rl
183
184instance (Show e, Show1 m) => Show1 (ErrorT e m) where
185    liftShowsPrec sp sl d (ErrorT m) =
186        showsUnaryWith (liftShowsPrec sp' sl') "ErrorT" d m
187      where
188        sp' = liftShowsPrec sp sl
189        sl' = liftShowList sp sl
190
191instance (Eq e, Eq1 m, Eq a) => Eq (ErrorT e m a) where (==) = eq1
192instance (Ord e, Ord1 m, Ord a) => Ord (ErrorT e m a) where compare = compare1
193instance (Read e, Read1 m, Read a) => Read (ErrorT e m a) where
194    readsPrec = readsPrec1
195instance (Show e, Show1 m, Show a) => Show (ErrorT e m a) where
196    showsPrec = showsPrec1
197
198-- | Map the unwrapped computation using the given function.
199--
200-- * @'runErrorT' ('mapErrorT' f m) = f ('runErrorT' m)@
201mapErrorT :: (m (Either e a) -> n (Either e' b))
202          -> ErrorT e m a
203          -> ErrorT e' n b
204mapErrorT f m = ErrorT $ f (runErrorT m)
205
206instance (Functor m) => Functor (ErrorT e m) where
207    fmap f = ErrorT . fmap (fmap f) . runErrorT
208
209instance (Foldable f) => Foldable (ErrorT e f) where
210    foldMap f (ErrorT a) = foldMap (either (const mempty) f) a
211
212instance (Traversable f) => Traversable (ErrorT e f) where
213    traverse f (ErrorT a) =
214        ErrorT <$> traverse (either (pure . Left) (fmap Right . f)) a
215
216instance (Functor m, Monad m) => Applicative (ErrorT e m) where
217    pure a  = ErrorT $ return (Right a)
218    f <*> v = ErrorT $ do
219        mf <- runErrorT f
220        case mf of
221            Left  e -> return (Left e)
222            Right k -> do
223                mv <- runErrorT v
224                case mv of
225                    Left  e -> return (Left e)
226                    Right x -> return (Right (k x))
227
228instance (Functor m, Monad m, Error e) => Alternative (ErrorT e m) where
229    empty = mzero
230    (<|>) = mplus
231
232instance (Monad m, Error e) => Monad (ErrorT e m) where
233#if !(MIN_VERSION_base(4,8,0))
234    return a = ErrorT $ return (Right a)
235#endif
236    m >>= k  = ErrorT $ do
237        a <- runErrorT m
238        case a of
239            Left  l -> return (Left l)
240            Right r -> runErrorT (k r)
241#if !(MIN_VERSION_base(4,13,0))
242    fail msg = ErrorT $ return (Left (strMsg msg))
243#endif
244
245#if MIN_VERSION_base(4,9,0)
246instance (Monad m, Error e) => Fail.MonadFail (ErrorT e m) where
247    fail msg = ErrorT $ return (Left (strMsg msg))
248#endif
249
250instance (Monad m, Error e) => MonadPlus (ErrorT e m) where
251    mzero       = ErrorT $ return (Left noMsg)
252    m `mplus` n = ErrorT $ do
253        a <- runErrorT m
254        case a of
255            Left  _ -> runErrorT n
256            Right r -> return (Right r)
257
258instance (MonadFix m, Error e) => MonadFix (ErrorT e m) where
259    mfix f = ErrorT $ mfix $ \ a -> runErrorT $ f $ case a of
260        Right r -> r
261        _       -> error "empty mfix argument"
262
263instance MonadTrans (ErrorT e) where
264    lift m = ErrorT $ do
265        a <- m
266        return (Right a)
267
268instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
269    liftIO = lift . liftIO
270
271#if MIN_VERSION_base(4,12,0)
272instance Contravariant m => Contravariant (ErrorT e m) where
273    contramap f = ErrorT . contramap (fmap f) . runErrorT
274#endif
275
276-- | Signal an error value @e@.
277--
278-- * @'runErrorT' ('throwError' e) = 'return' ('Left' e)@
279--
280-- * @'throwError' e >>= m = 'throwError' e@
281throwError :: (Monad m) => e -> ErrorT e m a
282throwError l = ErrorT $ return (Left l)
283
284-- | Handle an error.
285--
286-- * @'catchError' h ('lift' m) = 'lift' m@
287--
288-- * @'catchError' h ('throwError' e) = h e@
289catchError :: (Monad m) =>
290    ErrorT e m a                -- ^ the inner computation
291    -> (e -> ErrorT e m a)      -- ^ a handler for errors in the inner
292                                -- computation
293    -> ErrorT e m a
294m `catchError` h = ErrorT $ do
295    a <- runErrorT m
296    case a of
297        Left  l -> runErrorT (h l)
298        Right r -> return (Right r)
299
300-- | Lift a @callCC@ operation to the new monad.
301liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ErrorT e m) a b
302liftCallCC callCC f = ErrorT $
303    callCC $ \ c ->
304    runErrorT (f (\ a -> ErrorT $ c (Right a)))
305
306-- | Lift a @listen@ operation to the new monad.
307liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ErrorT e m) a
308liftListen listen = mapErrorT $ \ m -> do
309    (a, w) <- listen m
310    return $! fmap (\ r -> (r, w)) a
311
312-- | Lift a @pass@ operation to the new monad.
313liftPass :: (Monad m) => Pass w m (Either e a) -> Pass w (ErrorT e m) a
314liftPass pass = mapErrorT $ \ m -> pass $ do
315    a <- m
316    return $! case a of
317        Left  l      -> (Left  l, id)
318        Right (r, f) -> (Right r, f)
319
320{- $examples
321
322Wrapping an IO action that can throw an error @e@:
323
324> type ErrorWithIO e a = ErrorT e IO a
325> ==> ErrorT (IO (Either e a))
326
327An IO monad wrapped in @StateT@ inside of @ErrorT@:
328
329> type ErrorAndStateWithIO e s a = ErrorT e (StateT s IO) a
330> ==> ErrorT (StateT s IO (Either e a))
331> ==> ErrorT (StateT (s -> IO (Either e a,s)))
332
333-}
334