module Foreign.Marshal.ContT
(
alloca, allocaWith, allocaBytes, allocaBytesAligned
, calloc, callocBytes
, allocaArray, allocaArrayWith, allocaArrayWithOf
, allocaArray0, allocaArrayWith0, allocaArrayWith0Of
, callocArray, callocArray0
, withForeignPtr
, bracketContT
, ToCString(..)
, CString, CStringLen
, Ptr, nullPtr
, ContT(..)
, lowerContT
, AnIndexedFold
, allocaArrayWith', allocaArrayWithOf'
, iallocaArrayWith', iallocaArrayWithOf'
, allocaArrayWith0', allocaArrayWith0Of'
, iallocaArrayWith0', iallocaArrayWith0Of'
) where
import Control.Exception ( bracket )
import Control.Lens.Fold
import Control.Lens.Getter
import Control.Lens.Indexed
import Control.Lens.Type ( IndexedTraversal, IndexedLens )
import Control.Monad.Cont
import qualified Data.ByteString as BS
import qualified Data.ByteString.Short as SBS
import Data.Foldable ( foldrM )
import Data.Functor ( ($>) )
import qualified Foreign.C.String as C
import Foreign.C.String ( CString, CStringLen )
import qualified Foreign.ForeignPtr as C
import Foreign.ForeignPtr ( ForeignPtr )
import qualified Foreign.Marshal.Alloc as C
import qualified Foreign.Marshal.Array as C
import Foreign.Marshal.Utils ( fillBytes )
import Foreign.Ptr
import Foreign.Storable
lowerContT :: (Monad m) => ContT a m a -> m a
lowerContT (ContT f) = f return
alloca :: Storable a => ContT r IO (Ptr a)
alloca = ContT C.alloca
{-# INLINE alloca #-}
allocaWith :: Storable a => a -> ContT r IO (Ptr a)
allocaWith val = do
ptr <- alloca
liftIO $ poke ptr val
return ptr
{-# INLINE allocaWith #-}
allocaBytes :: forall a r. Int -> ContT r IO (Ptr a)
allocaBytes size = ContT $ C.allocaBytes size
{-# INLINE allocaBytes #-}
allocaBytesAligned :: forall a r. Int -> Int -> ContT r IO (Ptr a)
allocaBytesAligned size align = ContT $ C.allocaBytesAligned size align
{-# INLINE allocaBytesAligned #-}
bracketContT :: (a -> IO b) -> (a -> IO c) -> ContT r IO a -> ContT r IO a
bracketContT init' final = withContT $ \f a ->
bracket (init' a $> a) final f
{-# INLINE bracketContT #-}
calloc :: forall a r. Storable a => ContT r IO (Ptr a)
calloc = do
ptr <- alloca
let size = sizeOf (undefined :: a)
liftIO $ fillBytes ptr 0 size
return ptr
{-# INLINE calloc #-}
callocBytes :: forall a r. Int -> ContT r IO (Ptr a)
callocBytes size = do
ptr <- allocaBytes size
liftIO $ fillBytes ptr 0 size
return ptr
{-# INLINE callocBytes #-}
allocaArray :: Storable a => Int -> ContT r IO (Ptr a)
allocaArray = ContT . C.allocaArray
{-# INLINE allocaArray #-}
allocaArrayWith :: (Foldable f, Storable a) => f a -> ContT r IO (Ptr a)
allocaArrayWith = allocaArrayWith' return
{-# INLINE allocaArrayWith #-}
allocaArrayWith' :: (Foldable f, Storable b)
=> (a -> ContT r IO b)
-> f a -> ContT r IO (Ptr b)
allocaArrayWith' f xs = do
ptr <- allocaArray (length xs)
_ <- foldrM go ptr xs
return ptr
where
go x ptr = do
x' <- f x
liftIO $ poke ptr x'
return (C.advancePtr ptr 1)
{-# INLINE allocaArrayWith' #-}
allocaArrayWithOf :: (Storable a) => Fold s a -> s -> ContT r IO (Ptr a)
allocaArrayWithOf fold = allocaArrayWithOf' fold return
{-# INLINE allocaArrayWithOf #-}
allocaArrayWithOf' :: (Storable b)
=> Fold s a
-> (a -> ContT r IO b)
-> s -> ContT r IO (Ptr b)
allocaArrayWithOf' fold f xs = do
ptr <- allocaArray (lengthOf fold xs)
_ <- foldrMOf fold go ptr xs
return ptr
where
go x ptr = do
x' <- f x
liftIO $ poke ptr x'
return (C.advancePtr ptr 1)
{-# INLINE allocaArrayWithOf' #-}
iallocaArrayWith' :: (FoldableWithIndex i f, Storable b)
=> (i -> a -> ContT r IO b)
-> f a -> ContT r IO (Ptr b)
iallocaArrayWith' f xs = do
ptr <- allocaArray (length xs)
_ <- ifoldrMOf ifolded go ptr xs
return ptr
where
go i x ptr = do
x' <- f i x
liftIO $ poke ptr x'
return (C.advancePtr ptr 1)
{-# INLINE iallocaArrayWith' #-}
type AnIndexedFold i s a = forall m p. (Indexable i p)
=> p a (Const m a)
-> s -> Const m s
iallocaArrayWithOf' :: (Storable b)
=> AnIndexedFold i s a
-> (i -> a -> ContT r IO b)
-> s -> ContT r IO (Ptr b)
iallocaArrayWithOf' fold f xs = do
ptr <- allocaArray (lengthOf fold xs)
_ <- ifoldrMOf fold go ptr xs
return ptr
where
go i x ptr = do
x' <- f i x
liftIO $ poke ptr x'
return (C.advancePtr ptr 1)
{-# INLINE iallocaArrayWithOf' #-}
allocaArray0 :: Storable a => Int -> ContT r IO (Ptr a)
allocaArray0 = ContT . C.allocaArray0
{-# INLINE allocaArray0 #-}
allocaArrayWith0 :: (Foldable f, Storable a)
=> f a -> a -> ContT r IO (Ptr a)
allocaArrayWith0 = allocaArrayWith0' return
{-# INLINE allocaArrayWith0 #-}
allocaArrayWith0' :: (Foldable f, Storable b)
=> (a -> ContT r IO b)
-> f a -> b -> ContT r IO (Ptr b)
allocaArrayWith0' f xs end = do
ptr <- allocaArray (length xs)
endPtr <- foldrMOf folded go ptr xs
liftIO $ poke endPtr end
return ptr
where
go x ptr = do
x' <- f x
liftIO $ poke ptr x'
return (C.advancePtr ptr 1)
{-# INLINE allocaArrayWith0' #-}
allocaArrayWith0Of :: (Storable a) => Fold s a -> s -> a -> ContT r IO (Ptr a)
allocaArrayWith0Of fold = allocaArrayWith0Of' fold return
{-# INLINE allocaArrayWith0Of #-}
allocaArrayWith0Of' :: (Storable b)
=> Fold s a
-> (a -> ContT r IO b)
-> s -> b -> ContT r IO (Ptr b)
allocaArrayWith0Of' fold f xs end = do
ptr <- allocaArray (lengthOf fold xs)
endPtr <- foldrMOf fold go ptr xs
liftIO $ poke endPtr end
return ptr
where
go x ptr = do
x' <- f x
liftIO $ poke ptr x'
return (C.advancePtr ptr 1)
{-# INLINE allocaArrayWith0Of' #-}
iallocaArrayWith0' :: (FoldableWithIndex i f, Storable b)
=> (i -> a -> ContT r IO b)
-> f a -> b -> ContT r IO (Ptr b)
iallocaArrayWith0' f xs end = do
ptr <- allocaArray (length xs)
endPtr <- ifoldrMOf ifolded go ptr xs
liftIO $ poke endPtr end
return ptr
where
go i x ptr = do
x' <- f i x
liftIO $ poke ptr x'
return (C.advancePtr ptr 1)
{-# INLINE iallocaArrayWith0' #-}
iallocaArrayWith0Of' :: (Storable b)
=> AnIndexedFold i s a
-> (i -> a -> ContT r IO b)
-> s -> b -> ContT r IO (Ptr b)
iallocaArrayWith0Of' fold f xs end = do
ptr <- allocaArray (lengthOf fold xs)
endPtr <- ifoldrMOf fold go ptr xs
liftIO $ poke endPtr end
return ptr
where
go i x ptr = do
x' <- f i x
liftIO $ poke ptr x'
return (C.advancePtr ptr 1)
{-# INLINE iallocaArrayWith0Of' #-}
callocArray :: forall a r. Storable a => Int -> ContT r IO (Ptr a)
callocArray len = do
ptr <- allocaArray len
let size = sizeOf (undefined :: a)
liftIO $ fillBytes ptr 0 (len * size)
return ptr
{-# INLINE callocArray #-}
callocArray0 :: forall a r . Storable a => Int -> ContT r IO (Ptr a)
callocArray0 len = do
ptr <- allocaArray0 len
let size = sizeOf (undefined :: a)
liftIO $ fillBytes ptr 0 (len * size)
return ptr
{-# INLINE callocArray0 #-}
withForeignPtr :: ForeignPtr a -> ContT r IO (Ptr a)
withForeignPtr = ContT . C.withForeignPtr
{-# INLINE withForeignPtr #-}
class ToCString a where
withCString :: a -> ContT r IO CString
withCStringLen :: a -> ContT r IO CStringLen
instance ToCString String where
withCString = ContT . C.withCString
{-# INLINE withCString #-}
withCStringLen = ContT . C.withCStringLen
{-# INLINE withCStringLen #-}
instance ToCString BS.ByteString where
withCString = ContT . BS.useAsCString
{-# INLINE withCString #-}
withCStringLen = ContT . BS.useAsCStringLen
{-# INLINE withCStringLen #-}
instance ToCString SBS.ShortByteString where
withCString = ContT . SBS.useAsCString
{-# INLINE withCString #-}
withCStringLen = ContT . SBS.useAsCStringLen
{-# INLINE withCStringLen #-}