-- | Throwing and catching exceptions. Internal QuickCheck module.

-- Hide away the nasty implementation-specific ways of catching
-- exceptions behind a nice API. The main trouble is catching ctrl-C.

{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE CPP #-}
module Test.QuickCheck.Exception where

#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ < 700)
#define OLD_EXCEPTIONS
#endif

#if defined(NO_EXCEPTIONS)
#else
import qualified Control.Exception as E
#endif

#if defined(NO_EXCEPTIONS)
type AnException = ()
#elif defined(OLD_EXCEPTIONS)
type AnException = E.Exception
#else
type AnException = E.SomeException
#endif

#ifdef NO_EXCEPTIONS
tryEvaluate :: a -> IO (Either AnException a)
tryEvaluate x = return (Right x)

tryEvaluateIO :: IO a -> IO (Either AnException a)
tryEvaluateIO m = fmap Right m

evaluate :: a -> IO a
evaluate x = x `seq` return x

isInterrupt :: AnException -> Bool
isInterrupt _ = False

discard :: a
discard = error "'discard' not supported, since your Haskell system can't catch exceptions"

isDiscard :: AnException -> Bool
isDiscard _ = False

finally :: IO a -> IO b -> IO a
finally mx my = do
  x <- mx
  my
  return x

#else
--------------------------------------------------------------------------
-- try evaluate

tryEvaluate :: a -> IO (Either AnException a)
tryEvaluate :: a -> IO (Either AnException a)
tryEvaluate a
x = IO a -> IO (Either AnException a)
forall a. IO a -> IO (Either AnException a)
tryEvaluateIO (a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x)

tryEvaluateIO :: IO a -> IO (Either AnException a)
tryEvaluateIO :: IO a -> IO (Either AnException a)
tryEvaluateIO IO a
m = (AnException -> Maybe AnException)
-> IO a -> IO (Either AnException a)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
E.tryJust AnException -> Maybe AnException
notAsync (IO a
m IO a -> (a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO a
forall a. a -> IO a
E.evaluate)
  where
    notAsync :: AnException -> Maybe AnException
#if MIN_VERSION_base(4,7,0)
    notAsync :: AnException -> Maybe AnException
notAsync AnException
e = case AnException -> Maybe SomeAsyncException
forall e. Exception e => AnException -> Maybe e
E.fromException AnException
e of
        Just (E.SomeAsyncException e
_) -> Maybe AnException
forall a. Maybe a
Nothing
        Maybe SomeAsyncException
Nothing                       -> AnException -> Maybe AnException
forall a. a -> Maybe a
Just AnException
e
#elif !defined(OLD_EXCEPTIONS)
    notAsync e = case E.fromException e :: Maybe E.AsyncException of
        Just _  -> Nothing
        Nothing -> Just e
#else
    notAsync e = Just e
#endif

--tryEvaluateIO m = Right `fmap` m

evaluate :: a -> IO a
evaluate :: a -> IO a
evaluate = a -> IO a
forall a. a -> IO a
E.evaluate

-- | Test if an exception was a @^C@.
-- QuickCheck won't try to shrink an interrupted test case.
isInterrupt :: AnException -> Bool

#if defined(OLD_EXCEPTIONS)
isInterrupt _ = False
#else
isInterrupt :: AnException -> Bool
isInterrupt AnException
e = AnException -> Maybe AsyncException
forall e. Exception e => AnException -> Maybe e
E.fromException AnException
e Maybe AsyncException -> Maybe AsyncException -> Bool
forall a. Eq a => a -> a -> Bool
== AsyncException -> Maybe AsyncException
forall a. a -> Maybe a
Just AsyncException
E.UserInterrupt
#endif

-- | A special error value. If a property evaluates 'discard', it
-- causes QuickCheck to discard the current test case.
-- This can be useful if you want to discard the current test case,
-- but are somewhere you can't use 'Test.QuickCheck.==>', such as inside a
-- generator.
discard :: a

isDiscard :: AnException -> Bool
(a
discard, AnException -> Bool
isDiscard) = (ErrorCall -> a
forall a e. Exception e => e -> a
E.throw (String -> ErrorCall
E.ErrorCall String
msg), AnException -> Bool
isDiscard)
 where
  msg :: String
msg = String
"DISCARD. " String -> String -> String
forall a. [a] -> [a] -> [a]
++
        String
"You should not see this exception, it is internal to QuickCheck."
#if defined(OLD_EXCEPTIONS)
  isDiscard (E.ErrorCall msg') = msg' == msg
  isDiscard _ = False
#else
  isDiscard :: AnException -> Bool
isDiscard AnException
e =
    case AnException -> Maybe ErrorCall
forall e. Exception e => AnException -> Maybe e
E.fromException AnException
e of
      Just (E.ErrorCall String
msg') -> String
msg' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
msg
      Maybe ErrorCall
_ -> Bool
False
#endif

finally :: IO a -> IO b -> IO a
finally :: IO a -> IO b -> IO a
finally = IO a -> IO b -> IO a
forall a b. IO a -> IO b -> IO a
E.finally
#endif

--------------------------------------------------------------------------
-- the end.