diff --git a/cbits/hs_cpp_std.cpp b/cbits/hs_cpp_std.cpp new file mode 100644 --- /dev/null +++ b/cbits/hs_cpp_std.cpp @@ -0,0 +1,84 @@ +#include + +#include +#include +#include + +#define CAL_OFFSET(NAME, VAL_TYPE) \ + VAL_TYPE* cal_offset_##NAME(VAL_TYPE* current, HsInt offset) { \ + return current + offset; \ + } + +#define GET_SIZE(NAME, TYPE) \ + HsInt get_size_##NAME(const TYPE* t) { return (t) ? t->size() : 0; } + +#define PEEK_VECTOR(NAME, VEC_TYPE, VAL_TYPE) \ + void peek_##NAME(const VEC_TYPE* vec, HsInt len, VAL_TYPE* vals) { \ + assert(("peek_##NAME: size mismatch!", len == vec->size())); \ + for (int i = 0; i < len; i++) { \ + (vals)[i] = (*vec)[i]; \ + } \ + } + +// ---------------------------------------------------------------------------- +extern "C" { + +// std::string + +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); +} + +std::string* hs_new_std_string_copy(std::string&& str) { + auto value = new std::string; + *value = str; + return value; +} + +void hs_delete_std_string(std::string* str) { delete str; } + +// std::vector + +GET_SIZE(vec_of_string, std::vector) + +HsInt hs_std_vector_string_size(std::vector* v) { + if (v) + return (HsInt)v->size(); + else + return 0; +} + +std::string* hs_std_vector_string_data(std::vector* v) { + if (v) + return v->data(); + else + return nullptr; +} + +void hs_delete_std_vector_string(std::vector* v) { delete v; } + +// ---------------------------------------------------------------------------- +} // End extern "C" + +#undef GET_SIZE diff --git a/cbits/hs_std_string.cpp b/cbits/hs_std_string.cpp deleted file mode 100644 --- a/cbits/hs_std_string.cpp +++ /dev/null @@ -1,37 +0,0 @@ -#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.2.0 +version: 0.2.0.0 synopsis: A collection of helpers for ffi. description: Please see the README on Github at @@ -10,13 +10,14 @@ copyright: Copyright (c) author: mu maintainer: mu@laxcat.xyz -tested-with: GHC ==8.10.7 +tested-with: GHC ==8.10.7 || ==9.2.5 category: Foreign homepage: https://github.com/4eUeP/foreign bug-reports: https://github.com/4eUeP/foreign/issues build-type: Simple extra-source-files: ChangeLog.md + include/**/*.h README.md source-repository head @@ -46,20 +47,25 @@ library import: common hs-source-dirs: src - cxx-sources: cbits/hs_std_string.cpp + include-dirs: include + cxx-sources: cbits/hs_cpp_std.cpp + includes: hs_foreign.h exposed-modules: HsForeign HsForeign.AsyncFFI + HsForeign.CppStd HsForeign.Primitive HsForeign.String HsForeign.Utils + -- We need to use primitive-unlifted < 1.0 to support ghc-9.* + -- See: https://gitlab.haskell.org/ghc/ghc/-/issues/20908 build-depends: - , base >=4.14 && <5 - , bytestring >=0.10 && <=0.12 - , ghc-prim >=0.5 && <1.0 + , base >=4.14 && <5 + , bytestring >=0.10 && <0.12.0 + , ghc-prim >=0.5 && <1.0 , primitive ^>=0.7 - , primitive-unlifted ^>=1.0 + , primitive-unlifted >=0.1.3.1 && <0.2 cxx-options: -std=c++17 -Werror=switch extra-libraries: stdc++ diff --git a/include/hs_foreign.h b/include/hs_foreign.h new file mode 100644 --- /dev/null +++ b/include/hs_foreign.h @@ -0,0 +1,15 @@ +#pragma once + +// ---------------------------------------------------------------------------- + +#ifdef __cplusplus +extern "C" { +#endif +// ---------------------------------------------------------------------------- + + + +// ---------------------------------------------------------------------------- +#ifdef __cplusplus +} /* end extern "C" */ +#endif diff --git a/src/HsForeign/CppStd.hs b/src/HsForeign/CppStd.hs new file mode 100644 --- /dev/null +++ b/src/HsForeign/CppStd.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE MagicHash #-} + +module HsForeign.CppStd + ( -- * StdString + StdString + , newStdString + , maybeNewStdString + , hs_new_std_string + , hs_new_std_string_def + , hs_std_string_size + , hs_std_string_cstr + , hs_delete_std_string + , unsafePeekStdString + -- * StdVector + , StdVector + + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Unsafe as BS +import Data.Word +import Foreign.Ptr + +import HsForeign.String (withByteString) + +------------------------------------------------------------------------------- +-- StdString + +data StdString + +-- | New a c++ std::string from proviced bytestring. +-- +-- The memory should be deallocated using delete when no longer required. +newStdString :: ByteString -> IO (Ptr StdString) +newStdString bs = withByteString bs $ hs_new_std_string + +maybeNewStdString :: Maybe ByteString -> IO (Ptr StdString) +maybeNewStdString Nothing = pure nullPtr +maybeNewStdString (Just bs) = newStdString bs + +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 #-} + +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 () + +------------------------------------------------------------------------------- +-- StdVector + +data StdVector a + +peekStdVectorOfString :: Ptr (StdVector StdString) -> [ByteString] +peekStdVectorOfString = undefined diff --git a/src/HsForeign/String.hs b/src/HsForeign/String.hs --- a/src/HsForeign/String.hs +++ b/src/HsForeign/String.hs @@ -5,8 +5,7 @@ {-# LANGUAGE TupleSections #-} module HsForeign.String - ( -- * CString - mallocFromByteString + ( mallocFromByteString , mallocFromMaybeByteString , newStablePtrByteString , withByteString @@ -14,17 +13,6 @@ , withByteStringList , withByteStrings , withShortByteString - - -- * CXX: std::string - , StdString - , newStdString - , maybeNewStdString - , 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) @@ -121,34 +109,6 @@ !r <- f ba# (BSS.length sbs) primitive_ $ touch# ba# pure r - -------------------------------------------------------------------------------- --- 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 () - --- | New a c++ std::string from proviced bytestring. --- --- The memory should be deallocated using delete when no longer required. -newStdString :: ByteString -> IO (Ptr StdString) -newStdString bs = withByteString bs $ hs_new_std_string - -maybeNewStdString :: Maybe ByteString -> IO (Ptr StdString) -maybeNewStdString Nothing = pure nullPtr -maybeNewStdString (Just bs) = newStdString bs - -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 --- a/test/HsForeign/StringSpec.hs +++ b/test/HsForeign/StringSpec.hs @@ -6,13 +6,15 @@ import Test.QuickCheck import Test.QuickCheck.Instances.ByteString () +import HsForeign.CppStd 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 +spec = do + 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