{-# LANGUAGE BangPatterns    #-}
{-# LANGUAGE CPP             #-}
{-# LANGUAGE MagicHash       #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TupleSections   #-}

module HsForeign.String
  ( mallocFromByteString
  , mallocFromMaybeByteString
  , newStablePtrByteString
  , withByteString
  , withMaybeByteString
  , withByteStringList
  , withByteStrings
  , withShortByteString
  ) where

import           Control.Exception              (AssertionFailed (..), throw)
import           Control.Monad                  (unless)
import           Data.ByteString                (ByteString)
import qualified Data.ByteString.Internal       as BS
import           Data.ByteString.Short          (ShortByteString)
import qualified Data.ByteString.Short.Internal as BSS
import qualified Data.ByteString.Unsafe         as BS
import           Data.Word
import           Foreign.C.String
import           Foreign.ForeignPtr
import           Foreign.ForeignPtr.Unsafe
import           Foreign.Marshal
import           Foreign.Ptr
import           Foreign.StablePtr
import           GHC.Exts                       (touch#)

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 :: ByteString -> IO (CString, Int)
mallocFromByteString ByteString
bs =
  ByteString
-> ((CString, Int) -> IO (CString, Int)) -> IO (CString, Int)
forall a. ByteString -> ((CString, Int) -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
bs (((CString, Int) -> IO (CString, Int)) -> IO (CString, Int))
-> ((CString, Int) -> IO (CString, Int)) -> IO (CString, Int)
forall a b. (a -> b) -> a -> b
$ \(CString
src, Int
len) -> do
    CString
buf <- Int -> IO CString
forall a. Int -> IO (Ptr a)
mallocBytes Int
len
    CString -> CString -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes CString
buf CString
src Int
len
    (CString, Int) -> IO (CString, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (CString
buf, Int
len)
{-# INLINE mallocFromByteString #-}

mallocFromMaybeByteString :: Maybe ByteString -> IO (CString, Int)
mallocFromMaybeByteString :: Maybe ByteString -> IO (CString, Int)
mallocFromMaybeByteString (Just ByteString
bs) = ByteString -> IO (CString, Int)
mallocFromByteString ByteString
bs
mallocFromMaybeByteString Maybe ByteString
Nothing   = (CString, Int) -> IO (CString, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (CString
forall a. Ptr a
nullPtr, Int
0)
{-# INLINE mallocFromMaybeByteString #-}

newStablePtrByteString :: ByteString -> IO (CString, Int, StablePtr ByteString)
newStablePtrByteString :: ByteString -> IO (CString, Int, StablePtr ByteString)
newStablePtrByteString ByteString
bs = do
  !StablePtr ByteString
sp <- ByteString -> IO (StablePtr ByteString)
forall a. a -> IO (StablePtr a)
newStablePtr ByteString
bs
  let (ForeignPtr Word8
fp, Int
len) = ByteString -> (ForeignPtr Word8, Int)
toForeignPtr0 ByteString
bs
      !p :: Ptr Word8
p = ForeignPtr Word8 -> Ptr Word8
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr Word8
fp
  (CString, Int, StablePtr ByteString)
-> IO (CString, Int, StablePtr ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ptr Word8 -> CString
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
p, Int
len, StablePtr ByteString
sp)

withByteString :: ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a
withByteString :: ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a
withByteString ByteString
bs Ptr Word8 -> Int -> IO a
f =
  let (ForeignPtr Word8
fp, Int
len) = ByteString -> (ForeignPtr Word8, Int)
toForeignPtr0 ByteString
bs
   in ForeignPtr Word8 -> (Ptr Word8 -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO a) -> IO a) -> (Ptr Word8 -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> Ptr Word8 -> Int -> IO a
f Ptr Word8
p Int
len
{-# INLINABLE withByteString #-}

withMaybeByteString :: Maybe ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a
withMaybeByteString :: Maybe ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a
withMaybeByteString Maybe ByteString
Nothing Ptr Word8 -> Int -> IO a
f = Ptr Word8 -> Int -> IO a
f Ptr Word8
forall a. Ptr a
nullPtr Int
0
withMaybeByteString (Just ByteString
bs) Ptr Word8 -> Int -> IO a
f =
  let (ForeignPtr Word8
fp, Int
len) = ByteString -> (ForeignPtr Word8, Int)
toForeignPtr0 ByteString
bs
   in ForeignPtr Word8 -> (Ptr Word8 -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO a) -> IO a) -> (Ptr Word8 -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> Ptr Word8 -> Int -> IO a
f Ptr Word8
p Int
len
{-# INLINABLE withMaybeByteString #-}

-- | Pass list of ByteStrings to FFI.
withByteStringList
  :: [ByteString]
  -> (Ptr (Ptr Word8) -> Ptr Int -> Int -> IO a)
  -- ^ cstring*, len*, list_len
  -> IO a
withByteStringList :: [ByteString] -> (Ptr (Ptr Word8) -> Ptr Int -> Int -> IO a) -> IO a
withByteStringList [ByteString]
bss Ptr (Ptr Word8) -> Ptr Int -> Int -> IO a
f = do
  let ([ForeignPtr Word8]
ps, [Int]
lens) = [(ForeignPtr Word8, Int)] -> ([ForeignPtr Word8], [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip ((ByteString -> (ForeignPtr Word8, Int))
-> [ByteString] -> [(ForeignPtr Word8, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> (ForeignPtr Word8, Int)
toForeignPtr0 [ByteString]
bss)
  PrimArray Int -> (Ptr Int -> Int -> IO a) -> IO a
forall a b. Prim a => PrimArray a -> (Ptr a -> Int -> IO b) -> IO b
withPrimArray ([Int] -> PrimArray Int
forall a. Prim a => [a] -> PrimArray a
primArrayFromList [Int]
lens) ((Ptr Int -> Int -> IO a) -> IO a)
-> (Ptr Int -> Int -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr Int
lens' Int
num ->
    [ForeignPtr Word8] -> (Ptr (Ptr Word8) -> Int -> IO a) -> IO a
forall a b. [ForeignPtr a] -> (Ptr (Ptr a) -> Int -> IO b) -> IO b
withForeignPtrList [ForeignPtr Word8]
ps ((Ptr (Ptr Word8) -> Int -> IO a) -> IO a)
-> (Ptr (Ptr Word8) -> Int -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr Word8)
ps' Int
num_ps -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
num Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
num_ps) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ AssertionFailed -> IO ()
forall a e. Exception e => e -> a
throw (AssertionFailed -> IO ()) -> AssertionFailed -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> AssertionFailed
AssertionFailed String
"This should never happen..."
      Ptr (Ptr Word8) -> Ptr Int -> Int -> IO a
f Ptr (Ptr Word8)
ps' Ptr Int
lens' Int
num

{-# DEPRECATED withByteStrings "use withByteStringList instead" #-}
-- | 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 :: [ByteString]
-> (Ptr (Ptr Word8) -> Ptr Int -> Ptr Int -> Int -> IO a) -> IO a
withByteStrings [ByteString]
bss Ptr (Ptr Word8) -> Ptr Int -> Ptr Int -> Int -> IO a
f = do
  let exbs :: ByteString -> (ForeignPtr Word8, b, c)
exbs (BS.PS ForeignPtr Word8
payload Int
off Int
len) = (ForeignPtr Word8
payload, Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off, Int -> c
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
      ([ForeignPtr Word8]
ps, [Int]
offs, [Int]
lens) = [(ForeignPtr Word8, Int, Int)]
-> ([ForeignPtr Word8], [Int], [Int])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ((ByteString -> (ForeignPtr Word8, Int, Int))
-> [ByteString] -> [(ForeignPtr Word8, Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> (ForeignPtr Word8, Int, Int)
forall b c.
(Num b, Num c) =>
ByteString -> (ForeignPtr Word8, b, c)
exbs [ByteString]
bss)
  PrimArray Int -> (Ptr Int -> Int -> IO a) -> IO a
forall a b. Prim a => PrimArray a -> (Ptr a -> Int -> IO b) -> IO b
withPrimArray ([Int] -> PrimArray Int
forall a. Prim a => [a] -> PrimArray a
primArrayFromList [Int]
lens) ((Ptr Int -> Int -> IO a) -> IO a)
-> (Ptr Int -> Int -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr Int
lens' Int
num ->
    PrimArray Int -> (Ptr Int -> Int -> IO a) -> IO a
forall a b. Prim a => PrimArray a -> (Ptr a -> Int -> IO b) -> IO b
withPrimArray ([Int] -> PrimArray Int
forall a. Prim a => [a] -> PrimArray a
primArrayFromList [Int]
offs) ((Ptr Int -> Int -> IO a) -> IO a)
-> (Ptr Int -> Int -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr Int
offs' Int
_num_offs ->
    [ForeignPtr Word8] -> (Ptr (Ptr Word8) -> Int -> IO a) -> IO a
forall a b. [ForeignPtr a] -> (Ptr (Ptr a) -> Int -> IO b) -> IO b
withForeignPtrList [ForeignPtr Word8]
ps ((Ptr (Ptr Word8) -> Int -> IO a) -> IO a)
-> (Ptr (Ptr Word8) -> Int -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr Word8)
ps' Int
_num_ps -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
num Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
_num_offs Bool -> Bool -> Bool
&& Int
num Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
_num_ps) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ AssertionFailed -> IO ()
forall a e. Exception e => e -> a
throw (AssertionFailed -> IO ()) -> AssertionFailed -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> AssertionFailed
AssertionFailed String
"This should never happen..."
      Ptr (Ptr Word8) -> Ptr Int -> Ptr Int -> Int -> IO a
f Ptr (Ptr Word8)
ps' Ptr Int
offs' Ptr Int
lens' Int
num

withShortByteString :: ShortByteString -> (ByteArray# -> Int -> IO a) -> IO a
withShortByteString :: ShortByteString -> (ByteArray# -> Int -> IO a) -> IO a
withShortByteString sbs :: ShortByteString
sbs@(BSS.SBS ByteArray#
ba#) ByteArray# -> Int -> IO a
f = do
  !a
r <- ByteArray# -> Int -> IO a
f ByteArray#
ba# (ShortByteString -> Int
BSS.length ShortByteString
sbs)
  (State# (PrimState IO) -> State# (PrimState IO)) -> IO ()
forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
primitive_ ((State# (PrimState IO) -> State# (PrimState IO)) -> IO ())
-> (State# (PrimState IO) -> State# (PrimState IO)) -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteArray# -> State# RealWorld -> State# RealWorld
forall a. a -> State# RealWorld -> State# RealWorld
touch# ByteArray#
ba#
  a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r

-------------------------------------------------------------------------------

-- TODO: since bytestring 0.11.0.0, it exports the 'BS' constructor and
-- 'toForeignPtr0'.
--
-- we can change to benefit from the simplified BS constructor if we only
-- support bytestring >= 0.11
toForeignPtr0 :: ByteString -> (ForeignPtr Word8, Int)
#if !MIN_VERSION_bytestring(0, 11, 0)
toForeignPtr0 :: ByteString -> (ForeignPtr Word8, Int)
toForeignPtr0 (BS.PS ForeignPtr Word8
fp Int
off Int
len) = (ForeignPtr Word8
fp ForeignPtr Word8 -> Int -> ForeignPtr Word8
forall a b. ForeignPtr a -> Int -> ForeignPtr b
`plusForeignPtr` Int
off, Int
len)
#else
toForeignPtr0 = BS.toForeignPtr0
#endif