module Foreign.Marshal.Codensity
(
alloca, allocaWith, allocaBytes, allocaBytesAligned
, calloc, callocBytes
, allocaArray, allocaArrayWith, allocaArrayWithOf
, allocaArray0, allocaArrayWith0, allocaArrayWith0Of
, callocArray, callocArray0
, withForeignPtr
, bracketCodensity
, ToCString(..)
, CString, CStringLen
, Ptr, nullPtr
, Codensity(..)
, lowerCodensity
, AnIndexedFold
, allocaArrayWith', allocaArrayWithOf'
, iallocaArrayWith', iallocaArrayWithOf'
, allocaArrayWith0', allocaArrayWith0Of'
, iallocaArrayWith0', iallocaArrayWith0Of'
) where
import Control.Exception ( finally )
import Control.Lens.Fold
import Control.Lens.Getter
import Control.Lens.Indexed
import Control.Lens.Type ( IndexedTraversal, IndexedLens )
import Control.Monad.Codensity
import Control.Monad.IO.Class
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
alloca :: Storable a => Codensity IO (Ptr a)
alloca = Codensity C.alloca
{-# INLINE alloca #-}
allocaWith :: Storable a => a -> Codensity IO (Ptr a)
allocaWith val = do
ptr <- alloca
liftIO $ poke ptr val
return ptr
{-# INLINE allocaWith #-}
allocaBytes :: Int -> Codensity IO (Ptr a)
allocaBytes size = Codensity $ C.allocaBytes size
{-# INLINE allocaBytes #-}
allocaBytesAligned :: Int -> Int -> Codensity IO (Ptr a)
allocaBytesAligned size align = Codensity $ C.allocaBytesAligned size align
{-# INLINE allocaBytesAligned #-}
bracketCodensity :: (a -> IO b) -> (a -> IO c) -> Codensity IO a -> Codensity IO a
bracketCodensity init' final m = do
a <- m
liftIO $ init' a
wrapCodensity (`finally` final a)
return a
{-# INLINE bracketCodensity #-}
calloc :: forall a. Storable a => Codensity IO (Ptr a)
calloc = do
ptr <- alloca
let size = sizeOf (undefined :: a)
liftIO $ fillBytes ptr 0 size
return ptr
{-# INLINE calloc #-}
callocBytes :: Int -> Codensity IO (Ptr a)
callocBytes size = do
ptr <- allocaBytes size
liftIO $ fillBytes ptr 0 size
return ptr
{-# INLINE callocBytes #-}
allocaArray :: Storable a => Int -> Codensity IO (Ptr a)
allocaArray size = Codensity (C.allocaArray size)
{-# INLINE allocaArray #-}
allocaArrayWith :: (Foldable f, Storable a) => f a -> Codensity IO (Ptr a)
allocaArrayWith = allocaArrayWith' return
{-# INLINE allocaArrayWith #-}
allocaArrayWith' :: (Foldable f, Storable b)
=> (a -> Codensity IO b)
-> f a -> Codensity 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 -> Codensity IO (Ptr a)
allocaArrayWithOf fold = allocaArrayWithOf' fold return
{-# INLINE allocaArrayWithOf #-}
allocaArrayWithOf' :: (Storable b)
=> Fold s a
-> (a -> Codensity IO b)
-> s -> Codensity 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 -> Codensity IO b)
-> f a -> Codensity 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 -> Codensity IO b)
-> s -> Codensity 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 -> Codensity IO (Ptr a)
allocaArray0 len = Codensity (C.allocaArray0 len)
{-# INLINE allocaArray0 #-}
allocaArrayWith0 :: (Foldable f, Storable a)
=> f a -> a -> Codensity IO (Ptr a)
allocaArrayWith0 = allocaArrayWith0' return
{-# INLINE allocaArrayWith0 #-}
allocaArrayWith0' :: (Foldable f, Storable b)
=> (a -> Codensity IO b)
-> f a -> b -> Codensity 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 -> Codensity IO (Ptr a)
allocaArrayWith0Of fold = allocaArrayWith0Of' fold return
{-# INLINE allocaArrayWith0Of #-}
allocaArrayWith0Of' :: (Storable b)
=> Fold s a
-> (a -> Codensity IO b)
-> s -> b -> Codensity 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 -> Codensity IO b)
-> f a -> b -> Codensity 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 -> Codensity IO b)
-> s -> b -> Codensity 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 . Storable a => Int -> Codensity 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 . Storable a => Int -> Codensity 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 -> Codensity IO (Ptr a)
withForeignPtr ptr = Codensity (C.withForeignPtr ptr)
{-# INLINE withForeignPtr #-}
class ToCString a where
withCString :: a -> Codensity IO CString
withCStringLen :: a -> Codensity IO CStringLen
instance ToCString String where
withCString s = Codensity (C.withCString s)
{-# INLINE withCString #-}
withCStringLen s = Codensity (C.withCStringLen s)
{-# INLINE withCStringLen #-}
instance ToCString BS.ByteString where
withCString s = Codensity (BS.useAsCString s)
{-# INLINE withCString #-}
withCStringLen s = Codensity (BS.useAsCStringLen s)
{-# INLINE withCStringLen #-}
instance ToCString SBS.ShortByteString where
withCString s = Codensity (SBS.useAsCString s)
{-# INLINE withCString #-}
withCStringLen s = Codensity (SBS.useAsCStringLen s)
{-# INLINE withCStringLen #-}