#if __GLASGOW_HASKELL__ >= 703 #endif module Data . ByteString . Internal ( ByteString ( .. ) , packBytes , packUptoLenBytes , unsafePackLenBytes , packChars , packUptoLenChars , unsafePackLenChars , unpackBytes , unpackAppendBytesLazy , unpackAppendBytesStrict , unpackChars , unpackAppendCharsLazy , unpackAppendCharsStrict , unsafePackAddress , 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,9,0) import Data . Semigroup ( Semigroup ( ( <> ) ) ) #endif #if !(MIN_VERSION_base(4,8,0)) import Data . Monoid ( Monoid ( .. ) ) #endif import Control . DeepSeq ( NFData ( rnf ) ) import Data . String ( IsString ( .. ) ) import Control . Exception ( assert ) import Data . Char ( ord ) import Data . Word ( Word8 ) import Data . Typeable ( Typeable ) import Data . Data ( Data ( .. ) , mkNoRepType ) 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 import GHC . Base ( nullAddr # ) import GHC . ForeignPtr ( ForeignPtr ( ForeignPtr ) , newForeignPtr_ , mallocPlainForeignPtrBytes ) import GHC . Ptr ( Ptr ( .. ) , castPtr ) data ByteString = PS ! ( ForeignPtr Word8 ) ! Int ! Int deriving ( Typeable ) instance Eq ByteString where ( == ) = eq instance Ord ByteString where compare = compareBytes #if MIN_VERSION_base(4,9,0) instance Semigroup ByteString where ( <> ) = append #endif instance Monoid ByteString where mempty = PS nullForeignPtr 0 0 #if MIN_VERSION_base(4,9,0) mappend = ( <> ) #else mappend = append #endif 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 ] 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" 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 = 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 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 # 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 nullForeignPtr = ForeignPtr nullAddr # ( error "nullForeignPtr" ) fromForeignPtr :: ForeignPtr Word8 -> Int -> Int -> ByteString fromForeignPtr fp s l = PS fp s l toForeignPtr :: ByteString -> ( ForeignPtr Word8 , Int , Int ) toForeignPtr ( PS ps s l ) = ( ps , s , l ) unsafeCreate :: Int -> ( Ptr Word8 -> IO () ) -> ByteString unsafeCreate l f = unsafeDupablePerformIO ( create l f ) unsafeCreateUptoN :: Int -> ( Ptr Word8 -> IO Int ) -> ByteString unsafeCreateUptoN l f = unsafeDupablePerformIO ( createUptoN l f ) unsafeCreateUptoN' :: Int -> ( Ptr Word8 -> IO ( Int , a ) ) -> ( ByteString , a ) unsafeCreateUptoN' l f = unsafeDupablePerformIO ( createUptoN' l f ) create :: Int -> ( Ptr Word8 -> IO () ) -> IO ByteString create l f = do fp <- mallocByteString l withForeignPtr fp $ \ p -> f p return $! PS fp 0 l 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' 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 ) 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' 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 = mallocPlainForeignPtrBytes l 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 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 w2c = unsafeChr . fromIntegral c2w :: Char -> Word8 c2w = fromIntegral . ord isSpaceWord8 :: Word8 -> Bool isSpaceWord8 w = w == 0x20 || w == 0x0A || w == 0x09 || w == 0x0C || w == 0x0D || w == 0x0B || w == 0xA0 isSpaceChar8 :: Char -> Bool isSpaceChar8 c = c == ' ' || c == '\t' || c == '

' || c == '\r' || c == '\f' || c == '\v' || c == '\xa0' overflowError :: String -> a overflowError fun = error $ "Data.ByteString." ++ fun ++ ": size overflow" accursedUnutterablePerformIO :: IO a -> a accursedUnutterablePerformIO ( IO m ) = case m realWorld # of ( # _ , r # ) -> r inlinePerformIO :: IO a -> a inlinePerformIO = 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