cinvoke-0.1: Foreign/TreePtr.hs

{- | No Child Left Behind -
    Pointers that won't be freed until all its children have been freed -}
module Foreign.TreePtr (
    TreePtr,
    newTreePtr,
    addNode,
    addLeaf,
    nodePtr,
    withTreePtr,
) where

import Control.Monad
import Foreign.Ptr
import Foreign.ForeignPtr hiding (newForeignPtr, addForeignPtrFinalizer)
import Foreign.Concurrent

import Data.RefCount

data TreePtr a = TreePtr !RefCount !(ForeignPtr a)

instance Show (TreePtr a) where
    showsPrec p (TreePtr _ fp) = showsPrec p fp

newTreePtr :: Ptr a -> IO () -> IO (TreePtr a)
newTreePtr ptr free = do
    refCnt <- newRefCount free
    liftM (TreePtr refCnt)
        $ newForeignPtr ptr
            $ decRefCount refCnt

addWith f ptr free (TreePtr refCnt _) = do
    incRefCount refCnt
    f ptr $ do
        free
        decRefCount refCnt

addNode :: Ptr a -> IO () -> TreePtr b -> IO (TreePtr a)
addNode = addWith newTreePtr

addLeaf :: Ptr a -> IO () -> TreePtr b -> IO (ForeignPtr a)
addLeaf = addWith newForeignPtr

nodePtr :: TreePtr a -> ForeignPtr a
nodePtr (TreePtr _ fp) = fp

withTreePtr :: TreePtr a -> (Ptr a -> IO b) -> IO b
withTreePtr = withForeignPtr . nodePtr