{-# LANGUAGE ScopedTypeVariables, CPP, ConstraintKinds #-}
{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}

-- | Extra functions for "Control.Exception".
--   These functions provide retrying, showing in the presence of exceptions,
--   and functions to catch\/ignore exceptions, including monomorphic (no 'Exception' context) versions.
--
--   If you want to use a safer set of exceptions see the
--   <https://hackage.haskell.org/package/safe-exceptions safe-exceptions> package.
module Control.Exception.Extra(
    module Control.Exception,
    Partial,
    retry, retryBool,
    errorWithoutStackTrace,
    showException, stringException,
    errorIO, assertIO,
    -- * Exception catching/ignoring
    ignore,
    catch_, handle_, try_,
    catchJust_, handleJust_, tryJust_,
    catchBool, handleBool, tryBool
    ) where

#if __GLASGOW_HASKELL__ >= 800
import GHC.Stack
#endif

import Control.Exception
import Control.Monad
import Data.List.Extra
import Data.Functor
import Partial
import Prelude


-- | Fully evaluate an input String. If the String contains embedded exceptions it will produce @\<Exception\>@.
--
-- > stringException "test"                           == pure "test"
-- > stringException ("test" ++ undefined)            == pure "test<Exception>"
-- > stringException ("test" ++ undefined ++ "hello") == pure "test<Exception>"
-- > stringException ['t','e','s','t',undefined]      == pure "test<Exception>"
stringException :: String -> IO String
stringException :: String -> IO String
stringException String
x = do
    Either SomeException String
r <- IO String -> IO (Either SomeException String)
forall a. IO a -> IO (Either SomeException a)
try_ (IO String -> IO (Either SomeException String))
-> IO String -> IO (Either SomeException String)
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
evaluate (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> (Char -> String -> String) -> String -> String
forall b a. b -> (a -> [a] -> b) -> [a] -> b
list [] (\Char
x String
xs -> Char
x Char -> String -> String
`seq` Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs) String
x
    case Either SomeException String
r of
        Left SomeException
e -> String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"<Exception>"
        Right [] -> String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        Right (Char
x:String
xs) -> (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
stringException String
xs


-- | Show a value, but if the result contains exceptions, produce
--   @\<Exception\>@. Defined as @'stringException' . show@.
--   Particularly useful for printing exceptions to users, remembering that exceptions
--   can themselves contain undefined values.
showException :: Show e => e -> IO String
showException :: e -> IO String
showException = String -> IO String
stringException (String -> IO String) -> (e -> String) -> e -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
forall a. Show a => a -> String
show


#if __GLASGOW_HASKELL__ < 800
-- | A variant of 'error' that does not produce a stack trace.
errorWithoutStackTrace :: String -> a
errorWithoutStackTrace = error
#endif


-- | Ignore any exceptions thrown by the action.
--
-- > ignore (print 1)    == print 1
-- > ignore (fail "die") == pure ()
ignore :: IO () -> IO ()
ignore :: IO () -> IO ()
ignore = IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException ()) -> IO ())
-> (IO () -> IO (Either SomeException ())) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Either SomeException ())
forall a. IO a -> IO (Either SomeException a)
try_


