{-# 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 ()

-- | The way in which a release is called.
--
-- @since 1.1.2
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 ())

-- | A method for acquiring a scarce resource, providing the means of freeing
-- it when no longer needed. This data type provides
-- @Functor@\/@Applicative@\/@Monad@ instances for composing different resources
-- together. You can allocate these resources using either the @bracket@
-- pattern (via @with@) or using @ResourceT@ (via @allocateAcquire@).
--
-- This concept was originally introduced by Gabriel Gonzalez and described at:
-- <http://www.haskellforall.com/2013/06/the-resource-applicative.html>. The
-- implementation in this package is slightly different, due to taking a
-- different approach to async exception safety.
--
-- @since 1.1.0
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 ())

-- | Create an @Acquire@ value using the given allocate and free functions.
--
-- To acquire and free the resource in an arbitrary monad with `MonadUnliftIO`,
-- do the following:
--
-- > acquire <- withRunInIO $ \runInIO ->
-- >   return $ mkAcquire (runInIO create) (runInIO . free)
--
-- Note that this is only safe if the Acquire is run and freed within the same
-- monadic scope it was created in.
--
-- @since 1.1.0
mkAcquire :: IO a -- ^ acquire the resource
          -> (a -> IO ()) -- ^ free the resource
          -> 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)

-- | Same as 'mkAcquire', but the cleanup function will be informed of /how/
-- cleanup was initiated. This allows you to distinguish, for example, between
-- normal and exceptional exits.
--
-- To acquire and free the resource in an arbitrary monad with `MonadUnliftIO`,
-- do the following:
--
-- > acquire <- withRunInIO $ \runInIO ->
-- >   return $ mkAcquireType (runInIO create) (\a -> runInIO . free a)
--
-- Note that this is only safe if the Acquire is run and freed within the same
-- monadic scope it was created in.
--
-- @since 1.1.2
mkAcquireType
    :: IO a -- ^ acquire the resource
    -> (a -> ReleaseType -> IO ()) -- ^ free the resource
    -> 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)

-- | Allocate the given resource and provide it to the provided function. The
-- resource will be freed as soon as the inner block is exited, whether
-- normally or via an exception. This function is similar in function to
-- @bracket@.
--
-- @since 1.1.0
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