{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UnboxedTuples #-}

module Data.ByteString.Short.Internal
  ( create
  , asBA
  , BA(..)
  , MBA(..)
  , newPinnedByteArray
  , newByteArray
  , copyByteArray
  , unsafeFreezeByteArray
  , useAsCString
  , useAsCStringLen
  , useAsCWString
  , useAsCWStringLen
  , packCString
  , packCStringLen
  , packCWString
  , packCWStringLen
  , newCWString
  )

where

import Prelude hiding
    ( length )
import GHC.Exts
import GHC.ST
    ( ST (ST), runST )
import Data.Word
import Foreign.C.String hiding (newCWString)
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Marshal.Array (mallocArray0)
import Foreign.Storable (pokeByteOff)
import "bytestring" Data.ByteString.Short.Internal
import Control.Exception ( throwIO )
#if MIN_VERSION_bytestring(0,10,9)
import Data.ByteString.Internal (c_strlen)
#else
import Foreign.C.Types
#endif


create :: Int -> (forall s. MBA s -> ST s ()) -> ShortByteString
create :: Int -> (forall s. MBA s -> ST s ()) -> ShortByteString
create Int
len forall s. MBA s -> ST s ()
fill =
    (forall s. ST s ShortByteString) -> ShortByteString
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s ShortByteString) -> ShortByteString)
-> (forall s. ST s ShortByteString) -> ShortByteString
forall a b. (a -> b) -> a -> b
$ do
      MBA s
mba <- Int -> ST s (MBA s)
forall s. Int -> ST s (MBA s)
newByteArray Int
len
      MBA s -> ST s ()
forall s. MBA s -> ST s ()
fill MBA s
mba
      BA# ByteArray#
ba# <- MBA s -> ST s BA
forall s. MBA s -> ST s BA
unsafeFreezeByteArray MBA s
mba
      ShortByteString -> ST s ShortByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteArray# -> ShortByteString
