diff --git a/cbits/hs_std_string.cpp b/cbits/hs_std_string.cpp new file mode 100644 --- /dev/null +++ b/cbits/hs_std_string.cpp @@ -0,0 +1,37 @@ +#include + +#include +#include + +// ---------------------------------------------------------------------------- +extern "C" { + +HsInt hs_std_string_size(std::string* str) { + if (str) + return (HsInt)str->size(); + else + return 0; +} + +const char* hs_std_string_cstr(std::string* str) { + if (str) + return str->c_str(); + else + return 0; +} + +void hs_copy_std_string(std::string* str, HsInt size, char* buf) { + if (str != NULL) + memcpy(buf, str->c_str(), size); +} + +std::string* hs_new_std_string_def() { return new std::string; } + +std::string* hs_new_std_string(char* s, HsInt length) { + return new std::string(s, length); +} + +void hs_delete_std_string(std::string* str) { delete str; } + +// ---------------------------------------------------------------------------- +} // End extern "C" diff --git a/foreign.cabal b/foreign.cabal --- a/foreign.cabal +++ b/foreign.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: foreign -version: 0.1.0.0 +version: 0.1.1.0 synopsis: A collection of helpers for ffi. description: Please see the README on Github at @@ -46,17 +46,23 @@ library import: common hs-source-dirs: src + cxx-sources: cbits/hs_std_string.cpp exposed-modules: HsForeign HsForeign.AsyncFFI HsForeign.Primitive + HsForeign.String build-depends: , base >=4.14 && <5 + , bytestring >=0.10 && <=0.12 , ghc-prim >=0.5 && <1.0 , primitive ^>=0.7 , primitive-unlifted ^>=1.0 + cxx-options: -std=c++17 -Werror=switch + extra-libraries: stdc++ + test-suite foreign-test import: common type: exitcode-stdio-1.0 @@ -64,14 +70,16 @@ other-modules: HsForeign.AsyncFFISpec HsForeign.PrimitiveSpec + HsForeign.StringSpec hs-source-dirs: test c-sources: test/cbits/ffi.c build-depends: - , base >=4.14 && <5 + , base >=4.14 && <5 , foreign , hspec , QuickCheck + , quickcheck-instances build-tool-depends: hspec-discover:hspec-discover >=2 && <3 ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/src/HsForeign.hs b/src/HsForeign.hs --- a/src/HsForeign.hs +++ b/src/HsForeign.hs @@ -1,7 +1,9 @@ module HsForeign ( module HsForeign.Primitive , module HsForeign.AsyncFFI + , module HsForeign.String ) where import HsForeign.AsyncFFI import HsForeign.Primitive +import HsForeign.String diff --git a/src/HsForeign/Primitive.hs b/src/HsForeign/Primitive.hs --- a/src/HsForeign/Primitive.hs +++ b/src/HsForeign/Primitive.hs @@ -10,6 +10,7 @@ , withPrimUnsafe , allocPrimUnsafe , withPrimArray + , withPrimList , allocPrimArray , withPrimArrayUnsafe , allocPrimArrayUnsafe @@ -125,6 +126,10 @@ withMutablePrimArrayContents buf $ \ptr -> f ptr siz {-# INLINABLE withPrimArray #-} +withPrimList :: Prim a => [a] -> (Ptr a -> Int -> IO b) -> IO b +withPrimList = withPrimArray . primArrayFromList +{-# INLINABLE withPrimList #-} + -- From Z-Data package: Z.Foreign -- -- | Allocate a prim array and pass to FFI as pointer, freeze result into a 'PrimVector'. @@ -195,6 +200,7 @@ withPrimArray pa $ \ ppa _ -> do writePrimArray ptrs i ppa go ptrs (i+1) pas +{-# INLINABLE withPrimArrayList #-} withForeignPtrList :: [ForeignPtr a] -> (Ptr (Ptr a) -> Int -> IO b) -> IO b withForeignPtrList fptrs f = do diff --git a/src/HsForeign/String.hs b/src/HsForeign/String.hs new file mode 100644 --- /dev/null +++ b/src/HsForeign/String.hs @@ -0,0 +1,91 @@ +module HsForeign.String + ( -- * CString + mallocFromByteString + , mallocFromMaybeByteString + , withByteString + , withByteStrings + + -- * CXX: std::string + , StdString + , hs_new_std_string + , hs_new_std_string_def + , hs_std_string_size + , hs_std_string_cstr + , hs_delete_std_string + , unsafePeekStdString + ) where + +import Control.Exception (AssertionFailed (..), throw) +import Control.Monad (unless) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Unsafe as BS +import Data.Word +import Foreign.C.String +import Foreign.ForeignPtr +import Foreign.Marshal +import Foreign.Ptr + +import HsForeign.Primitive + +------------------------------------------------------------------------------- +-- CString + +-- | Copies the content of the given ByteString. +-- +-- The memory may be deallocated using free or finalizerFree when no longer +-- required. +mallocFromByteString :: ByteString -> IO (CString, Int) +mallocFromByteString bs = + BS.unsafeUseAsCStringLen bs $ \(src, len) -> do + buf <- mallocBytes len + copyBytes buf src len + return (buf, len) +{-# INLINE mallocFromByteString #-} + +mallocFromMaybeByteString :: Maybe ByteString -> IO (CString, Int) +mallocFromMaybeByteString (Just bs) = mallocFromByteString bs +mallocFromMaybeByteString Nothing = return (nullPtr, 0) +{-# INLINE mallocFromMaybeByteString #-} + +withByteString :: ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a +withByteString (BS.PS fp off len) f = + -- TODO: since bytestring 0.11.0.0, it exports the 'BS' constructor. + -- we can change to benefit from the simplified BS constructor if we only + -- support bytestring >= 0.11 + let fp' = fp `plusForeignPtr` off + in withForeignPtr fp' $ \p -> f p len + +-- | Pass list of ByteStrings to FFI. +withByteStrings + :: [ByteString] + -> (Ptr (Ptr Word8) -> Ptr Int -> Ptr Int -> Int -> IO a) + -- ^ cstring*, offset*, len*, list_len + -> IO a +withByteStrings bss f = do + let exbs (BS.PS payload off len) = (payload, fromIntegral off, fromIntegral len) + (ps, offs, lens) = unzip3 (map exbs bss) + withPrimArray (primArrayFromList lens) $ \lens' num -> + withPrimArray (primArrayFromList offs) $ \offs' _num_offs -> + withForeignPtrList ps $ \ps' _num_ps -> do + unless (num == _num_offs && num == _num_ps) $ throw $ + AssertionFailed "This should never happen..." + f ps' offs' lens' num + +------------------------------------------------------------------------------- +-- std::string + +data StdString + +foreign import ccall unsafe hs_new_std_string :: Ptr Word8 -> Int -> IO (Ptr StdString) +foreign import ccall unsafe hs_new_std_string_def :: IO (Ptr StdString) +foreign import ccall unsafe hs_std_string_size :: Ptr StdString -> IO Int +foreign import ccall unsafe hs_std_string_cstr :: Ptr StdString -> IO (Ptr Word8) +foreign import ccall unsafe hs_delete_std_string :: Ptr StdString -> IO () + +unsafePeekStdString :: Ptr StdString -> IO ByteString +unsafePeekStdString stdstring = do + siz <- hs_std_string_size stdstring + ptr <- hs_std_string_cstr stdstring + BS.unsafePackCStringFinalizer ptr siz (hs_delete_std_string stdstring) +{-# INLINE unsafePeekStdString #-} diff --git a/test/HsForeign/StringSpec.hs b/test/HsForeign/StringSpec.hs new file mode 100644 --- /dev/null +++ b/test/HsForeign/StringSpec.hs @@ -0,0 +1,18 @@ +module HsForeign.StringSpec (spec) where + +import System.IO.Unsafe (unsafeDupablePerformIO) +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Test.QuickCheck.Instances.ByteString () + +import HsForeign.String + +spec :: Spec +spec = describe "StdString" $ do + prop "unsafePeekStdString" $ \s -> + -- 1. withByteString does nothing but pass the underlying ptr + -- 2. hs_new_std_string copy construct a new std::string + -- 3. unsafePeekStdString peek the std::string with a delete finalizer. + let f = unsafePeekStdString =<< (withByteString s $ \p l -> hs_new_std_string p l) + in unsafeDupablePerformIO f === s