{-# 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
-- <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/control-monad-exception>.
-- 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