{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}

-- | The purpose of this module is to allow you to capture all exceptions
-- originating from within the enclosed computation, while still reacting
-- to asynchronous exceptions aimed at the calling thread.
--
-- This way, you can be sure that the function that calls, for example,
-- @'catchAny'@, will still respond to @'ThreadKilled'@ or @'Timeout'@
-- events raised by another thread (with @'throwTo'@), while capturing
-- all exceptions, synchronous or asynchronous, resulting from the
-- execution of the enclosed computation.
--
-- One particular use case is to allow the safe execution of code from various
-- libraries (which you do not control), capturing any faults that might
-- occur, while remaining responsive to higher level events and control
-- actions.
--
-- This library was originally developed by Michael Snoyman for the
-- 'ClassyPrelude' library, and was latter 'spun-off' into a separate
-- independent package.
--
-- For a more detailed explanation of the motivation behind this functions,
-- see:
--
-- <https://www.fpcomplete.com/user/snoyberg/general-haskell/exceptions/catching-all-exceptions>
--
-- and
--
-- <https://groups.google.com/forum/#!topic/haskell-cafe/e9H2I-3uVJE>
--
module Control.Exception.Enclosed
    ( -- ** Exceptions
      catchAny
    , handleAny
    , tryAny
    , catchDeep
    , catchAnyDeep
    , handleAnyDeep
    , tryDeep
    , tryAnyDeep
    , catchIO
    , handleIO
    , tryIO
      -- ** Force types
      -- | Helper functions for situations where type inferer gets confused.
    , asIOException
    , asSomeException
    ) where

import Prelude
import Control.Concurrent (forkIOWithUnmask)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar)
import Control.Exception
import Control.Monad (liftM)
import Control.Monad.Base (liftBase)
import Control.Monad.Trans.Control (MonadBaseControl, liftBaseWith, restoreM)
import Control.DeepSeq (NFData, ($!!))

import qualified Control.Exception.Lifted

-- | A version of 'catch' which is specialized for any exception. This
-- simplifies usage as no explicit type signatures are necessary.
--
-- Note that since version 0.5.9, this function now has proper support for
-- asynchronous exceptions, by only catching exceptions generated by the
-- internal (enclosed) action.
--
-- Since 0.5.6
catchAny :: MonadBaseControl IO m => m a -> (SomeException -> m a) -> m a
catchAny :: forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (SomeException -> m a) -> m a
catchAny m a
action SomeException -> m a
onE = m a -> m (Either SomeException a)
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> m (Either SomeException a)
tryAny m a
action m (Either SomeException a)
-> (Either SomeException a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> m a)
-> (a -> m a) -> Either SomeException a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> m a
onE a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | A version of 'handle' which is specialized for any exception.  This
-- simplifies usage as no explicit type signatures are necessary.
--
-- Note that since version 0.5.9, this function now has proper support for
-- asynchronous exceptions, by only catching exceptions generated by the
-- internal (enclosed) action.
--
-- Since 0.5.6
handleAny :: MonadBaseControl IO m => (SomeException -> m a) -> m a -> m a
handleAny :: forall (m :: * -> *) a.
MonadBaseControl IO m =>
(SomeException -> m a) -> m a -> m a
handleAny = (m a -> (SomeException -> m a) -> m a)
-> (SomeException -> m a) -> m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (SomeException -> m a) -> m a
catchAny

-- | A version of 'try' which is specialized for any exception.
-- This simplifies usage as no explicit type signatures are necessary.
--
-- Note that since version 0.5.9, this function now has proper support for
-- asynchronous exceptions, by only catching exceptions generated by the
-- internal (enclosed) action.
--
-- Since 0.5.6
tryAny :: MonadBaseControl IO m => m a -> m (Either SomeException a)
tryAny :: forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> m (Either SomeException a)
tryAny m a
m =
    (RunInBase m IO -> IO (Either SomeException (StM m a)))
