module Foreign.Marshal.ContT
(
alloca, allocaWith, allocaBytes, allocaBytesAligned
, calloc, callocBytes
, allocaArray, allocaArrayWith, allocaArrayWithOf
, allocaArray0, allocaArrayWith0, allocaArrayWith0Of
, callocArray, callocArray0
, withForeignPtr
, ToCString(..)
, AnIndexedFold
, allocaArrayWith', allocaArrayWithOf'
, iallocaArrayWith', iallocaArrayWithOf'
, allocaArrayWith0', allocaArrayWith0Of'
, iallocaArrayWith0', iallocaArrayWith0Of'
) where
import Control.Lens.Fold
import Control.Lens.Getter
import Control.Lens.Indexed
import Control.Monad.Cont
import qualified Data.ByteString as BS
import qualified Data.ByteString.Short as SBS
import Data.Foldable ( foldrM )
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.Ptr
import Foreign.Storable
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
allocaBytes :: Int -> ContT r IO (Ptr a)
allocaBytes size = ContT $ C.allocaBytes size
{-# INLINE allocaBytes #-}
allocaBytesAligned :: Int -> Int -> ContT r IO (Ptr a)
allocaBytesAligned size align = ContT $ C.allocaBytesAligned size align
{-# INLINE allocaBytesAligned #-}
calloc :: forall r a. Storable a => ContT r IO (Ptr a)
calloc = ContT $ \f -> do
ptr <- C.calloc
out <- f ptr
C.free ptr
return out
{-# INLINE calloc #-}
callocBytes :: Int -> ContT r IO (Ptr a)
callocBytes size = ContT $ \f -> do
ptr <- C.callocBytes size
out <- f ptr
C.free ptr
return out
{-# 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 -> ContT r IO (Ptr a)
allocaArrayWith0Of fold = allocaArrayWithOf' 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 :: Storable a => Int -> ContT r IO (Ptr a)
callocArray len = ContT $ \f -> do
ptr <- C.callocArray len
out <- f ptr
C.free ptr
return out
{-# INLINE callocArray #-}
callocArray0 :: Storable a => Int -> ContT r IO (Ptr a)
callocArray0 len = ContT $ \f -> do
ptr <- C.callocArray0 len
out <- f ptr
C.free ptr
return out
{-# 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 #-}