-- |Catch exceptions produced in pure code
{-# LANGUAGE ScopedTypeVariables #-}
module Control.Exception.Pure 
    ( catchPureErrors
    , catchPureErrorsSafe
    ) where

import Control.DeepSeq (deepseq)
import Control.Exception



-- | Evaluate to weak head normal form and catch 
-- exceptions which can be raised by errors in pure computation.
-- See also the "Test.ChasingBottoms.IsBottom" module in ChasingBottoms package.
catchPureErrors :: a -> IO (Either String a)
catchPureErrors :: a -> IO (Either String a)
catchPureErrors a
a 
    = (a -> Either String a) -> IO a -> IO (Either String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either String a
forall a b. b -> Either a b
Right (a -> IO a
forall a. a -> IO a
evaluate a
a)
      IO (Either String a)
-> [Handler (Either String a)] -> IO (Either String a)
forall a. IO a -> [Handler a] -> IO a
`catches` 
        [ (ErrorCall -> IO (Either String a)) -> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(ErrorCall
e :: ErrorCall)        -> ErrorCall -> IO (Either String a)
forall x a. Show x => x -> IO (Either String a)
f ErrorCall
e)
        , (NonTermination -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(NonTermination
e :: NonTermination)   -> NonTermination -> IO (Either String a)
forall x a. Show x => x -> IO (Either String a)
f NonTermination
e)
        , (PatternMatchFail -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(PatternMatchFail
e :: PatternMatchFail) -> PatternMatchFail -> IO (Either String a)
forall x a. Show x => x -> IO (Either String a)
f PatternMatchFail
e)
        , (NoMethodError -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(NoMethodError
e :: NoMethodError)    -> NoMethodError -> IO (Either String a)
forall x a. Show x => x -> IO (Either String a)
f NoMethodError
e)
        , (ArrayException -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(ArrayException
e :: ArrayException)   -> ArrayException -> IO (Either String a)
forall x a. Show x => x -> IO (Either String a)
f ArrayException
e)
        , (RecConError -> IO (Either String a)) -> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(RecConError
e :: RecConError)      -> RecConError -> IO (Either String a)
forall x a. Show x => x -> IO (Either String a)
f RecConError
e)
        , (RecSelError -> IO (Either String a)) -> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(RecSelError
e :: RecSelError)      -> RecSelError -> IO (Either String a)
forall x a. Show x => x -> IO (Either String a)
f RecSelError
e)
        , (RecUpdError -> IO (Either String a)) -> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(RecUpdError
e :: RecUpdError)      -> RecUpdError -> IO (Either String a)
forall x a. Show x => x -> IO (Either String a)
f RecUpdError
e)
        , (ArithException -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(ArithException
e :: ArithException)   -> ArithException -> IO (Either String a)
forall x a. Show x => x -> IO (Either String a)
f ArithException
e)
        , (AssertionFailed -> IO (Either String a))
-> Handler (Either String a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(AssertionFailed
e :: AssertionFailed)  -> AssertionFailed -> IO (Either String a)
forall x a. Show x => x -> IO (Either String a)
f AssertionFailed
e)
        ]
 where
    f :: Show x => x -> IO (Either String a)
    f :: x -> IO (Either String a)
f = Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> IO (Either String a))
-> (x -> Either String a) -> x -> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a)
-> (x -> String) -> x -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> String
forall a. Show a => a -> String
show

-- | Make sure that the error message is a concrete String.
catchPureErrorsSafe :: a -> IO (Either String a)
catchPureErrorsSafe :: a -> IO (Either String a)
catchPureErrorsSafe a
a = do
    Either String a
e <- a -> IO (Either String a)
forall a. a -> IO (Either String a)
catchPureErrors a
a
    case Either String a
e of
        Right a
_ -> Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return Either String a
e
        Left String
s -> (Either String String -> Either String a)
-> IO (Either String String) -> IO (Either String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Either String a)
-> (String -> Either String a)
-> Either String String
-> Either String a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a)
-> (String -> String) -> String -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Nested error: "String -> String -> String
forall a. [a] -> [a] -> [a]
++)) String -> Either String a
forall a b. a -> Either a b
Left) (IO (Either String String) -> IO (Either String a))
-> IO (Either String String) -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$ String -> IO (Either String String)
forall a. a -> IO (Either String a)
catchPureErrorsSafe (String
s String -> String -> String
forall a b. NFData a => a -> b -> b
`deepseq` String
s)