-- | An 'IO' action that when evaluated calls 'error', in the 'IO' monad.
--   Note that while 'fail' in 'IO' raises an 'IOException', this function raises an 'ErrorCall' exception with a call stack.
--
-- > catch (errorIO "Hello") (\(ErrorCall x) -> pure x) == pure "Hello"
-- > seq (errorIO "foo") (print 1) == print 1
{-# NOINLINE errorIO #-} -- otherwise GHC 8.4.1 seems to get upset
errorIO :: Partial => String -> IO a
errorIO :: String -> IO a
errorIO String
x = (HasCallStack => IO a) -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO a) -> IO a) -> (HasCallStack => IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall a. a -> IO a
evaluate (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ String -> a
forall a. HasCallStack => String -> a
error String
x

#if __GLASGOW_HASKELL__ < 800
withFrozenCallStack :: a -> a
withFrozenCallStack = id
#endif

-- | An 'IO' action that when evaluated calls 'assert' in the 'IO' monad, which throws an 'AssertionFailed' exception if the argument is 'False'.
--   With optimizations enabled (and @-fgnore-asserts@) this function ignores its argument and does nothing.
--
-- > catch (assertIO True  >> pure 1) (\(x :: AssertionFailed) -> pure 2) == pure 1
-- > seq (assertIO False) (print 1) == print 1
assertIO :: Partial => Bool -> IO ()
assertIO :: Bool -> IO ()
assertIO Bool
x = (HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO ()) -> IO ())
-> (HasCallStack => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert Bool
x ()

-- | Retry an operation at most /n/ times (/n/ must be positive).
--   If the operation fails the /n/th time it will throw that final exception.
--
-- > retry 1 (print "x")  == print "x"
-- > retry 3 (fail "die") == fail "die"
retry :: Int -> IO a -> IO a
retry :: Int -> IO a -> IO a
retry Int
i IO a
x | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = String -> IO a
forall a. HasCallStack => String -> a
error String
"Control.Exception.Extra.retry: count must be 1 or more"
retry Int
i IO a
x = (SomeException -> Bool) -> Int -> IO a -> IO a
forall e a. Exception e => (e -> Bool) -> Int -> IO a -> IO a
retryBool (\(SomeException
e :: SomeException) -> Bool
True) Int
i IO a
x

-- | Retry an operation at most /n/ times (/n/ must be positive), while the exception value and type match a predicate.
--   If the operation fails the /n/th time it will throw that final exception.
retryBool :: Exception e => (e -> Bool) -> Int -> IO a -> IO a
retryBool :: (e -> Bool) -> Int -> IO a -> IO a
retryBool e -> Bool
p Int
i IO a
x | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = String -> IO a
forall a. HasCallStack => String -> a
error String
"Control.Exception.Extra.retryBool: count must be 1 or more"
retryBool e -> Bool
p Int
1 IO a
x = IO a
x
retryBool e -> Bool
p Int
i IO a
x = do
    Either e a
res <- (e -> Bool) -> IO a -> IO (Either e a)
forall e a. Exception e => (e -> Bool) -> IO a -> IO (Either e a)
tryBool e -> Bool
p IO a
x
    case Either e a
res of
        Left e
_ -> (e -> Bool) -> Int -> IO a -> IO a
forall e a. Exception e => (e -> Bool) -> Int -> IO a -> IO a
retryBool e -> Bool
p (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) IO a
x
        Right a
v -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v


-- | A version of 'catch' without the 'Exception' context, restricted to 'SomeException',
--   so catches all exceptions.
catch_ :: IO a -> (SomeException -> IO a) -> IO a
catch_ :: IO a -> (SomeException -> IO a) -> IO a
catch_ = IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Control.Exception.catch

-- | Like 'catch_' but for 'catchJust'
catchJust_ :: (SomeException -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust_ :: (SomeException -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust_ = (SomeException -> Maybe b) -> IO a -> (b -> IO a) -> IO a
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust

-- | Like 'catch_' but for 'handle'
handle_ :: (SomeException -> IO a) -> IO a -> IO a
handle_ :: (SomeException -> IO a) -> IO a -> IO a
handle_ = (SomeException -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle

-- | Like 'catch_' but for 'handleJust'
handleJust_ :: (SomeException -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust_ :: (SomeException -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust_ = (SomeException -> Maybe b) -> (b -> IO a) -> IO a -> IO a
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust

-- | Like 'catch_' but for 'try'
try_ :: IO a -> IO (Either SomeException a)
try_ :: IO a -> IO (Either SomeException a)
try_ = IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try

-- | Like 'catch_' but for 'tryJust'
tryJust_ :: (SomeException -> Maybe b) -> IO a -> IO (Either b a)
tryJust_ :: (SomeException -> Maybe b) -> IO a -> IO (Either b a)
tryJust_ = (SomeException -> Maybe b) -> IO a -> IO (Either b a)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust

-- | Catch an exception if the predicate passes, then call the handler with the original exception.
--   As an example:
--
-- @
-- readFileExists x == catchBool isDoesNotExistError (readFile \"myfile\") (const $ pure \"\")
-- @
catchBool :: Exception e => (e -> Bool) -> IO a -> (e -> IO a) -> IO a
catchBool :: (e -> Bool) -> IO a -> (e -> IO a) -> IO a
catchBool e -> Bool
f IO a
a e -> IO a
b = (e -> Maybe e) -> IO a -> (e -> IO a) -> IO a
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust ((e -> Bool) -> e -> Maybe e
forall e. (e -> Bool) -> e -> Maybe e
bool e -> Bool
f) IO a
a e -> IO a
b

-- | Like 'catchBool' but for 'handle'.
handleBool :: Exception e => (e -> Bool) -> (e -> IO a) -> IO a -> IO a
handleBool :: (e -> Bool) -> (e -> IO a) -> IO a -> IO a
handleBool e -> Bool
f e -> IO a
a IO a
b = (e -> Maybe e) -> (e -> IO a) -> IO a -> IO a
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust ((e -> Bool) -> e -> Maybe e
forall e. (e -> Bool) -> e -> Maybe e
bool e -> Bool
f) e -> IO a
a IO a
b

-- | Like 'catchBool' but for 'try'.
tryBool :: Exception e => (e -> Bool) -> IO a -> IO (Either e a)
tryBool :: (e -> Bool) -> IO a -> IO (Either e a)
tryBool e -> Bool
f IO a
a = (e -> Maybe e) -> IO a -> IO (Either e a)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust ((e -> Bool) -> e -> Maybe e
forall e. (e -> Bool) -> e -> Maybe e
bool e -> Bool
f) IO a
a

bool :: (e -> Bool) -> (e -> Maybe e)
bool :: (e -> Bool) -> e -> Maybe e
bool e -> Bool
f e
x = if e -> Bool
f e
x then e -> Maybe e
forall a. a -> Maybe a
Just e
x else Maybe e
forall a. Maybe a
Nothing