SBS ByteArray#
ba#)
{-# INLINE create #-}


asBA :: ShortByteString -> BA
asBA :: ShortByteString -> BA
asBA (SBS ByteArray#
ba#) = ByteArray# -> BA
BA# ByteArray#
ba#



data BA    = BA# ByteArray#
data MBA s = MBA# (MutableByteArray# s)


newPinnedByteArray :: Int -> ST s (MBA s)
newPinnedByteArray :: Int -> ST s (MBA s)
newPinnedByteArray (I# Int#
len#) =
    STRep s (MBA s) -> ST s (MBA s)
forall s a. STRep s a -> ST s a
ST (STRep s (MBA s) -> ST s (MBA s))
-> STRep s (MBA s) -> ST s (MBA s)
forall a b. (a -> b) -> a -> b
$ \State# s
s -> case Int# -> State# s -> (# State# s, MutableByteArray# s #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newPinnedByteArray# Int#
len# State# s
s of
                 (# State# s
s', MutableByteArray# s
mba# #) -> (# State# s
s', MutableByteArray# s -> MBA s
forall s. MutableByteArray# s -> MBA s
MBA# MutableByteArray# s
mba# #)

newByteArray :: Int -> ST s (MBA s)
newByteArray :: Int -> ST s (MBA s)
newByteArray (I# Int#
len#) =
    STRep s (MBA s) -> ST s (MBA s)
forall s a. STRep s a -> ST s a
ST (STRep s (MBA s) -> ST s (MBA s))
-> STRep s (MBA s) -> ST s (MBA s)
forall a b. (a -> b) -> a -> b
$ \State# s
s -> case Int# -> State# s -> (# State# s, MutableByteArray# s #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# Int#
len# State# s
s of
                 (# State# s
s', MutableByteArray# s
mba# #) -> (# State# s
s', MutableByteArray# s -> MBA s
forall s. MutableByteArray# s -> MBA s
MBA# MutableByteArray# s
mba# #)

copyByteArray :: BA -> Int -> MBA s -> Int -> Int -> ST s ()
copyByteArray :: BA -> Int -> MBA s -> Int -> Int -> ST s ()
copyByteArray (BA# ByteArray#
src#) (I# Int#
src_off#) (MBA# MutableByteArray# s
dst#) (I# Int#
dst_off#) (I# Int#
len#) =
    STRep s () -> ST s ()
forall s a. STRep s a -> ST s a
ST (STRep s () -> ST s ()) -> STRep s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ \State# s
s -> case ByteArray#
-> Int#
-> MutableByteArray# s
-> Int#
-> Int#
-> State# s
-> State# s
forall d.
ByteArray#
-> Int#
-> MutableByteArray# d
-> Int#
-> Int#
-> State# d
-> State# d
copyByteArray# ByteArray#
src# Int#
src_off# MutableByteArray# s
dst# Int#
dst_off# Int#
len# State# s
s of
                 State# s
s' -> (# State# s
s', () #)

unsafeFreezeByteArray :: MBA s -> ST s BA
unsafeFreezeByteArray :: MBA s -> ST s BA
unsafeFreezeByteArray (MBA# MutableByteArray# s
mba#) =
    STRep s BA -> ST s BA
forall s a. STRep s a -> ST s a
ST (STRep s BA -> ST s BA) -> STRep s BA -> ST s BA
forall a b. (a -> b) -> a -> b
$ \State# s
s -> case MutableByteArray# s -> State# s -> (# State# s, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# s
mba# State# s
s of
                 (# State# s
s', ByteArray#
ba# #) -> (# State# s
s', ByteArray# -> BA
BA# ByteArray#
ba# #)


-- this is a copy-paste from bytestring
#if !MIN_VERSION_bytestring(0,10,9)
------------------------------------------------------------------------
-- Primop replacements

-- ---------------------------------------------------------------------
--
-- Standard C functions
--

foreign import ccall unsafe "string.h strlen" c_strlen
    :: CString -> IO CSize


-- ---------------------------------------------------------------------
--
-- Uses our C code
--

-- | /O(n)./ Construct a new @ShortByteString@ from a @CString@. The
-- resulting @ShortByteString@ is an immutable copy of the original
-- @CString@, and is managed on the Haskell heap. The original
-- @CString@ must be null terminated.
--
-- @since 0.10.10.0
packCString :: CString -> IO ShortByteString
packCString cstr = do
  len <- c_strlen cstr
  packCStringLen (cstr, fromIntegral len)

-- | /O(n)./ Construct a new @ShortByteString@ from a @CStringLen@. The
-- resulting @ShortByteString@ is an immutable copy of the original @CStringLen@.
-- The @ShortByteString@ is a normal Haskell value and will be managed on the
-- Haskell heap.
--
-- @since 0.10.10.0
packCStringLen :: CStringLen -> IO ShortByteString
packCStringLen (cstr, len) | len >= 0 = createFromPtr cstr len
packCStringLen (_, len) =
  moduleErrorIO "packCStringLen" ("negative length: " ++ show len)

-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a
-- null-terminated @CString@.  The @CString@ is a copy and will be freed
-- automatically; it must not be stored or used after the
-- subcomputation finishes.
--
-- @since 0.10.10.0
useAsCString :: ShortByteString -> (CString -> IO a) -> IO a
useAsCString bs action =
  allocaBytes (l+1) $ \buf -> do
      copyToPtr bs 0 buf (fromIntegral l)
      pokeByteOff buf l (0::Word8)
      action buf
  where l = length bs

-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a @CStringLen@.
-- As for @useAsCString@ this function makes a copy of the original @ShortByteString@.
-- It must not be stored or used after the subcomputation finishes.
--
-- @since 0.10.10.0
useAsCStringLen :: ShortByteString -> (CStringLen -> IO a) -> IO a
useAsCStringLen bs action =
  allocaBytes l $ \buf -> do
      copyToPtr bs 0 buf (fromIntegral l)
      action (buf, l)
  where l = length bs


#endif


-- | /O(n)./ Construct a new @ShortByteString@ from a @CWString@. The
-- resulting @ShortByteString@ is an immutable copy of the original
-- @CWString@, and is managed on the Haskell heap. The original
-- @CWString@ must be null terminated.
--
-- @since 0.10.10.0
packCWString :: CWString -> IO ShortByteString
packCWString :: CWString -> IO ShortByteString
packCWString CWString
cstr = do
  CSize
len <- CString -> IO CSize
c_strlen (CWString -> CString
coerce CWString
cstr)
  CWStringLen -> IO ShortByteString
packCWStringLen (CWString
cstr, CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
len)

-- | /O(n)./ Construct a new @ShortByteString@ from a @CWStringLen@. The
-- resulting @ShortByteString@ is an immutable copy of the original @CWStringLen@.
-- The @ShortByteString@ is a normal Haskell value and will be managed on the
-- Haskell heap.
--
-- @since 0.10.10.0
packCWStringLen :: CWStringLen -> IO ShortByteString
packCWStringLen :: CWStringLen -> IO ShortByteString
packCWStringLen (CWString
cstr, Int
len) | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 = CWString -> Int -> IO ShortByteString
forall a. Ptr a -> Int -> IO ShortByteString
createFromPtr CWString
cstr Int
len
packCWStringLen (CWString
_, Int
len) =
  String -> String -> IO ShortByteString
forall a. String -> String -> IO a
moduleErrorIO String
"packCWStringLen" (String
"negative length: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len)


-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a
-- null-terminated @CWString@.  The @CWString@ is a copy and will be freed
-- automatically; it must not be stored or used after the
-- subcomputation finishes.
--
-- @since 0.10.10.0
useAsCWString :: ShortByteString -> (CWString -> IO a) -> IO a
useAsCWString :: ShortByteString -> (CWString -> IO a) -> IO a
useAsCWString ShortByteString
bs CWString -> IO a
action =
  Int -> (CWString -> IO a) -> IO a
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ((CWString -> IO a) -> IO a) -> (CWString -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \CWString
buf -> do
      ShortByteString -> Int -> CWString -> Int -> IO ()
forall a. ShortByteString -> Int -> Ptr a -> Int -> IO ()
copyToPtr ShortByteString
bs Int
0 CWString
buf (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l)
      CWString -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff CWString
buf Int
l (Word8
0::Word8)
      CWString -> IO a
action CWString
buf
  where l :: Int
l = ShortByteString -> Int
length ShortByteString
bs

-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a @CWStringLen@.
-- As for @useAsCWString@ this function makes a copy of the original @ShortByteString@.
-- It must not be stored or used after the subcomputation finishes.
--
-- @since 0.10.10.0
useAsCWStringLen :: ShortByteString -> (CWStringLen -> IO a) -> IO a
useAsCWStringLen :: ShortByteString -> (CWStringLen -> IO a) -> IO a
useAsCWStringLen ShortByteString
bs CWStringLen -> IO a
action =
  Int -> (CWString -> IO a) -> IO a
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
l ((CWString -> IO a) -> IO a) -> (CWString -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \CWString
buf -> do
      ShortByteString -> Int -> CWString -> Int -> IO ()
forall a. ShortByteString -> Int -> Ptr a -> Int -> IO ()
copyToPtr ShortByteString
bs Int
0 CWString
buf (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l)
      CWStringLen -> IO a
action (CWString
buf, Int
l)
  where l :: Int
l = ShortByteString -> Int
length ShortByteString
bs

-- | /O(n) construction./ Use a @ShortByteString@ with a function requiring a @CWStringLen@.
-- As for @useAsCWString@ this function makes a copy of the original @ShortByteString@.
-- It must not be stored or used after the subcomputation finishes.
--
-- @since 0.10.10.0
newCWString :: ShortByteString -> IO CWString
newCWString :: ShortByteString -> IO CWString
newCWString ShortByteString
bs = do
  CWString
ptr <- Int -> IO CWString
forall a. Storable a => Int -> IO (Ptr a)
mallocArray0 Int
l
  ShortByteString -> Int -> CWString -> Int -> IO ()
forall a. ShortByteString -> Int -> Ptr a -> Int -> IO ()
copyToPtr ShortByteString
bs Int
0 CWString
ptr (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l)
  CWString -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff CWString
ptr Int
l (Word8
0::Word8)
  CWString -> IO CWString
forall (m :: * -> *) a. Monad m => a -> m a
return CWString
ptr
  where l :: Int
l = ShortByteString -> Int
length ShortByteString
bs


 -- ---------------------------------------------------------------------
-- Internal utilities

moduleErrorIO :: String -> String -> IO a
moduleErrorIO :: String -> String -> IO a
moduleErrorIO String
fun String
msg = IOError -> IO a
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO a) -> (String -> IOError) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
userError (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String -> String -> String
moduleErrorMsg String
fun String
msg
{-# NOINLINE moduleErrorIO #-}

moduleErrorMsg :: String -> String -> String
moduleErrorMsg :: String -> String -> String
moduleErrorMsg String
fun String
msg = String
"Data.ByteString.Short." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fun String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
':'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:String
msg