{-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns #-}
#if __GLASGOW_HASKELL__
{-# LANGUAGE UnliftedFFITypes, MagicHash,
UnboxedTuples, DeriveDataTypeable #-}
#if __GLASGOW_HASKELL__ >= 703
{-# LANGUAGE Unsafe #-}
#endif
#endif
{-# OPTIONS_HADDOCK hide #-}
module Data.ByteString.Internal (
ByteString(..),
packBytes, packUptoLenBytes, unsafePackLenBytes,
packChars, packUptoLenChars, unsafePackLenChars,
unpackBytes, unpackAppendBytesLazy, unpackAppendBytesStrict,
unpackChars, unpackAppendCharsLazy, unpackAppendCharsStrict,
#if defined(__GLASGOW_HASKELL__)
unsafePackAddress,
#endif
checkedSum,
create,
createUptoN,
createAndTrim,
createAndTrim',
unsafeCreate,
unsafeCreateUptoN,
mallocByteString,
fromForeignPtr,
toForeignPtr,
nullForeignPtr,
c_strlen,
c_free_finalizer,
memchr,
memcmp,
memcpy,
memset,
c_reverse,
c_intersperse,
c_maximum,
c_minimum,
c_count,
w2c, c2w, isSpaceWord8, isSpaceChar8,
accursedUnutterablePerformIO,
inlinePerformIO
) where
import Prelude hiding (concat)
import qualified Data.List as List
import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
import Foreign.Ptr (Ptr, FunPtr, plusPtr)
import Foreign.Storable (Storable(..))
#if MIN_VERSION_base(4,5,0) || __GLASGOW_HASKELL__ >= 703
import Foreign.C.Types (CInt(..), CSize(..), CULong(..))
#else
import Foreign.C.Types (CInt, CSize, CULong)
#endif
import Foreign.C.String (CString)
#if !(MIN_VERSION_base(4,8,0))
import Data.Monoid (Monoid(..))
#endif
import Control.DeepSeq (NFData(rnf))
#if MIN_VERSION_base(3,0,0)
import Data.String (IsString(..))
#endif
#ifndef __NHC__
import Control.Exception (assert)
#endif
import Data.Char (ord)
import Data.Word (Word8)
import Data.Typeable (Typeable)
#if MIN_VERSION_base(4,1,0)
import Data.Data (Data(..))
#if MIN_VERSION_base(4,2,0)
import Data.Data (mkNoRepType)
#else
import Data.Data (mkNorepType)
#endif
#else
import Data.Generics (Data(..), mkNorepType)
#endif
#ifdef __GLASGOW_HASKELL__
import GHC.Base (realWorld#,unsafeChr)
#if MIN_VERSION_base(4,4,0)
import GHC.CString (unpackCString#)
#else
import GHC.Base (unpackCString#)
#endif
import GHC.Prim (Addr#)
#if __GLASGOW_HASKELL__ >= 611
import GHC.IO (IO(IO))
#else
import GHC.IOBase (IO(IO),RawBuffer)
#endif
#if __GLASGOW_HASKELL__ >= 611
import GHC.IO (unsafeDupablePerformIO)
#else
import GHC.IOBase (unsafeDupablePerformIO)
#endif
#else
import Data.Char (chr)
import System.IO.Unsafe (unsafePerformIO)
#endif
#ifdef __GLASGOW_HASKELL__
import GHC.ForeignPtr (newForeignPtr_, mallocPlainForeignPtrBytes)
import GHC.Ptr (Ptr(..), castPtr)
#else
import Foreign.ForeignPtr (mallocForeignPtrBytes)
#endif
#ifdef __GLASGOW_HASKELL__
import GHC.ForeignPtr (ForeignPtr(ForeignPtr))
import GHC.Base (nullAddr#)
#else
import Foreign.Ptr (nullPtr)
#endif
#if __HUGS__
import Hugs.ForeignPtr (newForeignPtr_)
#elif __GLASGOW_HASKELL__<=604
import Foreign.ForeignPtr (newForeignPtr_)
#endif
{-# CFILES cbits/fpstring.c #-}
#ifdef __NHC__
#define assert assertS "__FILE__ : __LINE__"
assertS :: String -> Bool -> a -> a
assertS _ True = id
assertS s False = error ("assertion failed at "++s)
#endif
data ByteString = PS {-# UNPACK #-} !(ForeignPtr Word8)
{-# UNPACK #-} !Int
{-# UNPACK #-} !Int
#if defined(__GLASGOW_HASKELL__)
deriving (Typeable)
#endif
instance Eq ByteString where
(==) = eq
instance Ord ByteString where
compare = compareBytes
instance Monoid ByteString where
mempty = PS nullForeignPtr 0 0
mappend = append
mconcat = concat
instance NFData ByteString where
rnf (PS _ _ _) = ()
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 ]
#if MIN_VERSION_base(3,0,0)
instance IsString ByteString where
fromString = packChars
#endif
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"
#if MIN_VERSION_base(4,2,0)
dataTypeOf _ = mkNoRepType "Data.ByteString.ByteString"
#else
dataTypeOf _ = mkNorepType "Data.ByteString.ByteString"
#endif
packBytes :: [Word8] -> ByteString
packBytes ws = unsafePackLenBytes (List.length ws) ws
packChars :: [Char] -> ByteString
packChars cs = unsafePackLenChars (List.length cs) cs
#if defined(__GLASGOW_HASKELL__)
{-# INLINE [0] packChars #-}
{-# RULES
"ByteString packChars/packAddress" forall s .
packChars (unpackCString# s) = accursedUnutterablePerformIO (unsafePackAddress s)
#-}
#endif
unsafePackLenBytes :: Int -> [Word8] -> ByteString
unsafePackLenBytes len xs0 =
unsafeCreate len $ \p -> go p xs0
where
go !_ [] = return ()
go !p (x:xs) = poke p x >> go (p `plusPtr` 1) xs
unsafePackLenChars :: Int -> [Char] -> ByteString
unsafePackLenChars len cs0 =
unsafeCreate len $ \p -> go p cs0
where
go !_ [] = return ()
go !p (c:cs) = poke p (c2w c) >> go (p `plusPtr` 1) cs
#if defined(__GLASGOW_HASKELL__)
unsafePackAddress :: Addr# -> IO ByteString
unsafePackAddress addr# = do
p <- newForeignPtr_ (castPtr cstr)
l <- c_strlen cstr
return $ PS p 0 (fromIntegral l)
where
cstr :: CString
cstr = Ptr addr#
{-# INLINE unsafePackAddress #-}
#endif
packUptoLenBytes :: Int -> [Word8] -> (ByteString, [Word8])
packUptoLenBytes len xs0 =
unsafeCreateUptoN' len $ \p -> go p len xs0
where
go !_ !n [] = return (len-n, [])
go !_ !0 xs = return (len, xs)
go !p !n (x:xs) = poke p x >> go (p `plusPtr` 1) (n-1) xs
packUptoLenChars :: Int -> [Char] -> (ByteString, [Char])
packUptoLenChars len cs0 =
unsafeCreateUptoN' len $ \p -> go p len cs0
where
go !_ !n [] = return (len-n, [])
go !_ !0 cs = return (len, cs)
go !p !n (c:cs) = poke p (c2w c) >> go (p `plusPtr` 1) (n-1) cs
unpackBytes :: ByteString -> [Word8]
unpackBytes bs = unpackAppendBytesLazy bs []
unpackChars :: ByteString -> [Char]
unpackChars bs = unpackAppendCharsLazy bs []
unpackAppendBytesLazy :: ByteString -> [Word8] -> [Word8]
unpackAppendBytesLazy (PS fp off len) xs
| len <= 100 = unpackAppendBytesStrict (PS fp off len) xs
| otherwise = unpackAppendBytesStrict (PS fp off 100) remainder
where
remainder = unpackAppendBytesLazy (PS fp (off+100) (len-100)) xs
unpackAppendCharsLazy :: ByteString -> [Char] -> [Char]
unpackAppendCharsLazy (PS fp off len) cs
| len <= 100 = unpackAppendCharsStrict (PS fp off len) cs
| otherwise = unpackAppendCharsStrict (PS fp off 100) remainder
where
remainder = unpackAppendCharsLazy (PS fp (off+100) (len-100)) cs
unpackAppendBytesStrict :: ByteString -> [Word8] -> [Word8]
unpackAppendBytesStrict (PS fp off len) xs =
accursedUnutterablePerformIO $ withForeignPtr fp $ \base -> do
loop (base `plusPtr` (off-1)) (base `plusPtr` (off-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 (PS fp off len) xs =
accursedUnutterablePerformIO $ withForeignPtr fp $ \base ->
loop (base `plusPtr` (off-1)) (base `plusPtr` (off-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
#ifdef __GLASGOW_HASKELL__
nullForeignPtr = ForeignPtr nullAddr# (error "nullForeignPtr")
#else
nullForeignPtr = unsafePerformIO $ newForeignPtr_ nullPtr
{-# NOINLINE nullForeignPtr #-}
#endif
fromForeignPtr :: ForeignPtr Word8
-> Int
-> Int
-> ByteString
fromForeignPtr fp s l = PS fp s l
{-# INLINE fromForeignPtr #-}
toForeignPtr :: ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr (PS ps s l) = (ps, s, l)
{-# INLINE toForeignPtr #-}
unsafeCreate :: Int -> (Ptr Word8 -> IO ()) -> ByteString
unsafeCreate l f = unsafeDupablePerformIO (create l f)
{-# INLINE unsafeCreate #-}
unsafeCreateUptoN :: Int -> (Ptr Word8 -> IO Int) -> ByteString
unsafeCreateUptoN l f = unsafeDupablePerformIO (createUptoN l f)
{-# INLINE unsafeCreateUptoN #-}
unsafeCreateUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> (ByteString, a)
unsafeCreateUptoN' l f = unsafeDupablePerformIO (createUptoN' l f)
{-# INLINE unsafeCreateUptoN' #-}
#ifndef __GLASGOW_HASKELL__
unsafeDupablePerformIO :: IO a -> a
unsafeDupablePerformIO = unsafePerformIO
#endif
create :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString
create l f = do
fp <- mallocByteString l
withForeignPtr fp $ \p -> f p
return $! PS fp 0 l
{-# INLINE create #-}
createUptoN :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString
createUptoN l f = do
fp <- mallocByteString l
l' <- withForeignPtr fp $ \p -> f p
assert (l' <= l) $ return $! PS fp 0 l'
{-# INLINE createUptoN #-}
createUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> IO (ByteString, a)
createUptoN' l f = do
fp <- mallocByteString l
(l', res) <- withForeignPtr fp $ \p -> f p
assert (l' <= l) $ return (PS fp 0 l', res)
{-# INLINE createUptoN' #-}
createAndTrim :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString
createAndTrim l f = do
fp <- mallocByteString l
withForeignPtr fp $ \p -> do
l' <- f p
if assert (l' <= l) $ l' >= l
then return $! PS fp 0 l
else create l' $ \p' -> memcpy p' p l'
{-# INLINE createAndTrim #-}
createAndTrim' :: Int -> (Ptr Word8 -> IO (Int, Int, a)) -> IO (ByteString, a)
createAndTrim' l f = do
fp <- mallocByteString l
withForeignPtr fp $ \p -> do
(off, l', res) <- f p
if assert (l' <= l) $ l' >= l
then return $! (PS fp 0 l, res)
else do ps <- create l' $ \p' ->
memcpy p' (p `plusPtr` off) l'
return $! (ps, res)
mallocByteString :: Int -> IO (ForeignPtr a)
mallocByteString l = do
#ifdef __GLASGOW_HASKELL__
mallocPlainForeignPtrBytes l
#else
mallocForeignPtrBytes l
#endif
{-# INLINE mallocByteString #-}
eq :: ByteString -> ByteString -> Bool
eq a@(PS fp off len) b@(PS fp' off' len')
| len /= len' = False
| fp == fp' && off == off' = True
| otherwise = compareBytes a b == EQ
{-# INLINE eq #-}
compareBytes :: ByteString -> ByteString -> Ordering
compareBytes (PS _ _ 0) (PS _ _ 0) = EQ
compareBytes (PS fp1 off1 len1) (PS fp2 off2 len2) =
accursedUnutterablePerformIO $
withForeignPtr fp1 $ \p1 ->
withForeignPtr fp2 $ \p2 -> do
i <- memcmp (p1 `plusPtr` off1) (p2 `plusPtr` off2) (min len1 len2)
return $! case i `compare` 0 of
EQ -> len1 `compare` len2
x -> x
append :: ByteString -> ByteString -> ByteString
append (PS _ _ 0) b = b
append a (PS _ _ 0) = a
append (PS fp1 off1 len1) (PS fp2 off2 len2) =
unsafeCreate (len1+len2) $ \destptr1 -> do
let destptr2 = destptr1 `plusPtr` len1
withForeignPtr fp1 $ \p1 -> memcpy destptr1 (p1 `plusPtr` off1) len1
withForeignPtr fp2 $ \p2 -> memcpy destptr2 (p2 `plusPtr` off2) len2
concat :: [ByteString] -> ByteString
concat [] = mempty
concat [bs] = bs
concat bss0 = unsafeCreate totalLen $ \ptr -> go bss0 ptr
where
totalLen = checkedSum "concat" [ len | (PS _ _ len) <- bss0 ]
go [] !_ = return ()
go (PS fp off len:bss) !ptr = do
withForeignPtr fp $ \p -> memcpy ptr (p `plusPtr` off) len
go bss (ptr `plusPtr` len)
checkedSum :: String -> [Int] -> Int
checkedSum fun = go 0
where go !a (x:xs)
| ax >= 0 = go ax xs
| otherwise = overflowError fun
where ax = a + x
go a _ = a
w2c :: Word8 -> Char
#if !defined(__GLASGOW_HASKELL__)
w2c = chr . fromIntegral
#else
w2c = unsafeChr . fromIntegral
#endif
{-# INLINE w2c #-}
c2w :: Char -> Word8
c2w = fromIntegral . ord
{-# INLINE c2w #-}
isSpaceWord8 :: Word8 -> Bool
isSpaceWord8 w =
w == 0x20 ||
w == 0x0A ||
w == 0x09 ||
w == 0x0C ||
w == 0x0D ||
w == 0x0B ||
w == 0xA0
{-# INLINE isSpaceWord8 #-}
isSpaceChar8 :: Char -> Bool
isSpaceChar8 c =
c == ' ' ||
c == '\t' ||
c == '\n' ||
c == '\r' ||
c == '\f' ||
c == '\v' ||
c == '\xa0'
{-# INLINE isSpaceChar8 #-}
overflowError :: String -> a
overflowError fun = error $ "Data.ByteString." ++ fun ++ ": size overflow"
{-# INLINE accursedUnutterablePerformIO #-}
accursedUnutterablePerformIO :: IO a -> a
#if defined(__GLASGOW_HASKELL__)
accursedUnutterablePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
#else
accursedUnutterablePerformIO = unsafePerformIO
#endif
inlinePerformIO :: IO a -> a
inlinePerformIO = accursedUnutterablePerformIO
{-# INLINE inlinePerformIO #-}
{-# DEPRECATED inlinePerformIO "If you think you know what you are doing, use 'unsafePerformIO'. If you are sure you know what you are doing, use 'unsafeDupablePerformIO'. If you enjoy sharing an address space with a malevolent agent of chaos, try 'accursedUnutterablePerformIO'." #-}
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 s = c_memchr p (fromIntegral w) s
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 = c_memcpy p q (fromIntegral s) >> return ()
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 s = c_memset p (fromIntegral w) s
foreign import ccall unsafe "static fpstring.h fps_reverse" c_reverse
:: Ptr Word8 -> Ptr Word8 -> CULong -> IO ()
foreign import ccall unsafe "static fpstring.h fps_intersperse" c_intersperse
:: Ptr Word8 -> Ptr Word8 -> CULong -> Word8 -> IO ()
foreign import ccall unsafe "static fpstring.h fps_maximum" c_maximum
:: Ptr Word8 -> CULong -> IO Word8
foreign import ccall unsafe "static fpstring.h fps_minimum" c_minimum
:: Ptr Word8 -> CULong -> IO Word8
foreign import ccall unsafe "static fpstring.h fps_count" c_count
:: Ptr Word8 -> CULong -> Word8 -> IO CULong