Data/ByteString/Internal.hs

#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 (lenn, [])
    go !_ !0 xs     = return (len,   xs)
    go !p !n (x:xs) = poke p x >> go (p `plusPtr` 1) (n1) xs

packUptoLenChars :: Int -> [Char] -> (ByteString, [Char])
packUptoLenChars len cs0 =
    unsafeCreateUptoN' len $ \p -> go p len cs0
  where
    go !_ !n []     = return (lenn, [])
    go !_ !0 cs     = return (len,   cs)
    go !p !n (c:cs) = poke p (c2w c) >> go (p `plusPtr` 1) (n1) 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) (len100)) 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) (len100)) cs






unpackAppendBytesStrict :: ByteString -> [Word8] -> [Word8]
unpackAppendBytesStrict (PS fp off len) xs =
    accursedUnutterablePerformIO $ withForeignPtr fp $ \base -> do
      loop (base `plusPtr` (off1)) (base `plusPtr` (off1+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` (off1)) (base `plusPtr` (off1+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 == '\n'    ||
    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