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