{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ConstraintKinds #-}
module Foundation.Monad.Exception
    ( MonadThrow(..)
    , MonadCatch(..)
    , MonadBracket(..)
    ) where

import           Basement.Compat.Base
import qualified Control.Exception as E

-- | Monad that can throw exception
class Monad m => MonadThrow m where
    -- | Throw immediatity an exception.
    -- Only a 'MonadCatch' monad will be able to catch the exception using 'catch'
    throw :: Exception e => e -> m a

-- | Monad that can catch exception
class MonadThrow m => MonadCatch m where
    catch :: Exception e => m a -> (e -> m a) -> m a

-- | Monad that can ensure cleanup actions are performed even in the
-- case of exceptions, both synchronous and asynchronous. This usually
-- excludes continuation-based monads.
class MonadCatch m => MonadBracket m where
    -- | A generalized version of the standard bracket function which
    -- allows distinguishing different exit cases.
    generalBracket
        :: m a
        -- ^ acquire some resource
        -> (a -> b -> m ignored1)
        -- ^ cleanup, no exception thrown
        -> (a -> E.SomeException -> m ignored2)
        -- ^ cleanup, some exception thrown. The exception will be rethrown
        -> (a -> m b)
        -- ^ inner action to perform with the resource
        -> m b

instance MonadThrow IO where
    throw :: forall e a. Exception e => e -> IO a
throw = forall e a. Exception e => e -> IO a
E.throwIO
instance MonadCatch IO where
    catch :: forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch
instance MonadBracket IO where
    generalBracket :: forall a b ignored1 ignored2.
IO a
-> (a -> b -> IO ignored1)
-> (a -> SomeException -> IO ignored2)
-> (a -> IO b)
-> IO b
generalBracket IO a
acquire a -> b -> IO ignored1
onSuccess a -> SomeException -> IO ignored2
onException a -> IO b
inner = forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
E.mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
        a
x <- IO a
acquire
        Either SomeException b
res1 <- forall e a. Exception e => IO a -> IO (Either e a)
E.try forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ a -> IO b
inner a
x
        case Either SomeException b
res1 of
            Left (SomeException
e1 :: E.SomeException) -> do
                -- explicitly ignore exceptions from the cleanup
                -- action so we keep the original exception
                forall a. IO a -> IO a
E.uninterruptibleMask_ forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const ()) (a -> SomeException -> IO ignored2
onException a
x SomeException
e1) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch`
                    (\(SomeException
_ :: E.SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
                forall e a. Exception e => e -> IO a
E.throwIO SomeException
e1
            Right b
y -> do
                -- Allow exceptions from the onSuccess function to propagate
                ignored1
_ <- a -> b -> IO ignored1
onSuccess a
x b
y
                forall (m :: * -> *) a. Monad m => a -> m a
return b
y