{-| 
Module: Waterfall.Internal.Finalizers

These functions exist because the underlying `opencascade-hs` library, 
makes heavy use of `Data.Acquire` from `resourcet` to handle memory management.
However `waterfall-cad` does not (at the highest level) keep values in the `Acquire` monad. 
(This is required to support functions like `Waterfall.Solids.volume`, which return pure Haskell primitives.)

-}
module Waterfall.Internal.Finalizers 
( unsafeFromAcquire
, unsafeFromAcquireT
, fromAcquire
, fromAcquireT
, toAcquire
) where

import System.IO.Unsafe (unsafePerformIO)
import Control.Monad.Trans.Resource (runResourceT, unprotect)
import Data.Acquire (Acquire, mkAcquire, allocateAcquire)
import System.Mem.Weak (addFinalizer)
import Control.Monad.Primitive (touch)
import Control.Monad.IO.Class (liftIO)
import Data.Maybe (fromMaybe)
import Control.Monad (forM, when)
import Data.IORef (newIORef, atomicModifyIORef)

-- | Convert a resource in the `Data.Acquire.Acquire` monad to a value in IO
-- the `free` action of the resource is called when the underlying value goes out of scope of the Haskell garbage collection
-- so may run at an unpredictable time.
fromAcquire :: Acquire a -> IO a 
fromAcquire :: forall a. Acquire a -> IO a
fromAcquire Acquire a
a = ResourceT IO a -> IO a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO a -> IO a) -> ResourceT IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    (ReleaseKey
releaseKey, a
v) <- Acquire a -> ResourceT IO (ReleaseKey, a)
forall (m :: * -> *) a.
MonadResource m =>
Acquire a -> m (ReleaseKey, a)
allocateAcquire Acquire a
a
    IO ()
release <- IO () -> Maybe (IO ()) -> IO ()
forall a. a -> Maybe a -> a
fromMaybe (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Maybe (IO ()) -> IO ())
-> ResourceT IO (Maybe (IO ())) -> ResourceT IO (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReleaseKey -> ResourceT IO (Maybe (IO ()))
forall (m :: * -> *). MonadIO m => ReleaseKey -> m (Maybe (IO ()))
unprotect ReleaseKey
releaseKey
    IO () -> ResourceT IO ()
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ResourceT IO ()) -> IO () -> ResourceT IO ()
forall a b. (a -> b) -> a -> b
$ a -> IO () -> IO ()
forall key. key -> IO () -> IO ()
addFinalizer a
v IO ()
release
    a -> ResourceT IO a
forall a. a -> ResourceT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v

    
-- | variant of `fromAcquire` which registers the finalizer on the _value_ in a container 
-- as opposed to the container itself 
-- this is useful for wrapping IO actions that return the type `IO (Maybe a)` where the `Maybe` will often be finalized well before the value
-- or `IO [a]` where the List will be finalized first
fromAcquireT :: Traversable f => Acquire (f a) -> IO (f a) 
fromAcquireT :: forall (f :: * -> *) a. Traversable f => Acquire (f a) -> IO (f a)
fromAcquireT Acquire (f a)
a = ResourceT IO (f a) -> IO (f a)
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO (f a) -> IO (f a)) -> ResourceT IO (f a) -> IO (f a)
forall a b. (a -> b) -> a -> b
$ do
    (ReleaseKey
releaseKey, f a
v) <- Acquire (f a) -> ResourceT IO (ReleaseKey, f a)
forall (m :: * -> *) a.
MonadResource m =>
Acquire a -> m (ReleaseKey, a)
allocateAcquire Acquire (f a)
a
    IO ()
release <- IO () -> Maybe (IO ()) -> IO ()
forall a. a -> Maybe a -> a
fromMaybe (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Maybe (IO ()) -> IO ())
-> ResourceT IO (Maybe (IO ())) -> ResourceT IO (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReleaseKey -> ResourceT IO (Maybe (IO ()))
forall (m :: * -> *). MonadIO m => ReleaseKey -> m (Maybe (IO ()))
unprotect ReleaseKey
releaseKey
    IORef Int
ref <- IO (IORef Int) -> ResourceT IO (IORef Int)
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Int) -> ResourceT IO (IORef Int))
-> IO (IORef Int) -> ResourceT IO (IORef Int)
forall a b. (a -> b) -> a -> b
$ Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (f a -> Int
forall a. f a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length f a
v)
    let finalize :: IO ()
finalize = do
            Bool
isLast <- IORef Int -> (Int -> (Int, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Int
ref (\Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1))
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isLast IO ()
release
            
    f a -> (a -> ResourceT IO a) -> ResourceT IO (f a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM f a
v ((a -> ResourceT IO a) -> ResourceT IO (f a))
-> (a -> ResourceT IO a) -> ResourceT IO (f a)
forall a b. (a -> b) -> a -> b
$ \a
v' -> do 
        IO () -> ResourceT IO ()
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ResourceT IO ()) -> IO () -> ResourceT IO ()
forall a b. (a -> b) -> a -> b
$ a -> IO () -> IO ()
forall key. key -> IO () -> IO ()
addFinalizer a
v' IO ()
finalize
        a -> ResourceT IO a
forall a. a -> ResourceT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v'

-- | Converting to a value in the `Data.Acquire.Acquire` monad, to a raw value.
-- Analagous to calling `unsafePerformIO` to extract a value in the `IO` monad.
-- The same constraints as apply to `unsafePerformIO` apply to this method. 
-- That is, it should only be used on "philosophically pure" actions.
--
-- The `free` action of the resource is called when the underlying value goes out of scope of the Haskell garbage collection,
-- so may run at an unpredictable time.
{-# NOINLINE unsafeFromAcquire #-}
unsafeFromAcquire :: Acquire a -> a 
unsafeFromAcquire :: forall a. Acquire a -> a
unsafeFromAcquire = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> (Acquire a -> IO a) -> Acquire a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Acquire a -> IO a
forall a. Acquire a -> IO a
fromAcquire

-- | Version of `unsafeFromAcquire`  which registers the finalizer on the _value_ in a container 
{-# NOINLINE unsafeFromAcquireT #-}
unsafeFromAcquireT :: (Traversable t) => Acquire (t a)  -> t a 
unsafeFromAcquireT :: forall (t :: * -> *) a. Traversable t => Acquire (t a) -> t a
unsafeFromAcquireT = IO (t a) -> t a
forall a. IO a -> a
unsafePerformIO (IO (t a) -> t a)
-> (Acquire (t a) -> IO (t a)) -> Acquire (t a) -> t a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Acquire (t a) -> IO (t a)
forall (f :: * -> *) a. Traversable f => Acquire (f a) -> IO (f a)
fromAcquireT

-- | Add a pure value (which may or may not have been generated by `unsafeFromAcquire`) back into the Acquire monad. 
-- Using this action _should_ prevent the underlying value from going out of GC scope untill the resource is freed.
toAcquire :: a -> Acquire a
toAcquire :: forall a. a -> Acquire a
toAcquire a
value = IO a -> (a -> IO ()) -> Acquire a
forall a. IO a -> (a -> IO ()) -> Acquire a
mkAcquire (a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
value) a -> IO ()
forall (m :: * -> *) a. PrimMonad m => a -> m ()
touch