{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE CPP #-}
{-# 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.IO.Unlift (MonadIO (..), MonadUnliftIO, withRunInIO)
import qualified Control.Exception as E
import Data.Typeable (Typeable)
import Control.Monad (liftM, ap)
import qualified Control.Monad.Catch as C ()
data ReleaseType = ReleaseEarly
| ReleaseNormal
| ReleaseException
deriving (Int -> ReleaseType -> ShowS
[ReleaseType] -> ShowS
ReleaseType -> String
(Int -> ReleaseType -> ShowS)
-> (ReleaseType -> String)
-> ([ReleaseType] -> ShowS)
-> Show ReleaseType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReleaseType] -> ShowS
$cshowList :: [ReleaseType] -> ShowS
show :: ReleaseType -> String
$cshow :: ReleaseType -> String
showsPrec :: Int -> ReleaseType -> ShowS
$cshowsPrec :: Int -> ReleaseType -> ShowS
Show, ReadPrec [ReleaseType]
ReadPrec ReleaseType
Int -> ReadS ReleaseType
ReadS [ReleaseType]
(Int -> ReadS ReleaseType)
-> ReadS [ReleaseType]
-> ReadPrec ReleaseType
-> ReadPrec [ReleaseType]
-> Read ReleaseType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ReleaseType]
$creadListPrec :: ReadPrec [ReleaseType]
readPrec :: ReadPrec ReleaseType
$creadPrec :: ReadPrec ReleaseType
readList :: ReadS [ReleaseType]
$creadList :: ReadS [ReleaseType]
readsPrec :: Int -> ReadS ReleaseType
$creadsPrec :: Int -> ReadS ReleaseType
Read, ReleaseType -> ReleaseType -> Bool
(ReleaseType -> ReleaseType -> Bool)
-> (ReleaseType -> ReleaseType -> Bool) -> Eq ReleaseType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReleaseType -> ReleaseType -> Bool
$c/= :: ReleaseType -> ReleaseType -> Bool
== :: ReleaseType -> ReleaseType -> Bool
$c== :: ReleaseType -> ReleaseType -> Bool
Eq, Eq ReleaseType
Eq ReleaseType
-> (ReleaseType -> ReleaseType -> Ordering)
-> (ReleaseType -> ReleaseType -> Bool)
-> (ReleaseType -> ReleaseType -> Bool)
-> (ReleaseType -> ReleaseType -> Bool)
-> (ReleaseType -> ReleaseType -> Bool)
-> (ReleaseType -> ReleaseType -> ReleaseType)
-> (ReleaseType -> ReleaseType -> ReleaseType)
-> Ord ReleaseType
ReleaseType -> ReleaseType -> Bool
ReleaseType -> ReleaseType -> Ordering
ReleaseType -> ReleaseType -> ReleaseType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ReleaseType -> ReleaseType -> ReleaseType
$cmin :: ReleaseType -> ReleaseType -> ReleaseType
max :: ReleaseType -> ReleaseType -> ReleaseType
$cmax :: ReleaseType -> ReleaseType -> ReleaseType
>= :: ReleaseType -> ReleaseType -> Bool
$c>= :: ReleaseType -> ReleaseType -> Bool
> :: ReleaseType -> ReleaseType -> Bool
$c> :: ReleaseType -> ReleaseType -> Bool
<= :: ReleaseType -> ReleaseType -> Bool
$c<= :: ReleaseType -> ReleaseType -> Bool
< :: ReleaseType -> ReleaseType -> Bool
$c< :: ReleaseType -> ReleaseType -> Bool
compare :: ReleaseType -> ReleaseType -> Ordering
$ccompare :: ReleaseType -> ReleaseType -> Ordering
$cp1Ord :: Eq ReleaseType
Ord, Int -> ReleaseType
ReleaseType -> Int
ReleaseType -> [ReleaseType]
ReleaseType -> ReleaseType
ReleaseType -> ReleaseType -> [ReleaseType]
ReleaseType -> ReleaseType -> ReleaseType -> [ReleaseType]
(ReleaseType -> ReleaseType)
-> (ReleaseType -> ReleaseType)
-> (Int -> ReleaseType)
-> (ReleaseType -> Int)
-> (ReleaseType -> [ReleaseType])
-> (ReleaseType -> ReleaseType -> [ReleaseType])
-> (ReleaseType -> ReleaseType -> [ReleaseType])
-> (ReleaseType -> ReleaseType -> ReleaseType -> [ReleaseType])
-> Enum ReleaseType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ReleaseType -> ReleaseType -> ReleaseType -> [ReleaseType]
$cenumFromThenTo :: ReleaseType -> ReleaseType -> ReleaseType -> [ReleaseType]
enumFromTo :: ReleaseType -> ReleaseType -> [ReleaseType]
$cenumFromTo :: ReleaseType -> ReleaseType -> [ReleaseType]
enumFromThen :: ReleaseType -> ReleaseType -> [ReleaseType]
$cenumFromThen :: ReleaseType -> ReleaseType -> [ReleaseType]
enumFrom :: ReleaseType -> [ReleaseType]
$cenumFrom :: ReleaseType -> [ReleaseType]
fromEnum :: ReleaseType -> Int
$cfromEnum :: ReleaseType -> Int
toEnum :: Int -> ReleaseType
$ctoEnum :: Int -> ReleaseType
pred :: ReleaseType -> ReleaseType
$cpred :: ReleaseType -> ReleaseType
succ :: ReleaseType -> ReleaseType
$csucc :: ReleaseType -> ReleaseType
Enum, ReleaseType
ReleaseType -> ReleaseType -> Bounded ReleaseType
forall a. a -> a -> Bounded a
maxBound :: ReleaseType
$cmaxBound :: ReleaseType
minBound :: ReleaseType
$cminBound :: ReleaseType
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 :: (a -> b) -> Acquire a -> Acquire b
fmap = (a -> b) -> Acquire a -> Acquire b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative Acquire where
pure :: a -> Acquire a
pure a
a = ((forall b. IO b -> IO b) -> IO (Allocated a)) -> Acquire a
forall a.
((forall b. IO b -> IO b) -> IO (Allocated a)) -> Acquire a
Acquire (\forall b. IO b -> IO b
_ -> Allocated a -> IO (Allocated a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> (ReleaseType -> IO ()) -> Allocated a
forall a. a -> (ReleaseType -> IO ()) -> Allocated a
Allocated a
a (IO () -> ReleaseType -> IO ()
forall a b. a -> b -> a
const (IO () -> ReleaseType -> IO ()) -> IO () -> ReleaseType -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())))
<*> :: Acquire (a -> b) -> Acquire a -> Acquire b
(<*>) = Acquire (a -> b) -> Acquire a -> Acquire b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad Acquire where
return :: a -> Acquire a
return = a -> Acquire a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Acquire (forall b. IO b -> IO b) -> IO (Allocated a)
f >>= :: Acquire a -> (a -> Acquire b) -> Acquire b
>>= a -> Acquire b
g' = ((forall b. IO b -> IO b) -> IO (Allocated b)) -> Acquire b
forall a.
((forall b. IO b -> IO b) -> IO (Allocated a)) -> Acquire a
Acquire (((forall b. IO b -> IO b) -> IO (Allocated b)) -> Acquire b)
-> ((forall b. IO b -> IO b) -> IO (Allocated b)) -> Acquire b
forall a b. (a -> b) -> a -> b
$ \forall b. IO b -> IO b
restore -> do
Allocated a
x ReleaseType -> IO ()
free1 <- (forall b. IO b -> IO b) -> IO (Allocated a)
f forall b. IO b -> IO b
restore
let Acquire (forall b. IO b -> IO b) -> IO (Allocated b)
g = a -> Acquire b
g' a
x
Allocated b
y ReleaseType -> IO ()
free2 <- (forall b. IO b -> IO b) -> IO (Allocated b)
g forall b. IO b -> IO b
restore IO (Allocated b) -> IO () -> IO (Allocated b)
forall a b. IO a -> IO b -> IO a
`E.onException` ReleaseType -> IO ()
free1 ReleaseType
ReleaseException
Allocated b -> IO (Allocated b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Allocated b -> IO (Allocated b))
-> Allocated b -> IO (Allocated b)
forall a b. (a -> b) -> a -> b
$! b -> (ReleaseType -> IO ()) -> Allocated b
forall a. a -> (ReleaseType -> IO ()) -> Allocated a
Allocated b
y (\ReleaseType
rt -> ReleaseType -> IO ()
free2 ReleaseType
rt IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`E.finally` ReleaseType -> IO ()
free1 ReleaseType
rt)
instance MonadIO Acquire where
liftIO :: IO a -> Acquire a
liftIO IO a
f = ((forall b. IO b -> IO b) -> IO (Allocated a)) -> Acquire a
forall a.
((forall b. IO b -> IO b) -> IO (Allocated a)) -> Acquire a
Acquire (((forall b. IO b -> IO b) -> IO (Allocated a)) -> Acquire a)
-> ((forall b. IO b -> IO b) -> IO (Allocated a)) -> Acquire a
forall a b. (a -> b) -> a -> b
$ \forall b. IO b -> IO b
restore -> do
a
x <- IO a -> IO a
forall b. IO b -> IO b
restore IO a
f
Allocated a -> IO (Allocated a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Allocated a -> IO (Allocated a))
-> Allocated a -> IO (Allocated a)
forall a b. (a -> b) -> a -> b
$! a -> (ReleaseType -> IO ()) -> Allocated a
forall a. a -> (ReleaseType -> IO ()) -> Allocated a
Allocated a
x (IO () -> ReleaseType -> IO ()
forall a b. a -> b -> a
const (IO () -> ReleaseType -> IO ()) -> IO () -> ReleaseType -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
mkAcquire :: IO a
-> (a -> IO ())
-> Acquire a
mkAcquire :: IO a -> (a -> IO ()) -> Acquire a
mkAcquire IO a
create a -> IO ()
free = IO a -> (a -> ReleaseType -> IO ()) -> Acquire a
forall a. IO a -> (a -> ReleaseType -> IO ()) -> Acquire a
mkAcquireType IO a
create (\a
a ReleaseType
_ -> a -> IO ()
free a
a)
mkAcquireType
:: IO a
-> (a -> ReleaseType -> IO ())
-> Acquire a
mkAcquireType :: IO a -> (a -> ReleaseType -> IO ()) -> Acquire a
mkAcquireType IO a
create a -> ReleaseType -> IO ()
free = ((forall b. IO b -> IO b) -> IO (Allocated a)) -> Acquire a
forall a.
((forall b. IO b -> IO b) -> IO (Allocated a)) -> Acquire a
Acquire (((forall b. IO b -> IO b) -> IO (Allocated a)) -> Acquire a)
-> ((forall b. IO b -> IO b) -> IO (Allocated a)) -> Acquire a
forall a b. (a -> b) -> a -> b
$ \forall b. IO b -> IO b
_ -> do
a
x <- IO a
create
Allocated a -> IO (Allocated a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Allocated a -> IO (Allocated a))
-> Allocated a -> IO (Allocated a)
forall a b. (a -> b) -> a -> b
$! a -> (ReleaseType -> IO ()) -> Allocated a
forall a. a -> (ReleaseType -> IO ()) -> Allocated a
Allocated a
x (a -> ReleaseType -> IO ()
free a
x)
with :: MonadUnliftIO m
=> Acquire a
-> (a -> m b)
-> m b
with :: Acquire a -> (a -> m b) -> m b
with (Acquire (forall b. IO b -> IO b) -> IO (Allocated a)
f) a -> m b
g = ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO b) -> m b)
-> ((forall a. m a -> IO a) -> IO b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> ((forall b. IO b -> IO b) -> IO b) -> IO b
forall b. ((forall b. IO b -> IO b) -> IO b) -> IO b
E.mask (((forall b. IO b -> IO b) -> IO b) -> IO b)
-> ((forall b. IO b -> IO b) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \forall b. IO b -> IO b
restore -> do
Allocated a
x ReleaseType -> IO ()
free <- (forall b. IO b -> IO b) -> IO (Allocated a)
f forall b. IO b -> IO b
restore
b
res <- IO b -> IO b
forall b. IO b -> IO b
restore (m b -> IO b
forall a. m a -> IO a
run (a -> m b
g a
x)) IO b -> IO () -> IO b
forall a b. IO a -> IO b -> IO a
`E.onException` ReleaseType -> IO ()
free ReleaseType
ReleaseException
ReleaseType -> IO ()
free ReleaseType
ReleaseNormal
b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
res