managed.hs

{-# LANGUAGE Rank2Types #-}

module Managed where

-- base
import Data.IORef

-- exceptions
import Control.Monad.Catch

-- managed
import Control.Monad.Managed

managedCatch :: Exception e => ((a -> IO r) -> IO r) -> (e -> (a -> IO r) -> IO r) -> (a -> IO r) -> IO r
managedCatch eval handler next = do
    ref <- newIORef (handler)
    let handler' e n = readIORef ref >>= \h -> h e n
    catch (eval (\v -> writeIORef ref (\e _ -> throwM e) >> next v)) (\e -> handler' e next)


managedMask' :: ((forall a. Managed a -> Managed a) -> Managed b) -> Managed b
managedMask' eval =
    managed $ \next ->
        uninterruptibleMask $ \restore ->
            with (eval (managedRestore restore)) $ (restore . next)

managedMask :: ((forall a. Managed a -> Managed a) -> Managed b) -> Managed b
managedMask eval =
    managed $ \next ->
        mask $ \restore ->
            with (eval (managedRestore restore)) $ (restore . next)

managedRestore :: (forall a. IO a -> IO a) -> Managed b -> Managed b
managedRestore oldRestore eval = managed $ \next -> oldRestore $ with eval next

instance MonadThrow Managed where
    throwM = liftIO . throwM

instance MonadCatch Managed where
    catch eval handler = managed $ managedCatch (with eval) (with . handler)

instance MonadMask Managed where
    mask                = managedMask
    uninterruptibleMask = managedMask'