-> m (Either SomeException (StM m a))
forall a. (RunInBase m IO -> IO a) -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith (\RunInBase m IO
runInIO -> IO (StM m a) -> IO (Either SomeException (StM m a))
forall a. IO a -> IO (Either SomeException a)
tryAnyIO (m a -> IO (StM m a)
RunInBase m IO
runInIO m a
m)) m (Either SomeException (StM m a))
-> (Either SomeException (StM m a) -> m (Either SomeException a))
-> m (Either SomeException a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    (SomeException -> m (Either SomeException a))
-> (StM m a -> m (Either SomeException a))
-> Either SomeException (StM m a)
-> m (Either SomeException a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either SomeException a -> m (Either SomeException a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException a -> m (Either SomeException a))
-> (SomeException -> Either SomeException a)
-> SomeException
-> m (Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException a
forall a b. a -> Either a b
Left) ((a -> Either SomeException a) -> m a -> m (Either SomeException a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Either SomeException a
forall a b. b -> Either a b
Right (m a -> m (Either SomeException a))
-> (StM m a -> m a) -> StM m a -> m (Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StM m a -> m a
forall a. StM m a -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM)
  where
    tryAnyIO :: IO a -> IO (Either SomeException a)
    tryAnyIO :: forall a. IO a -> IO (Either SomeException a)
tryAnyIO IO a
action = do
        MVar (Either SomeException a)
result <- IO (MVar (Either SomeException a))
forall a. IO (MVar a)
newEmptyMVar
        IO ThreadId
-> (ThreadId -> IO ())
-> (ThreadId -> IO (Either SomeException a))
-> IO (Either SomeException a)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
            (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask (\forall a. IO a -> IO a
restore -> IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO a -> IO a
forall a. IO a -> IO a
restore IO a
action) IO (Either SomeException a)
-> (Either SomeException a -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar (Either SomeException a) -> Either SomeException a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException a)
result))
            (\ThreadId
t -> ThreadId -> AsyncException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
t AsyncException
ThreadKilled)
            (\ThreadId
_ -> Int -> IO (Either SomeException a) -> IO (Either SomeException a)
forall a. Int -> IO a -> IO a
retryCount Int
10 (MVar (Either SomeException a) -> IO (Either SomeException a)
forall a. MVar a -> IO a
readMVar MVar (Either SomeException a)
result))

    -- If the action supplied by the user ends up blocking on an MVar
    -- or STM action, all threads currently blocked on such an action will
    -- receive an exception. In general, this is a good thing from the GHC
    -- RTS, but it is counter-productive for our purposes, where we know that
    -- when the user action receives such an exception, our code above will
    -- unblock and our main thread will not deadlock.
    --
    -- Workaround: we retry the readMVar action if we received a
    -- BlockedIndefinitelyOnMVar. To remain on the safe side and avoid
    -- deadlock, we cap this at an arbitrary number (10) above so that, if
    -- there's a bug in this function, the runtime system can still recover.
    --
    -- For previous discussion of this topic, see:
    -- https://github.com/simonmar/async/pull/15
    retryCount :: Int -> IO a -> IO a
    retryCount :: forall a. Int -> IO a -> IO a
retryCount Int
cnt0 IO a
action =
        Int -> IO a
loop Int
cnt0
      where
        loop :: Int -> IO a
loop Int
0 = IO a
action
        loop Int
cnt = IO a
action IO a -> (BlockedIndefinitelyOnMVar -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Control.Exception.catch`
            \BlockedIndefinitelyOnMVar
BlockedIndefinitelyOnMVar -> Int -> IO a
loop (Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

-- | An extension to @catch@ which ensures that the return value is fully
-- evaluated. See @tryAny@.
--
-- Since 1.0.1
catchDeep :: (Exception e, NFData a, MonadBaseControl IO m) => m a -> (e -> m a) -> m a
catchDeep :: forall e a (m :: * -> *).
(Exception e, NFData a, MonadBaseControl IO m) =>
m a -> (e -> m a) -> m a
catchDeep m a
action e -> m a
onE = m a -> m (Either e a)
forall e a (m :: * -> *).
(Exception e, NFData a, MonadBaseControl IO m) =>
m a -> m (Either e a)
tryDeep m a
action m (Either e a) -> (Either e a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (e -> m a) -> (a -> m a) -> Either e a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> m a
onE a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | An extension to @catchAny@ which ensures that the return value is fully
-- evaluated. See @tryAnyDeep@.
--
-- Since 0.5.9
catchAnyDeep :: (NFData a, MonadBaseControl IO m) => m a -> (SomeException -> m a) -> m a
catchAnyDeep :: forall a (m :: * -> *).
(NFData a, MonadBaseControl IO m) =>
m a -> (SomeException -> m a) -> m a
catchAnyDeep m a
action SomeException -> m a
onE = m a -> m (Either SomeException a)
forall a (m :: * -> *).
(NFData a, MonadBaseControl IO m) =>
m a -> m (Either SomeException a)
tryAnyDeep m a
action m (Either SomeException a)
-> (Either SomeException a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> m a)
-> (a -> m a) -> Either SomeException a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> m a
onE a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | @flip catchAnyDeep@
--
-- Since 0.5.6
handleAnyDeep :: (NFData a, MonadBaseControl IO m) => (SomeException -> m a) -> m a -> m a
handleAnyDeep :: forall a (m :: * -> *).
(NFData a, MonadBaseControl IO m) =>
(SomeException -> m a) -> m a -> m a
handleAnyDeep = (m a -> (SomeException -> m a) -> m a)
-> (SomeException -> m a) -> m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip m a -> (SomeException -> m a) -> m a
forall a (m :: * -> *).
(NFData a, MonadBaseControl IO m) =>
m a -> (SomeException -> m a) -> m a
catchAnyDeep

-- | an extension to @try@ which ensures that the return value is fully
-- evaluated. in other words, if you get a @right@ response here, you can be
-- confident that using it will not result in another exception.
--
-- Since 1.0.1
tryDeep :: (Exception e, NFData a, MonadBaseControl IO m)
        => m a
        -> m (Either e a)
tryDeep :: forall e a (m :: * -> *).
(Exception e, NFData a, MonadBaseControl IO m) =>
m a -> m (Either e a)
tryDeep m a
m = m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> m (Either e a)
Control.Exception.Lifted.try (m a -> m (Either e a)) -> m a -> m (Either e a)
forall a b. (a -> b) -> a -> b
$ do
    a
x <- m a
m
    IO a -> m a
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO a -> m a) -> IO a -> m 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. NFData a => (a -> b) -> a -> b
$!! a
x


-- | an extension to @tryany@ which ensures that the return value is fully
-- evaluated. in other words, if you get a @right@ response here, you can be
-- confident that using it will not result in another exception.
--
-- Since 0.5.9
tryAnyDeep :: (NFData a, MonadBaseControl IO m)
           => m a
           -> m (Either SomeException a)
tryAnyDeep :: forall a (m :: * -> *).
(NFData a, MonadBaseControl IO m) =>
m a -> m (Either SomeException a)
tryAnyDeep m a
m = m a -> m (Either SomeException a)
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> m (Either SomeException a)
tryAny (m a -> m (Either SomeException a))
-> m a -> m (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ do
    a
x <- m a
m
    IO a -> m a
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO a -> m a) -> IO a -> m 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. NFData a => (a -> b) -> a -> b
$!! a
x

-- | A version of 'catch' which is specialized for IO exceptions. This
-- simplifies usage as no explicit type signatures are necessary.
--
-- Since 0.5.6
catchIO :: MonadBaseControl IO m => m a -> (IOException -> m a) -> m a
catchIO :: forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (IOException -> m a) -> m a
catchIO = m a -> (IOException -> m a) -> m a
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
Control.Exception.Lifted.catch

-- | A version of 'handle' which is specialized for IO exceptions.  This
-- simplifies usage as no explicit type signatures are necessary.
--
-- Since 0.5.6
handleIO :: MonadBaseControl IO m => (IOException -> m a) -> m a -> m a
handleIO :: forall (m :: * -> *) a.
MonadBaseControl IO m =>
(IOException -> m a) -> m a -> m a
handleIO = (IOException -> m a) -> m a -> m a
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
(e -> m a) -> m a -> m a
Control.Exception.Lifted.handle

-- | A version of 'try' which is specialized for IO exceptions.
-- This simplifies usage as no explicit type signatures are necessary.
--
-- Since 0.5.6
tryIO :: MonadBaseControl IO m => m a -> m (Either IOException a)
tryIO :: forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> m (Either IOException a)
tryIO = m a -> m (Either IOException a)
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> m (Either e a)
Control.Exception.Lifted.try

-- |
--
-- Since 0.5.6
asSomeException :: SomeException -> SomeException
asSomeException :: SomeException -> SomeException
asSomeException = SomeException -> SomeException
forall a. a -> a
id

-- |
--
-- Since 0.5.6
asIOException :: IOException -> IOException
asIOException :: IOException -> IOException
asIOException = IOException -> IOException
forall a. a -> a
id