{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
module Data.Acquire.Internal
( Acquire (..)
, Allocated (..)
, with
, mkAcquire
, ReleaseType (..)
, mkAcquireType
) where
import Control.Applicative (Applicative (..))
import Control.Monad.Base (MonadBase (..))
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Control (MonadBaseControl, control)
import qualified Control.Exception.Lifted as E
import Data.Typeable (Typeable)
import Control.Monad (liftM, ap)
data ReleaseType = ReleaseEarly
| ReleaseNormal
| ReleaseException
deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)
data Allocated a = Allocated !a !(ReleaseType -> IO ())
newtype Acquire a = Acquire ((forall b. IO b -> IO b) -> IO (Allocated a))
deriving Typeable
instance Functor Acquire where
fmap = liftM
instance Applicative Acquire where
pure = return
(<*>) = ap
instance Monad Acquire where
return a = Acquire (\_ -> return (Allocated a (const $ return ())))
Acquire f >>= g' = Acquire $ \restore -> do
Allocated x free1 <- f restore
let Acquire g = g' x
Allocated y free2 <- g restore `E.onException` free1 ReleaseException
return $! Allocated y (\rt -> free2 rt `E.finally` free1 rt)
instance MonadIO Acquire where
liftIO f = Acquire $ \restore -> do
x <- restore f
return $! Allocated x (const $ return ())
instance MonadBase IO Acquire where
liftBase = liftIO
mkAcquire :: IO a
-> (a -> IO ())
-> Acquire a
mkAcquire create free = Acquire $ \restore -> do
x <- restore create
return $! Allocated x (const $ free x)
mkAcquireType
:: IO a
-> (a -> ReleaseType -> IO ())
-> Acquire a
mkAcquireType create free = Acquire $ \restore -> do
x <- restore create
return $! Allocated x (free x)
with :: MonadBaseControl IO m
=> Acquire a
-> (a -> m b)
-> m b
with (Acquire f) g = control $ \run -> E.mask $ \restore -> do
Allocated x free <- f restore
res <- run (g x) `E.onException` free ReleaseException
free ReleaseNormal
return res