module Data.ByteString.Internal.Type (
ByteString
( BS
, PS
),
StrictByteString,
findIndexOrLength,
packBytes, packUptoLenBytes, unsafePackLenBytes,
packChars, packUptoLenChars, unsafePackLenChars,
unpackBytes, unpackAppendBytesLazy, unpackAppendBytesStrict,
unpackChars, unpackAppendCharsLazy, unpackAppendCharsStrict,
unsafePackAddress, unsafePackLenAddress,
unsafePackLiteral, unsafePackLenLiteral,
empty,
createFp,
createFpUptoN,
createFpUptoN',
createFpAndTrim,
createFpAndTrim',
unsafeCreateFp,
unsafeCreateFpUptoN,
unsafeCreateFpUptoN',
create,
createUptoN,
createUptoN',
createAndTrim,
createAndTrim',
unsafeCreate,
unsafeCreateUptoN,
unsafeCreateUptoN',
mallocByteString,
fromForeignPtr,
toForeignPtr,
fromForeignPtr0,
toForeignPtr0,
nullForeignPtr,
peekFp,
pokeFp,
peekFpByteOff,
pokeFpByteOff,
minusForeignPtr,
memcpyFp,
checkedAdd,
c_strlen,
c_free_finalizer,
memchr,
memcmp,
memcpy,
memset,
c_reverse,
c_intersperse,
c_maximum,
c_minimum,
c_count,
c_sort,
w2c, c2w, isSpaceWord8, isSpaceChar8,
accursedUnutterablePerformIO,
plusForeignPtr,
unsafeWithForeignPtr
) where
import Prelude hiding (concat, null)
import qualified Data.List as List
import Control.Monad (void)
import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
import Foreign.Ptr (Ptr, FunPtr, plusPtr)
import Foreign.Storable (Storable(..))
import Foreign.C.Types (CInt(..), CSize(..))
import Foreign.C.String (CString)
#if MIN_VERSION_base(4,13,0)
import Data.Semigroup (Semigroup (sconcat, stimes))
#else
import Data.Semigroup (Semigroup ((<>), sconcat, stimes))
#endif
import Data.List.NonEmpty (NonEmpty ((:|)))
import Control.DeepSeq (NFData(rnf))
import Data.String (IsString(..))
import Control.Exception (assert)
import Data.Bits ((.&.))
import Data.Char (ord)
import Data.Word
import Data.Typeable (Typeable)
import Data.Data (Data(..), mkNoRepType)
import GHC.Base (nullAddr#,realWorld#,unsafeChr)
import GHC.Exts (IsList(..))
import GHC.CString (unpackCString#)
import GHC.Exts (Addr#, minusAddr#)
import GHC.IO (IO(IO),unsafeDupablePerformIO)
import GHC.ForeignPtr (ForeignPtr(ForeignPtr)
#if __GLASGOW_HASKELL__ < 900
, newForeignPtr_
#endif
, mallocPlainForeignPtrBytes)
#if MIN_VERSION_base(4,10,0)
import GHC.ForeignPtr (plusForeignPtr)
#else
import GHC.Prim (plusAddr#)
#endif
#if __GLASGOW_HASKELL__ >= 811
import GHC.CString (cstringLength#)
import GHC.ForeignPtr (ForeignPtrContents(FinalPtr))
#else
import GHC.Ptr (Ptr(..))
#endif
import GHC.Types (Int (..))
#if MIN_VERSION_base(4,15,0)
import GHC.ForeignPtr (unsafeWithForeignPtr)
#endif
import qualified Language.Haskell.TH.Lib as TH
import qualified Language.Haskell.TH.Syntax as TH
#if !MIN_VERSION_base(4,15,0)
unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr = withForeignPtr
#endif
#if !MIN_VERSION_base(4,10,0)
plusForeignPtr :: ForeignPtr a -> Int -> ForeignPtr b
plusForeignPtr (ForeignPtr addr guts) (I# offset) = ForeignPtr (plusAddr# addr offset) guts
#endif
minusForeignPtr :: ForeignPtr a -> ForeignPtr b -> Int
minusForeignPtr (ForeignPtr addr1 _) (ForeignPtr addr2 _)
= I# (minusAddr# addr1 addr2)
peekFp :: Storable a => ForeignPtr a -> IO a
peekFp fp = unsafeWithForeignPtr fp peek
pokeFp :: Storable a => ForeignPtr a -> a -> IO ()
pokeFp fp val = unsafeWithForeignPtr fp $ \p -> poke p val
peekFpByteOff :: Storable a => ForeignPtr a -> Int -> IO a
peekFpByteOff fp off = unsafeWithForeignPtr fp $ \p ->
peekByteOff p off
pokeFpByteOff :: Storable a => ForeignPtr b -> Int -> a -> IO ()
pokeFpByteOff fp off val = unsafeWithForeignPtr fp $ \p ->
pokeByteOff p off val
data ByteString = BS !(ForeignPtr Word8)
!Int
deriving (Typeable)
type StrictByteString = ByteString
pattern PS :: ForeignPtr Word8 -> Int -> Int -> ByteString
pattern PS fp zero len <- BS fp ((0,) -> (zero, len)) where
PS fp o len = BS (plusForeignPtr fp o) len
#if __GLASGOW_HASKELL__ >= 802
#endif
instance Eq ByteString where
(==) = eq
instance Ord ByteString where
compare = compareBytes
instance Semigroup ByteString where
(<>) = append
sconcat (b:|bs) = concat (b:bs)
stimes = times
instance Monoid ByteString where
mempty = empty
mappend = (<>)
mconcat = concat
instance NFData ByteString where
rnf BS{} = ()
instance Show ByteString where
showsPrec p ps r = showsPrec p (unpackChars ps) r
instance Read ByteString where
readsPrec p str = [ (packChars x, y) | (x, y) <- readsPrec p str ]
instance IsList ByteString where
type Item ByteString = Word8
fromList = packBytes
toList = unpackBytes
instance IsString ByteString where
fromString = packChars
instance Data ByteString where
gfoldl f z txt = z packBytes `f` unpackBytes txt
toConstr _ = error "Data.ByteString.ByteString.toConstr"
gunfold _ _ = error "Data.ByteString.ByteString.gunfold"
dataTypeOf _ = mkNoRepType "Data.ByteString.ByteString"
instance TH.Lift ByteString where
#if MIN_VERSION_template_haskell(2,16,0)
lift (BS ptr len) = [| unsafePackLenLiteral |]
`TH.appE` TH.litE (TH.integerL (fromIntegral len))
`TH.appE` TH.litE (TH.BytesPrimL $ TH.Bytes ptr 0 (fromIntegral len))
#else
lift bs@(BS _ len) = [| unsafePackLenLiteral |]
`TH.appE` TH.litE (TH.integerL (fromIntegral len))
`TH.appE` TH.litE (TH.StringPrimL $ unpackBytes bs)
#endif
#if MIN_VERSION_template_haskell(2,17,0)
liftTyped = TH.unsafeCodeCoerce . TH.lift
#elif MIN_VERSION_template_haskell(2,16,0)
liftTyped = TH.unsafeTExpCoerce . TH.lift
#endif
findIndexOrLength :: (Word8 -> Bool) -> ByteString -> Int
findIndexOrLength k (BS x l) =
accursedUnutterablePerformIO $ g x
where
g ptr = go 0
where
go !n | n >= l = return l
| otherwise = do w <- peekFp $ ptr `plusForeignPtr` n
if k w
then return n
else go (n+1)
packBytes :: [Word8] -> ByteString
packBytes ws = unsafePackLenBytes (List.length ws) ws
packChars :: [Char] -> ByteString
packChars cs = unsafePackLenChars (List.length cs) cs
unsafePackLenBytes :: Int -> [Word8] -> ByteString
unsafePackLenBytes len xs0 =
unsafeCreateFp len $ \p -> go p xs0
where
go !_ [] = return ()
go !p (x:xs) = pokeFp p x >> go (p `plusForeignPtr` 1) xs
unsafePackLenChars :: Int -> [Char] -> ByteString
unsafePackLenChars len cs0 =
unsafeCreateFp len $ \p -> go p cs0
where
go !_ [] = return ()
go !p (c:cs) = pokeFp p (c2w c) >> go (p `plusForeignPtr` 1) cs
unsafePackAddress :: Addr# -> IO ByteString
unsafePackAddress addr# = do
#if __GLASGOW_HASKELL__ >= 811
unsafePackLenAddress (I# (cstringLength# addr#)) addr#
#else
l <- c_strlen (Ptr addr#)
unsafePackLenAddress (fromIntegral l) addr#
#endif
unsafePackLenAddress :: Int -> Addr# -> IO ByteString
unsafePackLenAddress len addr# = do
#if __GLASGOW_HASKELL__ >= 811
return (BS (ForeignPtr addr# FinalPtr) len)
#else
p <- newForeignPtr_ (Ptr addr#)
return $ BS p len
#endif
unsafePackLiteral :: Addr# -> ByteString
unsafePackLiteral addr# =
#if __GLASGOW_HASKELL__ >= 811
unsafePackLenLiteral (I# (cstringLength# addr#)) addr#
#else
let len = accursedUnutterablePerformIO (c_strlen (Ptr addr#))
in unsafePackLenLiteral (fromIntegral len) addr#
#endif
unsafePackLenLiteral :: Int -> Addr# -> ByteString
unsafePackLenLiteral len addr# =
#if __GLASGOW_HASKELL__ >= 811
BS (ForeignPtr addr# FinalPtr) len
#else
BS (unsafeDupablePerformIO (newForeignPtr_ (Ptr addr#))) len
#endif
packUptoLenBytes :: Int -> [Word8] -> (ByteString, [Word8])
packUptoLenBytes len xs0 =
unsafeCreateFpUptoN' len $ \p0 ->
let p_end = plusForeignPtr p0 len
go !p [] = return (p `minusForeignPtr` p0, [])
go !p xs | p == p_end = return (len, xs)
go !p (x:xs) = pokeFp p x >> go (p `plusForeignPtr` 1) xs
in go p0 xs0
packUptoLenChars :: Int -> [Char] -> (ByteString, [Char])
packUptoLenChars len cs0 =
unsafeCreateFpUptoN' len $ \p0 ->
let p_end = plusForeignPtr p0 len
go !p [] = return (p `minusForeignPtr` p0, [])
go !p cs | p == p_end = return (len, cs)
go !p (c:cs) = pokeFp p (c2w c) >> go (p `plusForeignPtr` 1) cs
in go p0 cs0
unpackBytes :: ByteString -> [Word8]
unpackBytes bs = unpackAppendBytesLazy bs []
unpackChars :: ByteString -> [Char]
unpackChars bs = unpackAppendCharsLazy bs []
unpackAppendBytesLazy :: ByteString -> [Word8] -> [Word8]
unpackAppendBytesLazy (BS fp len) xs
| len <= 100 = unpackAppendBytesStrict (BS fp len) xs
| otherwise = unpackAppendBytesStrict (BS fp 100) remainder
where
remainder = unpackAppendBytesLazy (BS (plusForeignPtr fp 100) (len100)) xs
unpackAppendCharsLazy :: ByteString -> [Char] -> [Char]
unpackAppendCharsLazy (BS fp len) cs
| len <= 100 = unpackAppendCharsStrict (BS fp len) cs
| otherwise = unpackAppendCharsStrict (BS fp 100) remainder
where
remainder = unpackAppendCharsLazy (BS (plusForeignPtr fp 100) (len100)) cs
unpackAppendBytesStrict :: ByteString -> [Word8] -> [Word8]
unpackAppendBytesStrict (BS fp len) xs =
accursedUnutterablePerformIO $ unsafeWithForeignPtr fp $ \base ->
loop (base `plusPtr` (1)) (base `plusPtr` (1+len)) xs
where
loop !sentinal !p acc
| p == sentinal = return acc
| otherwise = do x <- peek p
loop sentinal (p `plusPtr` (1)) (x:acc)
unpackAppendCharsStrict :: ByteString -> [Char] -> [Char]
unpackAppendCharsStrict (BS fp len) xs =
accursedUnutterablePerformIO $ unsafeWithForeignPtr fp $ \base ->
loop (base `plusPtr` (1)) (base `plusPtr` (1+len)) xs
where
loop !sentinal !p acc
| p == sentinal = return acc
| otherwise = do x <- peek p
loop sentinal (p `plusPtr` (1)) (w2c x:acc)
nullForeignPtr :: ForeignPtr Word8
#if __GLASGOW_HASKELL__ >= 811
nullForeignPtr = ForeignPtr nullAddr# FinalPtr
#else
nullForeignPtr = ForeignPtr nullAddr# (error "nullForeignPtr")
#endif
fromForeignPtr :: ForeignPtr Word8
-> Int
-> Int
-> ByteString
fromForeignPtr fp o = BS (plusForeignPtr fp o)
fromForeignPtr0 :: ForeignPtr Word8
-> Int
-> ByteString
fromForeignPtr0 = BS
toForeignPtr :: ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr (BS ps l) = (ps, 0, l)
toForeignPtr0 :: ByteString -> (ForeignPtr Word8, Int)
toForeignPtr0 (BS ps l) = (ps, l)
unsafeCreateFp :: Int -> (ForeignPtr Word8 -> IO ()) -> ByteString
unsafeCreateFp l f = unsafeDupablePerformIO (createFp l f)
unsafeCreateFpUptoN :: Int -> (ForeignPtr Word8 -> IO Int) -> ByteString
unsafeCreateFpUptoN l f = unsafeDupablePerformIO (createFpUptoN l f)
unsafeCreateFpUptoN'
:: Int -> (ForeignPtr Word8 -> IO (Int, a)) -> (ByteString, a)
unsafeCreateFpUptoN' l f = unsafeDupablePerformIO (createFpUptoN' l f)
createFp :: Int -> (ForeignPtr Word8 -> IO ()) -> IO ByteString
createFp l action = do
fp <- mallocByteString l
action fp
return $! BS fp l
createFpUptoN :: Int -> (ForeignPtr Word8 -> IO Int) -> IO ByteString
createFpUptoN l action = do
fp <- mallocByteString l
l' <- action fp
assert (l' <= l) $ return $! BS fp l'
createFpUptoN' :: Int -> (ForeignPtr Word8 -> IO (Int, a)) -> IO (ByteString, a)
createFpUptoN' l action = do
fp <- mallocByteString l
(l', res) <- action fp
assert (l' <= l) $ return (BS fp l', res)
createFpAndTrim :: Int -> (ForeignPtr Word8 -> IO Int) -> IO ByteString
createFpAndTrim l action = do
fp <- mallocByteString l
l' <- action fp
if assert (0 <= l' && l' <= l) $ l' >= l
then return $! BS fp l
else createFp l' $ \fp' -> memcpyFp fp' fp l'
createFpAndTrim' :: Int -> (ForeignPtr Word8 -> IO (Int, Int, a)) -> IO (ByteString, a)
createFpAndTrim' l action = do
fp <- mallocByteString l
(off, l', res) <- action fp
if assert (0 <= l' && l' <= l) $ l' >= l
then return (BS fp l, res)
else do ps <- createFp l' $ \fp' ->
memcpyFp fp' (fp `plusForeignPtr` off) l'
return (ps, res)
wrapAction :: (Ptr Word8 -> IO res) -> ForeignPtr Word8 -> IO res
wrapAction = flip withForeignPtr
unsafeCreate :: Int -> (Ptr Word8 -> IO ()) -> ByteString
unsafeCreate l f = unsafeCreateFp l (wrapAction f)
unsafeCreateUptoN :: Int -> (Ptr Word8 -> IO Int) -> ByteString
unsafeCreateUptoN l f = unsafeCreateFpUptoN l (wrapAction f)
unsafeCreateUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> (ByteString, a)
unsafeCreateUptoN' l f = unsafeCreateFpUptoN' l (wrapAction f)
create :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString
create l action = createFp l (wrapAction action)
createUptoN :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString
createUptoN l action = createFpUptoN l (wrapAction action)
createUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> IO (ByteString, a)
createUptoN' l action = createFpUptoN' l (wrapAction action)
createAndTrim :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString
createAndTrim l action = createFpAndTrim l (wrapAction action)
createAndTrim' :: Int -> (Ptr Word8 -> IO (Int, Int, a)) -> IO (ByteString, a)
createAndTrim' l action = createFpAndTrim' l (wrapAction action)
mallocByteString :: Int -> IO (ForeignPtr a)
mallocByteString = mallocPlainForeignPtrBytes
eq :: ByteString -> ByteString -> Bool
eq a@(BS fp len) b@(BS fp' len')
| len /= len' = False
| fp == fp' = True
| otherwise = compareBytes a b == EQ
compareBytes :: ByteString -> ByteString -> Ordering
compareBytes (BS _ 0) (BS _ 0) = EQ
compareBytes (BS fp1 len1) (BS fp2 len2) =
accursedUnutterablePerformIO $
unsafeWithForeignPtr fp1 $ \p1 ->
unsafeWithForeignPtr fp2 $ \p2 -> do
i <- memcmp p1 p2 (min len1 len2)
return $! case i `compare` 0 of
EQ -> len1 `compare` len2
x -> x
empty :: ByteString
empty = BS nullForeignPtr 0
append :: ByteString -> ByteString -> ByteString
append (BS _ 0) b = b
append a (BS _ 0) = a
append (BS fp1 len1) (BS fp2 len2) =
unsafeCreateFp (len1+len2) $ \destptr1 -> do
let destptr2 = destptr1 `plusForeignPtr` len1
memcpyFp destptr1 fp1 len1
memcpyFp destptr2 fp2 len2
concat :: [ByteString] -> ByteString
concat = \bss0 -> goLen0 bss0 bss0
where
goLen0 _ [] = empty
goLen0 bss0 (BS _ 0 :bss) = goLen0 bss0 bss
goLen0 bss0 (bs :bss) = goLen1 bss0 bs bss
goLen1 _ bs [] = bs
goLen1 bss0 bs (BS _ 0 :bss) = goLen1 bss0 bs bss
goLen1 bss0 bs (BS _ len:bss) = goLen bss0 (checkedAdd "concat" len' len) bss
where BS _ len' = bs
goLen bss0 !total (BS _ len:bss) = goLen bss0 total' bss
where total' = checkedAdd "concat" total len
goLen bss0 total [] =
unsafeCreateFp total $ \ptr -> goCopy bss0 ptr
goCopy [] !_ = return ()
goCopy (BS _ 0 :bss) !ptr = goCopy bss ptr
goCopy (BS fp len:bss) !ptr = do
memcpyFp ptr fp len
goCopy bss (ptr `plusForeignPtr` len)
times :: Integral a => a -> ByteString -> ByteString
times n (BS fp len)
| n < 0 = error "stimes: non-negative multiplier expected"
| n == 0 = empty
| n == 1 = BS fp len
| len == 0 = empty
| len == 1 = unsafeCreateFp size $ \destfptr -> do
byte <- peekFp fp
void $ unsafeWithForeignPtr destfptr $ \destptr ->
memset destptr byte (fromIntegral n)
| otherwise = unsafeCreateFp size $ \destptr -> do
memcpyFp destptr fp len
fillFrom destptr len
where
size = len * fromIntegral n
fillFrom :: ForeignPtr Word8 -> Int -> IO ()
fillFrom destptr copied
| 2 * copied <= size = do
memcpyFp (destptr `plusForeignPtr` copied) destptr copied
fillFrom destptr (copied * 2)
| otherwise = memcpyFp (destptr `plusForeignPtr` copied) destptr (size copied)
checkedAdd :: String -> Int -> Int -> Int
checkedAdd fun x y
| r >= 0 = r
| otherwise = overflowError fun
where r = x + y
w2c :: Word8 -> Char
w2c = unsafeChr . fromIntegral
c2w :: Char -> Word8
c2w = fromIntegral . ord
isSpaceWord8 :: Word8 -> Bool
isSpaceWord8 w8 =
let w :: Word
!w = fromIntegral w8
in w .&. 0x50 == 0
&& w 0x21 > 0x7e
&& ( w == 0x20
|| w == 0xa0
|| w 0x09 < 5)
isSpaceChar8 :: Char -> Bool
isSpaceChar8 = isSpaceWord8 . c2w
overflowError :: String -> a
overflowError fun = error $ "Data.ByteString." ++ fun ++ ": size overflow"
accursedUnutterablePerformIO :: IO a -> a
accursedUnutterablePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
foreign import ccall unsafe "string.h strlen" c_strlen
:: CString -> IO CSize
foreign import ccall unsafe "static stdlib.h &free" c_free_finalizer
:: FunPtr (Ptr Word8 -> IO ())
foreign import ccall unsafe "string.h memchr" c_memchr
:: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8)
memchr :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)
memchr p w = c_memchr p (fromIntegral w)
foreign import ccall unsafe "string.h memcmp" c_memcmp
:: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt
memcmp :: Ptr Word8 -> Ptr Word8 -> Int -> IO CInt
memcmp p q s = c_memcmp p q (fromIntegral s)
foreign import ccall unsafe "string.h memcpy" c_memcpy
:: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8)
memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()
memcpy p q s = void $ c_memcpy p q (fromIntegral s)
memcpyFp :: ForeignPtr Word8 -> ForeignPtr Word8 -> Int -> IO ()
memcpyFp fp fq s = unsafeWithForeignPtr fp $ \p ->
unsafeWithForeignPtr fq $ \q -> memcpy p q s
foreign import ccall unsafe "string.h memset" c_memset
:: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8)
memset :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)
memset p w = c_memset p (fromIntegral w)
foreign import ccall unsafe "static fpstring.h fps_reverse" c_reverse
:: Ptr Word8 -> Ptr Word8 -> CSize -> IO ()
foreign import ccall unsafe "static fpstring.h fps_intersperse" c_intersperse
:: Ptr Word8 -> Ptr Word8 -> CSize -> Word8 -> IO ()
foreign import ccall unsafe "static fpstring.h fps_maximum" c_maximum
:: Ptr Word8 -> CSize -> IO Word8
foreign import ccall unsafe "static fpstring.h fps_minimum" c_minimum
:: Ptr Word8 -> CSize -> IO Word8
foreign import ccall unsafe "static fpstring.h fps_count" c_count
:: Ptr Word8 -> CSize -> Word8 -> IO CSize
foreign import ccall unsafe "static fpstring.h fps_sort" c_sort
:: Ptr Word8 -> CSize -> IO ()