{-# LANGUAGE FlexibleInstances #-}
-- |
-- Module : Control.Exception.Generic
--
-- Maintainer : tov at ccs dot neu dot edu
-- Stability : experimental
-- Portability : GHC 6.8
--
-- THIS PACKAGE HAS BEEN SUPERSEDED.
--
-- For GHC >= 6.10, check out the control-monad-exception
-- package at Hackage at
-- .
-- It does everything this package does and works with the new
-- exception system.
--
-- A generalization of exception handling, both inside and outside the
-- 'IO' monad. Based on Oleg Kiselyov's Control.Exception.MonadIO.
--
-- In the GHC library, 'Control.Exception.catch' has type
-- @IO a -> (Exception -> IO a) -> IO a@. If you are using monad
-- transformers on top of 'IO', this means that you can still use 'liftIO'
-- to catch exceptions, but the handler has to be written in the 'IO'
-- monad, not the richer monad that you're working in.
--
-- This module provides an API to fix this problem: Simply define an
-- instances of EMonad for your monad transformer, and then use 'gcatch'
-- to catch exceptions and 'glift' rather than 'lift' to faithfully
-- propogate exceptions out of the lifted term.
--
----------
module Control.Exception.Generic (
-- * Classes and types
EMonad(..),
EMonadIO,
-- ** Exception types (re-exported)
Exception(..), IOException, ArithException(..),
ArrayException(..), AsyncException(..),
-- * Lifting functions
glift, guntry,
-- * Lots of functions
-- | These are based on the functions in "Control.Exception"; they
-- all do the things indicated clearly by their types.
gthrowStr,
gcatchJust, ghandleJust, gtryJust,
gignore, gignoreJust,
gthrowDyn, gcatchDyn, ghandleDyn, gtryDyn,
gbracket, gbracket_, gfinally,
-- * Filters (re-exported)
ioErrors, arithExceptions, errorCalls, dynExceptions,
assertions, asyncExceptions, userErrors,
-- * Tests
tests__Control_Exception_Generic
) where
import Prelude hiding ( catch )
import Data.Dynamic
import System.IO.Error ( )
import Control.Exception
import Control.Monad.Trans ( )
import Control.Monad.Error
import Control.Monad.List
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.RWS
-- For tests:
import Data.IORef
import Test.HUnit
-- | Minimal complete definition: 'gthrow', and one of 'gcatch',
-- 'ghandle', or 'gtry'. (It turns out to be slightly useful to be able
-- to define in terms of any of these; e.g., for the 'EMonad' 'Either'
-- instance, 'gtry' = 'Right'.)
class Monad m => EMonad m where
gthrow :: Exception -> m a
gcatch :: m a -> (Exception -> m a) -> m a
ghandle :: (Exception -> m a) -> m a -> m a
gtry :: m a -> m (Either Exception a)
ghandle = flip gcatch
gtry a = gcatch (liftM Right a) (return . Left)
gcatch a h = gtry a >>= either h return
-- | Convenience class
class (EMonad m, MonadIO m) => EMonadIO m
instance EMonad IO where
gcatch = catch
gthrow = throw
instance EMonadIO IO
instance EMonad (Either Exception) where
gthrow = Left
gtry = Right
instance Error Exception where
strMsg = ErrorCall
instance Monad m => EMonad (ErrorT Exception m) where
gthrow = throwError
gcatch = catchError
instance EMonad m => EMonad (ListT m) where
gthrow = lift . gthrow
m `gcatch` h = ListT $ runListT m
`gcatch` \e -> runListT (h e)
instance EMonad m => EMonad (ReaderT r m) where
gthrow = lift . gthrow
m `gcatch` h = ReaderT $ \r -> runReaderT m r
`gcatch` \e -> runReaderT (h e) r
instance EMonad m => EMonad (StateT s m) where
gthrow = lift . gthrow
m `gcatch` h = StateT $ \s -> runStateT m s
`gcatch` \e -> runStateT (h e) s
instance (Monoid w, EMonad m) => EMonad (WriterT w m) where
gthrow = lift . gthrow
m `gcatch` h = WriterT $ runWriterT m
`gcatch` \e -> runWriterT (h e)
instance (Monoid w, EMonad m) => EMonad (RWST r w s m) where
gthrow = lift . gthrow
m `gcatch` h = RWST $ \r s -> runRWST m r s
`gcatch` \e -> runRWST (h e) r s
-- | This is like lift, but it catches exceptions on the inside and
-- lifts them on the outside.
glift :: (MonadTrans t, EMonad m, EMonad (t m)) => m a -> t m a
glift m = lift (gtry m) >>= guntry
-- | This is kind of a useful function -- it's the opposite of 'gtry'.
guntry :: EMonad m => Either Exception a -> m a
guntry = either gthrow return
gthrowStr :: EMonad m => String -> m a
gthrowStr = gthrow . strMsg
gcatchJust :: EMonad m =>
(Exception -> Maybe b) -> m a -> (b -> m a) -> m a
gcatchJust p a h = a `gcatch` \e -> maybe (gthrow e) h (p e)
ghandleJust :: EMonad m =>
(Exception -> Maybe b) -> (b -> m a) -> m a -> m a
ghandleJust = flip . gcatchJust
gtryJust :: EMonad m =>
(Exception -> Maybe b) -> m b1 -> m (Either b b1)
gtryJust p a = gcatchJust p (liftM Right a) (return . Left)
gignore :: EMonad m => m a -> m ()
gignore a = (a >> return ()) `gcatch` const (return ())
gignoreJust :: EMonad m => (Exception -> Maybe b) -> m a -> m ()
gignoreJust p a = gcatchJust p (a >> return ()) (const (return ()))
gthrowDyn :: (Typeable exc, EMonad m) => exc -> m a
gthrowDyn = gthrow . DynException . toDyn
gcatchDyn :: (Typeable exc, EMonad m) => m a -> (exc -> m a) -> m a
gcatchDyn a h = gcatchJust dynExceptions a $ \e ->
maybe (gthrow (DynException e)) h (fromDynamic e)
ghandleDyn :: (Typeable exc, EMonad m) => (exc -> m a) -> m a -> m a
ghandleDyn = flip gcatchDyn
-- | This is cool -- it's a /gtry/ variant that only pulls out
-- dynamic exceptions of one type.
gtryDyn :: (Typeable exc, EMonad m) => m a -> m (Either exc a)
gtryDyn a = gcatchDyn (liftM Right a) (return . Left)
-- | Note that this 'gbracket' /does not/ protect the cleanup code; I
-- contend that it shouldn't, because starting the cleanup again if it
-- throws the first time is almost never the right thing to do.
gbracket :: EMonad m => m a -> (a -> m b) -> (a -> m c) -> m c
gbracket pre post body = do
a <- pre
r <- gtry (body a)
post a
guntry r
gbracket_ :: EMonad m => m a -> m b -> m c -> m c
gbracket_ pre post body = gbracket pre (const post) (const body)
gfinally :: EMonad m => m a -> m b -> m a
gfinally body post = gbracket_ (return ()) post body
-- | Test cases. Most of these functions are suffciently constrained
-- by their types that they can't do the wrong thing unless there's
-- something obviously absurd in them.
tests__Control_Exception_Generic :: Test
tests__Control_Exception_Generic = "Control.Exception.Generic" ~:
test [ -- 'gcatch' doesn't go off willy-nilly . . .
"no catch" ~: do x <- return z `gcatch` \_ -> return 1
x @?= 0
-- . . . but it does catch when something is thrown.
, "catch" ~: do r <- newIORef z
gcatch (do fail "hi"
writeIORef r 1)
(\_ -> writeIORef r 2)
x <- readIORef r
x @?= 2
-- Basic 'gbracket' sanity test.
, "gbracket" ~: do r <- newIORef z
bracket (return r)
(\r' -> modifyIORef r' (+100))
(\r' -> do modifyIORef r' (+1)
fail "bye!"
modifyIORef r' (+10))
`gcatch` \_ -> modifyIORef r (+1000)
x <- readIORef r
x @?= 1101
]
where z :: Int
z = 0