diff --git a/Data/ByteString.hs b/Data/ByteString.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString.hs @@ -0,0 +1,2007 @@ +{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-} + +-- #prune + +-- | +-- Module : Data.ByteString +-- Copyright : (c) The University of Glasgow 2001, +-- (c) David Roundy 2003-2005, +-- (c) Simon Marlow 2005 +-- (c) Don Stewart 2005-2006 +-- (c) Bjorn Bringert 2006 +-- +-- Array fusion code: +-- (c) 2001,2002 Manuel M T Chakravarty & Gabriele Keller +-- (c) 2006 Manuel M T Chakravarty & Roman Leshchinskiy +-- +-- License : BSD-style +-- +-- Maintainer : dons@cse.unsw.edu.au +-- Stability : experimental +-- Portability : portable +-- +-- A time and space-efficient implementation of byte vectors using +-- packed Word8 arrays, suitable for high performance use, both in terms +-- of large data quantities, or high speed requirements. Byte vectors +-- are encoded as strict 'Word8' arrays of bytes, held in a 'ForeignPtr', +-- and can be passed between C and Haskell with little effort. +-- +-- This module is intended to be imported @qualified@, to avoid name +-- clashes with "Prelude" functions. eg. +-- +-- > import qualified Data.ByteString as B +-- +-- Original GHC implementation by Bryan O\'Sullivan. +-- Rewritten to use 'Data.Array.Unboxed.UArray' by Simon Marlow. +-- Rewritten to support slices and use 'ForeignPtr' by David Roundy. +-- Polished and extended by Don Stewart. +-- + +module Data.ByteString ( + + -- * The @ByteString@ type + ByteString, -- abstract, instances: Eq, Ord, Show, Read, Data, Typeable, Monoid + + -- * Introducing and eliminating 'ByteString's + empty, -- :: ByteString + singleton, -- :: Word8 -> ByteString + pack, -- :: [Word8] -> ByteString + unpack, -- :: ByteString -> [Word8] + + -- * Basic interface + cons, -- :: Word8 -> ByteString -> ByteString + snoc, -- :: ByteString -> Word8 -> ByteString + append, -- :: ByteString -> ByteString -> ByteString + head, -- :: ByteString -> Word8 + uncons, -- :: ByteString -> Maybe (Word8, ByteString) + last, -- :: ByteString -> Word8 + tail, -- :: ByteString -> ByteString + init, -- :: ByteString -> ByteString + null, -- :: ByteString -> Bool + length, -- :: ByteString -> Int + + -- * Transforming ByteStrings + map, -- :: (Word8 -> Word8) -> ByteString -> ByteString + reverse, -- :: ByteString -> ByteString + intersperse, -- :: Word8 -> ByteString -> ByteString + intercalate, -- :: ByteString -> [ByteString] -> ByteString + transpose, -- :: [ByteString] -> [ByteString] + + -- * Reducing 'ByteString's (folds) + foldl, -- :: (a -> Word8 -> a) -> a -> ByteString -> a + foldl', -- :: (a -> Word8 -> a) -> a -> ByteString -> a + foldl1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 + foldl1', -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 + + foldr, -- :: (Word8 -> a -> a) -> a -> ByteString -> a + foldr', -- :: (Word8 -> a -> a) -> a -> ByteString -> a + foldr1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 + foldr1', -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 + + -- ** Special folds + concat, -- :: [ByteString] -> ByteString + concatMap, -- :: (Word8 -> ByteString) -> ByteString -> ByteString + any, -- :: (Word8 -> Bool) -> ByteString -> Bool + all, -- :: (Word8 -> Bool) -> ByteString -> Bool + maximum, -- :: ByteString -> Word8 + minimum, -- :: ByteString -> Word8 + + -- * Building ByteStrings + -- ** Scans + scanl, -- :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString + scanl1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString + scanr, -- :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString + scanr1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString + + -- ** Accumulating maps + mapAccumL, -- :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) + mapAccumR, -- :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) + mapIndexed, -- :: (Int -> Word8 -> Word8) -> ByteString -> ByteString + + -- ** Generating and unfolding ByteStrings + replicate, -- :: Int -> Word8 -> ByteString + unfoldr, -- :: (a -> Maybe (Word8, a)) -> a -> ByteString + unfoldrN, -- :: Int -> (a -> Maybe (Word8, a)) -> a -> (ByteString, Maybe a) + + -- * Substrings + + -- ** Breaking strings + take, -- :: Int -> ByteString -> ByteString + drop, -- :: Int -> ByteString -> ByteString + splitAt, -- :: Int -> ByteString -> (ByteString, ByteString) + takeWhile, -- :: (Word8 -> Bool) -> ByteString -> ByteString + dropWhile, -- :: (Word8 -> Bool) -> ByteString -> ByteString + span, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) + spanEnd, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) + break, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) + breakEnd, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) + group, -- :: ByteString -> [ByteString] + groupBy, -- :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString] + inits, -- :: ByteString -> [ByteString] + tails, -- :: ByteString -> [ByteString] + + -- ** Breaking into many substrings + split, -- :: Word8 -> ByteString -> [ByteString] + splitWith, -- :: (Word8 -> Bool) -> ByteString -> [ByteString] + + -- * Predicates + isPrefixOf, -- :: ByteString -> ByteString -> Bool + isSuffixOf, -- :: ByteString -> ByteString -> Bool + isInfixOf, -- :: ByteString -> ByteString -> Bool + isSubstringOf, -- :: ByteString -> ByteString -> Bool + + -- ** Search for arbitrary substrings + findSubstring, -- :: ByteString -> ByteString -> Maybe Int + findSubstrings, -- :: ByteString -> ByteString -> [Int] + + -- * Searching ByteStrings + + -- ** Searching by equality + elem, -- :: Word8 -> ByteString -> Bool + notElem, -- :: Word8 -> ByteString -> Bool + + -- ** Searching with a predicate + find, -- :: (Word8 -> Bool) -> ByteString -> Maybe Word8 + filter, -- :: (Word8 -> Bool) -> ByteString -> ByteString + partition, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) + + -- * Indexing ByteStrings + index, -- :: ByteString -> Int -> Word8 + elemIndex, -- :: Word8 -> ByteString -> Maybe Int + elemIndices, -- :: Word8 -> ByteString -> [Int] + elemIndexEnd, -- :: Word8 -> ByteString -> Maybe Int + findIndex, -- :: (Word8 -> Bool) -> ByteString -> Maybe Int + findIndices, -- :: (Word8 -> Bool) -> ByteString -> [Int] + count, -- :: Word8 -> ByteString -> Int + + -- * Zipping and unzipping ByteStrings + zip, -- :: ByteString -> ByteString -> [(Word8,Word8)] + zipWith, -- :: (Word8 -> Word8 -> c) -> ByteString -> ByteString -> [c] + unzip, -- :: [(Word8,Word8)] -> (ByteString,ByteString) + + -- * Ordered ByteStrings + sort, -- :: ByteString -> ByteString + + -- * Low level conversions + -- ** Copying ByteStrings + copy, -- :: ByteString -> ByteString + + -- ** Packing 'CString's and pointers + packCString, -- :: CString -> IO ByteString + packCStringLen, -- :: CStringLen -> IO ByteString + + -- ** Using ByteStrings as 'CString's + useAsCString, -- :: ByteString -> (CString -> IO a) -> IO a + useAsCStringLen, -- :: ByteString -> (CStringLen -> IO a) -> IO a + + -- * I\/O with 'ByteString's + + -- ** Standard input and output + getLine, -- :: IO ByteString + getContents, -- :: IO ByteString + putStr, -- :: ByteString -> IO () + putStrLn, -- :: ByteString -> IO () + interact, -- :: (ByteString -> ByteString) -> IO () + + -- ** Files + readFile, -- :: FilePath -> IO ByteString + writeFile, -- :: FilePath -> ByteString -> IO () + appendFile, -- :: FilePath -> ByteString -> IO () +-- mmapFile, -- :: FilePath -> IO ByteString + + -- ** I\/O with Handles + hGetLine, -- :: Handle -> IO ByteString + hGetContents, -- :: Handle -> IO ByteString + hGet, -- :: Handle -> Int -> IO ByteString + hGetNonBlocking, -- :: Handle -> Int -> IO ByteString + hPut, -- :: Handle -> ByteString -> IO () + hPutStr, -- :: Handle -> ByteString -> IO () + hPutStrLn, -- :: Handle -> ByteString -> IO () + + -- undocumented deprecated things: + join -- :: ByteString -> [ByteString] -> ByteString + + ) where + +import qualified Prelude as P +import Prelude hiding (reverse,head,tail,last,init,null + ,length,map,lines,foldl,foldr,unlines + ,concat,any,take,drop,splitAt,takeWhile + ,dropWhile,span,break,elem,filter,maximum + ,minimum,all,concatMap,foldl1,foldr1 + ,scanl,scanl1,scanr,scanr1 + ,readFile,writeFile,appendFile,replicate + ,getContents,getLine,putStr,putStrLn,interact + ,zip,zipWith,unzip,notElem) + +import Data.ByteString.Internal +import Data.ByteString.Unsafe +import Data.ByteString.Fusion + +import qualified Data.List as List + +import Data.Word (Word8) +import Data.Maybe (listToMaybe) +import Data.Array (listArray) +import qualified Data.Array as Array ((!)) + +-- Control.Exception.bracket not available in yhc or nhc +#ifndef __NHC__ +import Control.Exception (bracket, assert) +import qualified Control.Exception as Exception +#else +import IO (bracket) +#endif +import Control.Monad (when) + +import Foreign.C.String (CString, CStringLen) +import Foreign.C.Types (CSize) +import Foreign.ForeignPtr +import Foreign.Marshal.Alloc (allocaBytes, mallocBytes, reallocBytes, finalizerFree) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Ptr +import Foreign.Storable (Storable(..)) + +-- hGetBuf and hPutBuf not available in yhc or nhc +import System.IO (stdin,stdout,hClose,hFileSize + ,hGetBuf,hPutBuf,openBinaryFile + ,Handle,IOMode(..)) + +import Data.Monoid (Monoid, mempty, mappend, mconcat) + +#if !defined(__GLASGOW_HASKELL__) +import System.IO.Unsafe +import qualified System.Environment +import qualified System.IO (hGetLine) +#endif + +#if defined(__GLASGOW_HASKELL__) + +import System.IO (hGetBufNonBlocking) +import System.IO.Error (isEOFError) + +import GHC.Handle +import GHC.Prim (Word#, (+#), writeWord8OffAddr#) +import GHC.Base (build) +import GHC.Word hiding (Word8) +import GHC.Ptr (Ptr(..)) +import GHC.ST (ST(..)) +import GHC.IOBase + +#endif + +-- An alternative to Control.Exception (assert) for nhc98 +#ifdef __NHC__ +#define assert assertS "__FILE__ : __LINE__" +assertS :: String -> Bool -> a -> a +assertS _ True = id +assertS s False = error ("assertion failed at "++s) +#endif + +-- ----------------------------------------------------------------------------- +-- +-- Useful macros, until we have bang patterns +-- + +#define STRICT1(f) f a | a `seq` False = undefined +#define STRICT2(f) f a b | a `seq` b `seq` False = undefined +#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined +#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined +#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined + +-- ----------------------------------------------------------------------------- + +instance Eq ByteString + where (==) = eq + +instance Ord ByteString + where compare = compareBytes + +instance Monoid ByteString where + mempty = empty + mappend = append + mconcat = concat + +{- +instance Arbitrary PackedString where + arbitrary = P.pack `fmap` arbitrary + coarbitrary s = coarbitrary (P.unpack s) +-} + +-- | /O(n)/ Equality on the 'ByteString' type. +eq :: ByteString -> ByteString -> Bool +eq a@(PS p s l) b@(PS p' s' l') + | l /= l' = False -- short cut on length + | p == p' && s == s' = True -- short cut for the same string + | otherwise = compareBytes a b == EQ +{-# INLINE eq #-} + +-- | /O(n)/ 'compareBytes' provides an 'Ordering' for 'ByteStrings' supporting slices. +compareBytes :: ByteString -> ByteString -> Ordering +compareBytes (PS x1 s1 l1) (PS x2 s2 l2) + | l1 == 0 && l2 == 0 = EQ -- short cut for empty strings + | x1 == x2 && s1 == s2 && l1 == l2 = EQ -- short cut for the same string + | otherwise = inlinePerformIO $ + withForeignPtr x1 $ \p1 -> + withForeignPtr x2 $ \p2 -> do + i <- memcmp (p1 `plusPtr` s1) (p2 `plusPtr` s2) (fromIntegral $ min l1 l2) + return $! case i `compare` 0 of + EQ -> l1 `compare` l2 + x -> x +{-# INLINE compareBytes #-} + +{- +-- +-- About 4x slower over 32M +-- +compareBytes :: ByteString -> ByteString -> Ordering +compareBytes (PS fp1 off1 len1) (PS fp2 off2 len2) = inlinePerformIO $ + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> + cmp (p1 `plusPtr` off1) + (p2 `plusPtr` off2) 0 len1 len2 + +cmp :: Ptr Word8 -> Ptr Word8 -> Int -> Int -> Int-> IO Ordering +STRICT5(cmp) +cmp p1 p2 n len1 len2 + | n == len1 = if n == len2 then return EQ else return LT + | n == len2 = return GT + | otherwise = do + (a :: Word8) <- peekByteOff p1 n + (b :: Word8) <- peekByteOff p2 n + case a `compare` b of + EQ -> cmp p1 p2 (n+1) len1 len2 + LT -> return LT + GT -> return GT +{-# INLINE compareBytes #-} +-} + +-- ----------------------------------------------------------------------------- +-- Introducing and eliminating 'ByteString's + +-- | /O(1)/ The empty 'ByteString' +empty :: ByteString +empty = PS nullForeignPtr 0 0 + +-- | /O(1)/ Convert a 'Word8' into a 'ByteString' +singleton :: Word8 -> ByteString +singleton c = unsafeCreate 1 $ \p -> poke p c +{-# INLINE [1] singleton #-} + +-- +-- XXX The unsafePerformIO is critical! +-- +-- Otherwise: +-- +-- singleton 255 `compare` singleton 127 +-- +-- is compiled to: +-- +-- case mallocByteString 2 of +-- ForeignPtr f internals -> +-- case writeWord8OffAddr# f 0 255 of _ -> +-- case writeWord8OffAddr# f 0 127 of _ -> +-- case eqAddr# f f of +-- False -> case compare (GHC.Prim.plusAddr# f 0) +-- (GHC.Prim.plusAddr# f 0) +-- +-- + +-- | /O(n)/ Convert a '[Word8]' into a 'ByteString'. +-- +-- For applications with large numbers of string literals, pack can be a +-- bottleneck. In such cases, consider using packAddress (GHC only). +pack :: [Word8] -> ByteString + +#if !defined(__GLASGOW_HASKELL__) + +pack str = unsafeCreate (P.length str) $ \p -> go p str + where + go _ [] = return () + go p (x:xs) = poke p x >> go (p `plusPtr` 1) xs -- less space than pokeElemOff + +#else /* hack away */ + +pack str = unsafeCreate (P.length str) $ \(Ptr p) -> stToIO (go p 0# str) + where + go _ _ [] = return () + go p i (W8# c:cs) = writeByte p i c >> go p (i +# 1#) cs + + writeByte p i c = ST $ \s# -> + case writeWord8OffAddr# p i c s# of s2# -> (# s2#, () #) + +#endif + +-- | /O(n)/ Converts a 'ByteString' to a '[Word8]'. +unpack :: ByteString -> [Word8] + +#if !defined(__GLASGOW_HASKELL__) + +unpack (PS _ _ 0) = [] +unpack (PS ps s l) = inlinePerformIO $ withForeignPtr ps $ \p -> + go (p `plusPtr` s) (l - 1) [] + where + STRICT3(go) + go p 0 acc = peek p >>= \e -> return (e : acc) + go p n acc = peekByteOff p n >>= \e -> go p (n-1) (e : acc) +{-# INLINE unpack #-} + +#else + +unpack ps = build (unpackFoldr ps) +{-# INLINE unpack #-} + +-- +-- critical this isn't strict in the acc +-- as it will break in the presence of list fusion. this is a known +-- issue with seq and build/foldr rewrite rules, which rely on lazy +-- demanding to avoid bottoms in the list. +-- +unpackFoldr :: ByteString -> (Word8 -> a -> a) -> a -> a +unpackFoldr (PS fp off len) f ch = withPtr fp $ \p -> do + let loop q n _ | q `seq` n `seq` False = undefined -- n.b. + loop _ (-1) acc = return acc + loop q n acc = do + a <- peekByteOff q n + loop q (n-1) (a `f` acc) + loop (p `plusPtr` off) (len-1) ch +{-# INLINE [0] unpackFoldr #-} + +unpackList :: ByteString -> [Word8] +unpackList (PS fp off len) = withPtr fp $ \p -> do + let STRICT3(loop) + loop _ (-1) acc = return acc + loop q n acc = do + a <- peekByteOff q n + loop q (n-1) (a : acc) + loop (p `plusPtr` off) (len-1) [] + +{-# RULES + "FPS unpack-list" [1] forall p . unpackFoldr p (:) [] = unpackList p + #-} + +#endif + +-- --------------------------------------------------------------------- +-- Basic interface + +-- | /O(1)/ Test whether a ByteString is empty. +null :: ByteString -> Bool +null (PS _ _ l) = assert (l >= 0) $ l <= 0 +{-# INLINE null #-} + +-- --------------------------------------------------------------------- +-- | /O(1)/ 'length' returns the length of a ByteString as an 'Int'. +length :: ByteString -> Int +length (PS _ _ l) = assert (l >= 0) $ l + +-- +-- length/loop fusion. When taking the length of any fuseable loop, +-- rewrite it as a foldl', and thus avoid allocating the result buffer +-- worth around 10% in speed testing. +-- + +#if defined(__GLASGOW_HASKELL__) +{-# INLINE [1] length #-} +#endif + +lengthU :: ByteString -> Int +lengthU = foldl' (const . (+1)) (0::Int) +{-# INLINE lengthU #-} + +{-# RULES + +-- v2 fusion +"FPS length/loop" forall loop s . + length (loopArr (loopWrapper loop s)) = + lengthU (loopArr (loopWrapper loop s)) + + #-} + +------------------------------------------------------------------------ + +-- | /O(n)/ 'cons' is analogous to (:) for lists, but of different +-- complexity, as it requires a memcpy. +cons :: Word8 -> ByteString -> ByteString +cons c (PS x s l) = unsafeCreate (l+1) $ \p -> withForeignPtr x $ \f -> do + poke p c + memcpy (p `plusPtr` 1) (f `plusPtr` s) (fromIntegral l) +{-# INLINE cons #-} + +-- | /O(n)/ Append a byte to the end of a 'ByteString' +snoc :: ByteString -> Word8 -> ByteString +snoc (PS x s l) c = unsafeCreate (l+1) $ \p -> withForeignPtr x $ \f -> do + memcpy p (f `plusPtr` s) (fromIntegral l) + poke (p `plusPtr` l) c +{-# INLINE snoc #-} + +-- todo fuse + +-- | /O(1)/ Extract the first element of a ByteString, which must be non-empty. +-- An exception will be thrown in the case of an empty ByteString. +head :: ByteString -> Word8 +head (PS x s l) + | l <= 0 = errorEmptyList "head" + | otherwise = inlinePerformIO $ withForeignPtr x $ \p -> peekByteOff p s +{-# INLINE head #-} + +-- | /O(1)/ Extract the elements after the head of a ByteString, which must be non-empty. +-- An exception will be thrown in the case of an empty ByteString. +tail :: ByteString -> ByteString +tail (PS p s l) + | l <= 0 = errorEmptyList "tail" + | otherwise = PS p (s+1) (l-1) +{-# INLINE tail #-} + +-- | /O(1)/ Extract the head and tail of a ByteString, returning Nothing +-- if it is empty. +uncons :: ByteString -> Maybe (Word8, ByteString) +uncons (PS x s l) + | l <= 0 = Nothing + | otherwise = Just (inlinePerformIO $ withForeignPtr x + $ \p -> peekByteOff p s, + PS x (s+1) (l-1)) +{-# INLINE uncons #-} + +-- | /O(1)/ Extract the last element of a ByteString, which must be finite and non-empty. +-- An exception will be thrown in the case of an empty ByteString. +last :: ByteString -> Word8 +last ps@(PS x s l) + | null ps = errorEmptyList "last" + | otherwise = inlinePerformIO $ withForeignPtr x $ \p -> peekByteOff p (s+l-1) +{-# INLINE last #-} + +-- | /O(1)/ Return all the elements of a 'ByteString' except the last one. +-- An exception will be thrown in the case of an empty ByteString. +init :: ByteString -> ByteString +init ps@(PS p s l) + | null ps = errorEmptyList "init" + | otherwise = PS p s (l-1) +{-# INLINE init #-} + +-- | /O(n)/ Append two ByteStrings +append :: ByteString -> ByteString -> ByteString +append xs ys | null xs = ys + | null ys = xs + | otherwise = concat [xs,ys] +{-# INLINE append #-} + +-- --------------------------------------------------------------------- +-- Transformations + +-- | /O(n)/ 'map' @f xs@ is the ByteString obtained by applying @f@ to each +-- element of @xs@. This function is subject to array fusion. +map :: (Word8 -> Word8) -> ByteString -> ByteString +#if defined(LOOPU_FUSION) +map f = loopArr . loopU (mapEFL f) NoAcc +#elif defined(LOOPUP_FUSION) +map f = loopArr . loopUp (mapEFL f) NoAcc +#elif defined(LOOPNOACC_FUSION) +map f = loopArr . loopNoAcc (mapEFL f) +#else +map f = loopArr . loopMap f +#endif +{-# INLINE map #-} + +{- +-- | /O(n)/ Like 'map', but not fuseable. The benefit is that it is +-- slightly faster for one-shot cases. +map' :: (Word8 -> Word8) -> ByteString -> ByteString +map' f (PS fp s len) = inlinePerformIO $ withForeignPtr fp $ \a -> + create len $ map_ 0 (a `plusPtr` s) + where + map_ :: Int -> Ptr Word8 -> Ptr Word8 -> IO () + STRICT3(map_) + map_ n p1 p2 + | n >= len = return () + | otherwise = do + x <- peekByteOff p1 n + pokeByteOff p2 n (f x) + map_ (n+1) p1 p2 +{-# INLINE map' #-} +-} + +-- | /O(n)/ 'reverse' @xs@ efficiently returns the elements of @xs@ in reverse order. +reverse :: ByteString -> ByteString +reverse (PS x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f -> + c_reverse p (f `plusPtr` s) (fromIntegral l) + +-- | /O(n)/ The 'intersperse' function takes a 'Word8' and a +-- 'ByteString' and \`intersperses\' that byte between the elements of +-- the 'ByteString'. It is analogous to the intersperse function on +-- Lists. +intersperse :: Word8 -> ByteString -> ByteString +intersperse c ps@(PS x s l) + | length ps < 2 = ps + | otherwise = unsafeCreate (2*l-1) $ \p -> withForeignPtr x $ \f -> + c_intersperse p (f `plusPtr` s) (fromIntegral l) c + +{- +intersperse c = pack . List.intersperse c . unpack +-} + +-- | The 'transpose' function transposes the rows and columns of its +-- 'ByteString' argument. +transpose :: [ByteString] -> [ByteString] +transpose ps = P.map pack (List.transpose (P.map unpack ps)) + +-- --------------------------------------------------------------------- +-- Reducing 'ByteString's + +-- | 'foldl', applied to a binary operator, a starting value (typically +-- the left-identity of the operator), and a ByteString, reduces the +-- ByteString using the binary operator, from left to right. +-- This function is subject to array fusion. +foldl :: (a -> Word8 -> a) -> a -> ByteString -> a +#if !defined(LOOPU_FUSION) +foldl f z = loopAcc . loopUp (foldEFL f) z +#else +foldl f z = loopAcc . loopU (foldEFL f) z +#endif +{-# INLINE foldl #-} + +{- +-- +-- About twice as fast with 6.4.1, but not fuseable +-- A simple fold . map is enough to make it worth while. +-- +foldl f v (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr -> + lgo v (ptr `plusPtr` s) (ptr `plusPtr` (s+l)) + where + STRICT3(lgo) + lgo z p q | p == q = return z + | otherwise = do c <- peek p + lgo (f z c) (p `plusPtr` 1) q +-} + +-- | 'foldl\'' is like 'foldl', but strict in the accumulator. +-- Though actually foldl is also strict in the accumulator. +foldl' :: (a -> Word8 -> a) -> a -> ByteString -> a +foldl' = foldl +-- foldl' f z = loopAcc . loopU (foldEFL' f) z +{-# INLINE foldl' #-} + +-- | 'foldr', applied to a binary operator, a starting value +-- (typically the right-identity of the operator), and a ByteString, +-- reduces the ByteString using the binary operator, from right to left. +foldr :: (Word8 -> a -> a) -> a -> ByteString -> a +foldr k z = loopAcc . loopDown (foldEFL (flip k)) z +{-# INLINE foldr #-} + +-- | 'foldr\'' is like 'foldr', but strict in the accumulator. +foldr' :: (Word8 -> a -> a) -> a -> ByteString -> a +foldr' k v (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr -> + go v (ptr `plusPtr` (s+l-1)) (ptr `plusPtr` (s-1)) + where + STRICT3(go) + go z p q | p == q = return z + | otherwise = do c <- peek p + go (c `k` z) (p `plusPtr` (-1)) q -- tail recursive +{-# INLINE [1] foldr' #-} + +-- | 'foldl1' is a variant of 'foldl' that has no starting value +-- argument, and thus must be applied to non-empty 'ByteStrings'. +-- This function is subject to array fusion. +-- An exception will be thrown in the case of an empty ByteString. +foldl1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 +foldl1 f ps + | null ps = errorEmptyList "foldl1" + | otherwise = foldl f (unsafeHead ps) (unsafeTail ps) +{-# INLINE foldl1 #-} + +-- | 'foldl1\'' is like 'foldl1', but strict in the accumulator. +-- An exception will be thrown in the case of an empty ByteString. +foldl1' :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 +foldl1' f ps + | null ps = errorEmptyList "foldl1'" + | otherwise = foldl' f (unsafeHead ps) (unsafeTail ps) +{-# INLINE foldl1' #-} + +-- | 'foldr1' is a variant of 'foldr' that has no starting value argument, +-- and thus must be applied to non-empty 'ByteString's +-- An exception will be thrown in the case of an empty ByteString. +foldr1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 +foldr1 f ps + | null ps = errorEmptyList "foldr1" + | otherwise = foldr f (last ps) (init ps) +{-# INLINE foldr1 #-} + +-- | 'foldr1\'' is a variant of 'foldr1', but is strict in the +-- accumulator. +foldr1' :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 +foldr1' f ps + | null ps = errorEmptyList "foldr1" + | otherwise = foldr' f (last ps) (init ps) +{-# INLINE [1] foldr1' #-} + +-- --------------------------------------------------------------------- +-- Special folds + +-- | /O(n)/ Concatenate a list of ByteStrings. +concat :: [ByteString] -> ByteString +concat [] = empty +concat [ps] = ps +concat xs = unsafeCreate len $ \ptr -> go xs ptr + where len = P.sum . P.map length $ xs + STRICT2(go) + go [] _ = return () + go (PS p s l:ps) ptr = do + withForeignPtr p $ \fp -> memcpy ptr (fp `plusPtr` s) (fromIntegral l) + go ps (ptr `plusPtr` l) + +-- | Map a function over a 'ByteString' and concatenate the results +concatMap :: (Word8 -> ByteString) -> ByteString -> ByteString +concatMap f = concat . foldr ((:) . f) [] + +-- foldr (append . f) empty + +-- | /O(n)/ Applied to a predicate and a ByteString, 'any' determines if +-- any element of the 'ByteString' satisfies the predicate. +any :: (Word8 -> Bool) -> ByteString -> Bool +any _ (PS _ _ 0) = False +any f (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr -> + go (ptr `plusPtr` s) (ptr `plusPtr` (s+l)) + where + STRICT2(go) + go p q | p == q = return False + | otherwise = do c <- peek p + if f c then return True + else go (p `plusPtr` 1) q + +-- todo fuse + +-- | /O(n)/ Applied to a predicate and a 'ByteString', 'all' determines +-- if all elements of the 'ByteString' satisfy the predicate. +all :: (Word8 -> Bool) -> ByteString -> Bool +all _ (PS _ _ 0) = True +all f (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr -> + go (ptr `plusPtr` s) (ptr `plusPtr` (s+l)) + where + STRICT2(go) + go p q | p == q = return True -- end of list + | otherwise = do c <- peek p + if f c + then go (p `plusPtr` 1) q + else return False + +------------------------------------------------------------------------ + +-- | /O(n)/ 'maximum' returns the maximum value from a 'ByteString' +-- This function will fuse. +-- An exception will be thrown in the case of an empty ByteString. +maximum :: ByteString -> Word8 +maximum xs@(PS x s l) + | null xs = errorEmptyList "maximum" + | otherwise = inlinePerformIO $ withForeignPtr x $ \p -> + c_maximum (p `plusPtr` s) (fromIntegral l) + +-- | /O(n)/ 'minimum' returns the minimum value from a 'ByteString' +-- This function will fuse. +-- An exception will be thrown in the case of an empty ByteString. +minimum :: ByteString -> Word8 +minimum xs@(PS x s l) + | null xs = errorEmptyList "minimum" + | otherwise = inlinePerformIO $ withForeignPtr x $ \p -> + c_minimum (p `plusPtr` s) (fromIntegral l) + +-- +-- minimum/maximum/loop fusion. As for length (and other folds), when we +-- see we're applied after a fuseable op, switch from using the C +-- version, to the fuseable version. The result should then avoid +-- allocating a buffer. +-- + +#if defined(__GLASGOW_HASKELL__) +{-# INLINE [1] minimum #-} +{-# INLINE [1] maximum #-} +#endif + +maximumU :: ByteString -> Word8 +maximumU = foldl1' max +{-# INLINE maximumU #-} + +minimumU :: ByteString -> Word8 +minimumU = foldl1' min +{-# INLINE minimumU #-} + +{-# RULES + +"FPS minimum/loop" forall loop s . + minimum (loopArr (loopWrapper loop s)) = + minimumU (loopArr (loopWrapper loop s)) + +"FPS maximum/loop" forall loop s . + maximum (loopArr (loopWrapper loop s)) = + maximumU (loopArr (loopWrapper loop s)) + + #-} + +------------------------------------------------------------------------ + +-- | The 'mapAccumL' function behaves like a combination of 'map' and +-- 'foldl'; it applies a function to each element of a ByteString, +-- passing an accumulating parameter from left to right, and returning a +-- final value of this accumulator together with the new list. +mapAccumL :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) +#if !defined(LOOPU_FUSION) +mapAccumL f z = unSP . loopUp (mapAccumEFL f) z +#else +mapAccumL f z = unSP . loopU (mapAccumEFL f) z +#endif +{-# INLINE mapAccumL #-} + +-- | The 'mapAccumR' function behaves like a combination of 'map' and +-- 'foldr'; it applies a function to each element of a ByteString, +-- passing an accumulating parameter from right to left, and returning a +-- final value of this accumulator together with the new ByteString. +mapAccumR :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) +mapAccumR f z = unSP . loopDown (mapAccumEFL f) z +{-# INLINE mapAccumR #-} + +-- | /O(n)/ map Word8 functions, provided with the index at each position +mapIndexed :: (Int -> Word8 -> Word8) -> ByteString -> ByteString +mapIndexed f = loopArr . loopUp (mapIndexEFL f) 0 +{-# INLINE mapIndexed #-} + +-- --------------------------------------------------------------------- +-- Building ByteStrings + +-- | 'scanl' is similar to 'foldl', but returns a list of successive +-- reduced values from the left. This function will fuse. +-- +-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +-- +-- Note that +-- +-- > last (scanl f z xs) == foldl f z xs. +scanl :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString +#if !defined(LOOPU_FUSION) +scanl f z ps = loopArr . loopUp (scanEFL f) z $ (ps `snoc` 0) +#else +scanl f z ps = loopArr . loopU (scanEFL f) z $ (ps `snoc` 0) +#endif + + -- n.b. haskell's List scan returns a list one bigger than the + -- input, so we need to snoc here to get some extra space, however, + -- it breaks map/up fusion (i.e. scanl . map no longer fuses) +{-# INLINE scanl #-} + +-- | 'scanl1' is a variant of 'scanl' that has no starting value argument. +-- This function will fuse. +-- +-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] +scanl1 :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString +scanl1 f ps + | null ps = empty + | otherwise = scanl f (unsafeHead ps) (unsafeTail ps) +{-# INLINE scanl1 #-} + +-- | scanr is the right-to-left dual of scanl. +scanr :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString +scanr f z ps = loopArr . loopDown (scanEFL (flip f)) z $ (0 `cons` ps) -- extra space +{-# INLINE scanr #-} + +-- | 'scanr1' is a variant of 'scanr' that has no starting value argument. +scanr1 :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString +scanr1 f ps + | null ps = empty + | otherwise = scanr f (last ps) (init ps) -- todo, unsafe versions +{-# INLINE scanr1 #-} + +-- --------------------------------------------------------------------- +-- Unfolds and replicates + +-- | /O(n)/ 'replicate' @n x@ is a ByteString of length @n@ with @x@ +-- the value of every element. The following holds: +-- +-- > replicate w c = unfoldr w (\u -> Just (u,u)) c +-- +-- This implemenation uses @memset(3)@ +replicate :: Int -> Word8 -> ByteString +replicate w c + | w <= 0 = empty + | otherwise = unsafeCreate w $ \ptr -> + memset ptr c (fromIntegral w) >> return () + +-- | /O(n)/, where /n/ is the length of the result. The 'unfoldr' +-- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a +-- ByteString from a seed value. The function takes the element and +-- returns 'Nothing' if it is done producing the ByteString or returns +-- 'Just' @(a,b)@, in which case, @a@ is the next byte in the string, +-- and @b@ is the seed value for further production. +-- +-- Examples: +-- +-- > unfoldr (\x -> if x <= 5 then Just (x, x + 1) else Nothing) 0 +-- > == pack [0, 1, 2, 3, 4, 5] +-- +unfoldr :: (a -> Maybe (Word8, a)) -> a -> ByteString +unfoldr f = concat . unfoldChunk 32 64 + where unfoldChunk n n' x = + case unfoldrN n f x of + (s, Nothing) -> s : [] + (s, Just x') -> s : unfoldChunk n' (n+n') x' + +-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a ByteString from a seed +-- value. However, the length of the result is limited by the first +-- argument to 'unfoldrN'. This function is more efficient than 'unfoldr' +-- when the maximum length of the result is known. +-- +-- The following equation relates 'unfoldrN' and 'unfoldr': +-- +-- > unfoldrN n f s == take n (unfoldr f s) +-- +unfoldrN :: Int -> (a -> Maybe (Word8, a)) -> a -> (ByteString, Maybe a) +unfoldrN i f x0 + | i < 0 = (empty, Just x0) + | otherwise = unsafePerformIO $ createAndTrim' i $ \p -> go p x0 0 + where STRICT3(go) + go p x n = + case f x of + Nothing -> return (0, n, Nothing) + Just (w,x') + | n == i -> return (0, n, Just x) + | otherwise -> do poke p w + go (p `plusPtr` 1) x' (n+1) + +-- --------------------------------------------------------------------- +-- Substrings + +-- | /O(1)/ 'take' @n@, applied to a ByteString @xs@, returns the prefix +-- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@. +take :: Int -> ByteString -> ByteString +take n ps@(PS x s l) + | n <= 0 = empty + | n >= l = ps + | otherwise = PS x s n +{-# INLINE take #-} + +-- | /O(1)/ 'drop' @n xs@ returns the suffix of @xs@ after the first @n@ +-- elements, or @[]@ if @n > 'length' xs@. +drop :: Int -> ByteString -> ByteString +drop n ps@(PS x s l) + | n <= 0 = ps + | n >= l = empty + | otherwise = PS x (s+n) (l-n) +{-# INLINE drop #-} + +-- | /O(1)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@. +splitAt :: Int -> ByteString -> (ByteString, ByteString) +splitAt n ps@(PS x s l) + | n <= 0 = (empty, ps) + | n >= l = (ps, empty) + | otherwise = (PS x s n, PS x (s+n) (l-n)) +{-# INLINE splitAt #-} + +-- | 'takeWhile', applied to a predicate @p@ and a ByteString @xs@, +-- returns the longest prefix (possibly empty) of @xs@ of elements that +-- satisfy @p@. +takeWhile :: (Word8 -> Bool) -> ByteString -> ByteString +takeWhile f ps = unsafeTake (findIndexOrEnd (not . f) ps) ps +{-# INLINE takeWhile #-} + +-- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@. +dropWhile :: (Word8 -> Bool) -> ByteString -> ByteString +dropWhile f ps = unsafeDrop (findIndexOrEnd (not . f) ps) ps +{-# INLINE dropWhile #-} + +-- instead of findIndexOrEnd, we could use memchr here. + +-- | 'break' @p@ is equivalent to @'span' ('not' . p)@. +break :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) +break p ps = case findIndexOrEnd p ps of n -> (unsafeTake n ps, unsafeDrop n ps) +{-# INLINE [1] break #-} + +{-# RULES +"FPS specialise break (x==)" forall x. + break ((==) x) = breakByte x + #-} + +#if __GLASGOW_HASKELL__ >= 605 +{-# RULES +"FPS specialise break (==x)" forall x. + break (==x) = breakByte x + #-} +#endif + +-- | 'breakByte' breaks its ByteString argument at the first occurence +-- of the specified byte. It is more efficient than 'break' as it is +-- implemented with @memchr(3)@. I.e. +-- +-- > break (=='c') "abcd" == breakByte 'c' "abcd" +-- +breakByte :: Word8 -> ByteString -> (ByteString, ByteString) +breakByte c p = case elemIndex c p of + Nothing -> (p,empty) + Just n -> (unsafeTake n p, unsafeDrop n p) +{-# INLINE breakByte #-} + +-- | 'breakEnd' behaves like 'break' but from the end of the 'ByteString' +-- +-- breakEnd p == spanEnd (not.p) +breakEnd :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) +breakEnd p ps = splitAt (findFromEndUntil p ps) ps + +-- | 'span' @p xs@ breaks the ByteString into two segments. It is +-- equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@ +span :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) +span p ps = break (not . p) ps +{-# INLINE [1] span #-} + +-- | 'spanByte' breaks its ByteString argument at the first +-- occurence of a byte other than its argument. It is more efficient +-- than 'span (==)' +-- +-- > span (=='c') "abcd" == spanByte 'c' "abcd" +-- +spanByte :: Word8 -> ByteString -> (ByteString, ByteString) +spanByte c ps@(PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> + go (p `plusPtr` s) 0 + where + STRICT2(go) + go p i | i >= l = return (ps, empty) + | otherwise = do c' <- peekByteOff p i + if c /= c' + then return (unsafeTake i ps, unsafeDrop i ps) + else go p (i+1) +{-# INLINE spanByte #-} + +{-# RULES +"FPS specialise span (x==)" forall x. + span ((==) x) = spanByte x + #-} + +#if __GLASGOW_HASKELL__ >= 605 +{-# RULES +"FPS specialise span (==x)" forall x. + span (==x) = spanByte x + #-} +#endif + +-- | 'spanEnd' behaves like 'span' but from the end of the 'ByteString'. +-- We have +-- +-- > spanEnd (not.isSpace) "x y z" == ("x y ","z") +-- +-- and +-- +-- > spanEnd (not . isSpace) ps +-- > == +-- > let (x,y) = span (not.isSpace) (reverse ps) in (reverse y, reverse x) +-- +spanEnd :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) +spanEnd p ps = splitAt (findFromEndUntil (not.p) ps) ps + +-- | /O(n)/ Splits a 'ByteString' into components delimited by +-- separators, where the predicate returns True for a separator element. +-- The resulting components do not contain the separators. Two adjacent +-- separators result in an empty component in the output. eg. +-- +-- > splitWith (=='a') "aabbaca" == ["","","bb","c",""] +-- > splitWith (=='a') [] == [] +-- +splitWith :: (Word8 -> Bool) -> ByteString -> [ByteString] + +#if defined(__GLASGOW_HASKELL__) +splitWith _pred (PS _ _ 0) = [] +splitWith pred_ (PS fp off len) = splitWith0 pred# off len fp + where pred# c# = pred_ (W8# c#) + + STRICT4(splitWith0) + splitWith0 pred' off' len' fp' = withPtr fp $ \p -> + splitLoop pred' p 0 off' len' fp' + + splitLoop :: (Word# -> Bool) + -> Ptr Word8 + -> Int -> Int -> Int + -> ForeignPtr Word8 + -> IO [ByteString] + + splitLoop pred' p idx' off' len' fp' + | pred' `seq` p `seq` idx' `seq` off' `seq` len' `seq` fp' `seq` False = undefined + | idx' >= len' = return [PS fp' off' idx'] + | otherwise = do + w <- peekElemOff p (off'+idx') + if pred' (case w of W8# w# -> w#) + then return (PS fp' off' idx' : + splitWith0 pred' (off'+idx'+1) (len'-idx'-1) fp') + else splitLoop pred' p (idx'+1) off' len' fp' +{-# INLINE splitWith #-} + +#else +splitWith _ (PS _ _ 0) = [] +splitWith p ps = loop p ps + where + STRICT2(loop) + loop q qs = if null rest then [chunk] + else chunk : loop q (unsafeTail rest) + where (chunk,rest) = break q qs +#endif + +-- | /O(n)/ Break a 'ByteString' into pieces separated by the byte +-- argument, consuming the delimiter. I.e. +-- +-- > split '\n' "a\nb\nd\ne" == ["a","b","d","e"] +-- > split 'a' "aXaXaXa" == ["","X","X","X",""] +-- > split 'x' "x" == ["",""] +-- +-- and +-- +-- > intercalate [c] . split c == id +-- > split == splitWith . (==) +-- +-- As for all splitting functions in this library, this function does +-- not copy the substrings, it just constructs new 'ByteStrings' that +-- are slices of the original. +-- +split :: Word8 -> ByteString -> [ByteString] +split _ (PS _ _ 0) = [] +split w (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do + let ptr = p `plusPtr` s + + STRICT1(loop) + loop n = + let q = inlinePerformIO $ memchr (ptr `plusPtr` n) + w (fromIntegral (l-n)) + in if q == nullPtr + then [PS x (s+n) (l-n)] + else let i = q `minusPtr` ptr in PS x (s+n) (i-n) : loop (i+1) + + return (loop 0) +{-# INLINE split #-} + +{- +-- slower. but stays inside Haskell. +split _ (PS _ _ 0) = [] +split (W8# w#) (PS fp off len) = splitWith' off len fp + where + splitWith' off' len' fp' = withPtr fp $ \p -> + splitLoop p 0 off' len' fp' + + splitLoop :: Ptr Word8 + -> Int -> Int -> Int + -> ForeignPtr Word8 + -> IO [ByteString] + + STRICT5(splitLoop) + splitLoop p idx' off' len' fp' + | p `seq` idx' `seq` off' `seq` len' `seq` fp' `seq` False = undefined + | idx' >= len' = return [PS fp' off' idx'] + | otherwise = do + (W8# x#) <- peekElemOff p (off'+idx') + if word2Int# w# ==# word2Int# x# + then return (PS fp' off' idx' : + splitWith' (off'+idx'+1) (len'-idx'-1) fp') + else splitLoop p (idx'+1) off' len' fp' +-} + +{- +-- | Like 'splitWith', except that sequences of adjacent separators are +-- treated as a single separator. eg. +-- +-- > tokens (=='a') "aabbaca" == ["bb","c"] +-- +tokens :: (Word8 -> Bool) -> ByteString -> [ByteString] +tokens f = P.filter (not.null) . splitWith f +{-# INLINE tokens #-} +-} + +-- | The 'group' function takes a ByteString and returns a list of +-- ByteStrings such that the concatenation of the result is equal to the +-- argument. Moreover, each sublist in the result contains only equal +-- elements. For example, +-- +-- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"] +-- +-- It is a special case of 'groupBy', which allows the programmer to +-- supply their own equality test. It is about 40% faster than +-- /groupBy (==)/ +group :: ByteString -> [ByteString] +group xs + | null xs = [] + | otherwise = ys : group zs + where + (ys, zs) = spanByte (unsafeHead xs) xs + +-- | The 'groupBy' function is the non-overloaded version of 'group'. +groupBy :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString] +groupBy k xs + | null xs = [] + | otherwise = unsafeTake n xs : groupBy k (unsafeDrop n xs) + where + n = 1 + findIndexOrEnd (not . k (unsafeHead xs)) (unsafeTail xs) + +-- | /O(n)/ The 'intercalate' function takes a 'ByteString' and a list of +-- 'ByteString's and concatenates the list after interspersing the first +-- argument between each element of the list. +intercalate :: ByteString -> [ByteString] -> ByteString +intercalate s = concat . (List.intersperse s) +{-# INLINE [1] intercalate #-} + +join :: ByteString -> [ByteString] -> ByteString +join = intercalate +{-# DEPRECATED join "use intercalate" #-} + +{-# RULES +"FPS specialise intercalate c -> intercalateByte" forall c s1 s2 . + intercalate (singleton c) (s1 : s2 : []) = intercalateWithByte c s1 s2 + #-} + +-- | /O(n)/ intercalateWithByte. An efficient way to join to two ByteStrings +-- with a char. Around 4 times faster than the generalised join. +-- +intercalateWithByte :: Word8 -> ByteString -> ByteString -> ByteString +intercalateWithByte c f@(PS ffp s l) g@(PS fgp t m) = unsafeCreate len $ \ptr -> + withForeignPtr ffp $ \fp -> + withForeignPtr fgp $ \gp -> do + memcpy ptr (fp `plusPtr` s) (fromIntegral l) + poke (ptr `plusPtr` l) c + memcpy (ptr `plusPtr` (l + 1)) (gp `plusPtr` t) (fromIntegral m) + where + len = length f + length g + 1 +{-# INLINE intercalateWithByte #-} + +-- --------------------------------------------------------------------- +-- Indexing ByteStrings + +-- | /O(1)/ 'ByteString' index (subscript) operator, starting from 0. +index :: ByteString -> Int -> Word8 +index ps n + | n < 0 = moduleError "index" ("negative index: " ++ show n) + | n >= length ps = moduleError "index" ("index too large: " ++ show n + ++ ", length = " ++ show (length ps)) + | otherwise = ps `unsafeIndex` n +{-# INLINE index #-} + +-- | /O(n)/ The 'elemIndex' function returns the index of the first +-- element in the given 'ByteString' which is equal to the query +-- element, or 'Nothing' if there is no such element. +-- This implementation uses memchr(3). +elemIndex :: Word8 -> ByteString -> Maybe Int +elemIndex c (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do + let p' = p `plusPtr` s + q <- memchr p' c (fromIntegral l) + return $! if q == nullPtr then Nothing else Just $! q `minusPtr` p' +{-# INLINE elemIndex #-} + +-- | /O(n)/ The 'elemIndexEnd' function returns the last index of the +-- element in the given 'ByteString' which is equal to the query +-- element, or 'Nothing' if there is no such element. The following +-- holds: +-- +-- > elemIndexEnd c xs == +-- > (-) (length xs - 1) `fmap` elemIndex c (reverse xs) +-- +elemIndexEnd :: Word8 -> ByteString -> Maybe Int +elemIndexEnd ch (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> + go (p `plusPtr` s) (l-1) + where + STRICT2(go) + go p i | i < 0 = return Nothing + | otherwise = do ch' <- peekByteOff p i + if ch == ch' + then return $ Just i + else go p (i-1) +{-# INLINE elemIndexEnd #-} + +-- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning +-- the indices of all elements equal to the query element, in ascending order. +-- This implementation uses memchr(3). +elemIndices :: Word8 -> ByteString -> [Int] +elemIndices w (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do + let ptr = p `plusPtr` s + + STRICT1(loop) + loop n = let q = inlinePerformIO $ memchr (ptr `plusPtr` n) + w (fromIntegral (l - n)) + in if q == nullPtr + then [] + else let i = q `minusPtr` ptr + in i : loop (i+1) + return $! loop 0 +{-# INLINE elemIndices #-} + +{- +-- much slower +elemIndices :: Word8 -> ByteString -> [Int] +elemIndices c ps = loop 0 ps + where STRICT2(loop) + loop _ ps' | null ps' = [] + loop n ps' | c == unsafeHead ps' = n : loop (n+1) (unsafeTail ps') + | otherwise = loop (n+1) (unsafeTail ps') +-} + +-- | count returns the number of times its argument appears in the ByteString +-- +-- > count = length . elemIndices +-- +-- But more efficiently than using length on the intermediate list. +count :: Word8 -> ByteString -> Int +count w (PS x s m) = inlinePerformIO $ withForeignPtr x $ \p -> + fmap fromIntegral $ c_count (p `plusPtr` s) (fromIntegral m) w +{-# INLINE count #-} + +{- +-- +-- around 30% slower +-- +count w (PS x s m) = inlinePerformIO $ withForeignPtr x $ \p -> + go (p `plusPtr` s) (fromIntegral m) 0 + where + go :: Ptr Word8 -> CSize -> Int -> IO Int + STRICT3(go) + go p l i = do + q <- memchr p w l + if q == nullPtr + then return i + else do let k = fromIntegral $ q `minusPtr` p + go (q `plusPtr` 1) (l-k-1) (i+1) +-} + +-- | The 'findIndex' function takes a predicate and a 'ByteString' and +-- returns the index of the first element in the ByteString +-- satisfying the predicate. +findIndex :: (Word8 -> Bool) -> ByteString -> Maybe Int +findIndex k (PS x s l) = inlinePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0 + where + STRICT2(go) + go ptr n | n >= l = return Nothing + | otherwise = do w <- peek ptr + if k w + then return (Just n) + else go (ptr `plusPtr` 1) (n+1) +{-# INLINE findIndex #-} + +-- | The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending order. +findIndices :: (Word8 -> Bool) -> ByteString -> [Int] +findIndices p ps = loop 0 ps + where + STRICT2(loop) + loop n qs | null qs = [] + | p (unsafeHead qs) = n : loop (n+1) (unsafeTail qs) + | otherwise = loop (n+1) (unsafeTail qs) + +-- --------------------------------------------------------------------- +-- Searching ByteStrings + +-- | /O(n)/ 'elem' is the 'ByteString' membership predicate. +elem :: Word8 -> ByteString -> Bool +elem c ps = case elemIndex c ps of Nothing -> False ; _ -> True +{-# INLINE elem #-} + +-- | /O(n)/ 'notElem' is the inverse of 'elem' +notElem :: Word8 -> ByteString -> Bool +notElem c ps = not (elem c ps) +{-# INLINE notElem #-} + +-- | /O(n)/ 'filter', applied to a predicate and a ByteString, +-- returns a ByteString containing those characters that satisfy the +-- predicate. This function is subject to array fusion. +filter :: (Word8 -> Bool) -> ByteString -> ByteString +#if defined(LOOPU_FUSION) +filter p = loopArr . loopU (filterEFL p) NoAcc +#elif defined(LOOPUP_FUSION) +filter p = loopArr . loopUp (filterEFL p) NoAcc +#elif defined(LOOPNOACC_FUSION) +filter p = loopArr . loopNoAcc (filterEFL p) +#else +filter f = loopArr . loopFilter f +#endif +{-# INLINE filter #-} + +{- +-- | /O(n)/ 'filter\'' is a non-fuseable version of filter, that may be +-- around 2x faster for some one-shot applications. +filter' :: (Word8 -> Bool) -> ByteString -> ByteString +filter' k ps@(PS x s l) + | null ps = ps + | otherwise = unsafePerformIO $ createAndTrim l $ \p -> withForeignPtr x $ \f -> do + t <- go (f `plusPtr` s) p (f `plusPtr` (s + l)) + return $! t `minusPtr` p -- actual length + where + STRICT3(go) + go f t end | f == end = return t + | otherwise = do + w <- peek f + if k w + then poke t w >> go (f `plusPtr` 1) (t `plusPtr` 1) end + else go (f `plusPtr` 1) t end +{-# INLINE filter' #-} +-} + +-- +-- | /O(n)/ A first order equivalent of /filter . (==)/, for the common +-- case of filtering a single byte. It is more efficient to use +-- /filterByte/ in this case. +-- +-- > filterByte == filter . (==) +-- +-- filterByte is around 10x faster, and uses much less space, than its +-- filter equivalent +-- +filterByte :: Word8 -> ByteString -> ByteString +filterByte w ps = replicate (count w ps) w +{-# INLINE filterByte #-} + +{-# RULES + "FPS specialise filter (== x)" forall x. + filter ((==) x) = filterByte x + #-} + +#if __GLASGOW_HASKELL__ >= 605 +{-# RULES + "FPS specialise filter (== x)" forall x. + filter (== x) = filterByte x + #-} +#endif + +-- | /O(n)/ The 'find' function takes a predicate and a ByteString, +-- and returns the first element in matching the predicate, or 'Nothing' +-- if there is no such element. +-- +-- > find f p = case findIndex f p of Just n -> Just (p ! n) ; _ -> Nothing +-- +find :: (Word8 -> Bool) -> ByteString -> Maybe Word8 +find f p = case findIndex f p of + Just n -> Just (p `unsafeIndex` n) + _ -> Nothing +{-# INLINE find #-} + +{- +-- +-- fuseable, but we don't want to walk the whole array. +-- +find k = foldl findEFL Nothing + where findEFL a@(Just _) _ = a + findEFL _ c | k c = Just c + | otherwise = Nothing +-} + +-- | /O(n)/ The 'partition' function takes a predicate a ByteString and returns +-- the pair of ByteStrings with elements which do and do not satisfy the +-- predicate, respectively; i.e., +-- +-- > partition p bs == (filter p xs, filter (not . p) xs) +-- +partition :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) +partition p bs = (filter p bs, filter (not . p) bs) +--TODO: use a better implementation + +-- --------------------------------------------------------------------- +-- Searching for substrings + +-- | /O(n)/ The 'isPrefixOf' function takes two ByteStrings and returns 'True' +-- iff the first is a prefix of the second. +isPrefixOf :: ByteString -> ByteString -> Bool +isPrefixOf (PS x1 s1 l1) (PS x2 s2 l2) + | l1 == 0 = True + | l2 < l1 = False + | otherwise = inlinePerformIO $ withForeignPtr x1 $ \p1 -> + withForeignPtr x2 $ \p2 -> do + i <- memcmp (p1 `plusPtr` s1) (p2 `plusPtr` s2) (fromIntegral l1) + return $! i == 0 + +-- | /O(n)/ The 'isSuffixOf' function takes two ByteStrings and returns 'True' +-- iff the first is a suffix of the second. +-- +-- The following holds: +-- +-- > isSuffixOf x y == reverse x `isPrefixOf` reverse y +-- +-- However, the real implemenation uses memcmp to compare the end of the +-- string only, with no reverse required.. +isSuffixOf :: ByteString -> ByteString -> Bool +isSuffixOf (PS x1 s1 l1) (PS x2 s2 l2) + | l1 == 0 = True + | l2 < l1 = False + | otherwise = inlinePerformIO $ withForeignPtr x1 $ \p1 -> + withForeignPtr x2 $ \p2 -> do + i <- memcmp (p1 `plusPtr` s1) (p2 `plusPtr` s2 `plusPtr` (l2 - l1)) (fromIntegral l1) + return $! i == 0 + +-- | Alias of 'isSubstringOf' +isInfixOf :: ByteString -> ByteString -> Bool +isInfixOf = isSubstringOf + +-- | Check whether one string is a substring of another. @isSubstringOf +-- p s@ is equivalent to @not (null (findSubstrings p s))@. +isSubstringOf :: ByteString -- ^ String to search for. + -> ByteString -- ^ String to search in. + -> Bool +isSubstringOf p s = not $ P.null $ findSubstrings p s + +{-# DEPRECATED findSubstring "Do not use. The ByteString searching api is about to be replaced." #-} +-- | Get the first index of a substring in another string, +-- or 'Nothing' if the string is not found. +-- @findSubstring p s@ is equivalent to @listToMaybe (findSubstrings p s)@. +findSubstring :: ByteString -- ^ String to search for. + -> ByteString -- ^ String to seach in. + -> Maybe Int +findSubstring = (listToMaybe .) . findSubstrings + +{-# DEPRECATED findSubstrings "Do not use. The ByteString searching api is about to be replaced." #-} +-- | Find the indexes of all (possibly overlapping) occurances of a +-- substring in a string. This function uses the Knuth-Morris-Pratt +-- string matching algorithm. +findSubstrings :: ByteString -- ^ String to search for. + -> ByteString -- ^ String to seach in. + -> [Int] + +findSubstrings pat@(PS _ _ m) str@(PS _ _ n) = search 0 0 + where + patc x = pat `unsafeIndex` x + strc x = str `unsafeIndex` x + + -- maybe we should make kmpNext a UArray before using it in search? + kmpNext = listArray (0,m) (-1:kmpNextL pat (-1)) + kmpNextL p _ | null p = [] + kmpNextL p j = let j' = next (unsafeHead p) j + 1 + ps = unsafeTail p + x = if not (null ps) && unsafeHead ps == patc j' + then kmpNext Array.! j' else j' + in x:kmpNextL ps j' + search i j = match ++ rest -- i: position in string, j: position in pattern + where match = if j == m then [(i - j)] else [] + rest = if i == n then [] else search (i+1) (next (strc i) j + 1) + next c j | j >= 0 && (j == m || c /= patc j) = next c (kmpNext Array.! j) + | otherwise = j + +-- --------------------------------------------------------------------- +-- Zipping + +-- | /O(n)/ 'zip' takes two ByteStrings and returns a list of +-- corresponding pairs of bytes. If one input ByteString is short, +-- excess elements of the longer ByteString are discarded. This is +-- equivalent to a pair of 'unpack' operations. +zip :: ByteString -> ByteString -> [(Word8,Word8)] +zip ps qs + | null ps || null qs = [] + | otherwise = (unsafeHead ps, unsafeHead qs) : zip (unsafeTail ps) (unsafeTail qs) + +-- | 'zipWith' generalises 'zip' by zipping with the function given as +-- the first argument, instead of a tupling function. For example, +-- @'zipWith' (+)@ is applied to two ByteStrings to produce the list of +-- corresponding sums. +zipWith :: (Word8 -> Word8 -> a) -> ByteString -> ByteString -> [a] +zipWith f ps qs + | null ps || null qs = [] + | otherwise = f (unsafeHead ps) (unsafeHead qs) : zipWith f (unsafeTail ps) (unsafeTail qs) +#if defined(__GLASGOW_HASKELL__) +{-# INLINE [1] zipWith #-} +#endif + +-- +-- | A specialised version of zipWith for the common case of a +-- simultaneous map over two bytestrings, to build a 3rd. Rewrite rules +-- are used to automatically covert zipWith into zipWith' when a pack is +-- performed on the result of zipWith, but we also export it for +-- convenience. +-- +zipWith' :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString -> ByteString +zipWith' f (PS fp s l) (PS fq t m) = inlinePerformIO $ + withForeignPtr fp $ \a -> + withForeignPtr fq $ \b -> + create len $ zipWith_ 0 (a `plusPtr` s) (b `plusPtr` t) + where + zipWith_ :: Int -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> IO () + STRICT4(zipWith_) + zipWith_ n p1 p2 r + | n >= len = return () + | otherwise = do + x <- peekByteOff p1 n + y <- peekByteOff p2 n + pokeByteOff r n (f x y) + zipWith_ (n+1) p1 p2 r + + len = min l m +{-# INLINE zipWith' #-} + +{-# RULES + +"FPS specialise zipWith" forall (f :: Word8 -> Word8 -> Word8) p q . + zipWith f p q = unpack (zipWith' f p q) + + #-} + +-- | /O(n)/ 'unzip' transforms a list of pairs of bytes into a pair of +-- ByteStrings. Note that this performs two 'pack' operations. +unzip :: [(Word8,Word8)] -> (ByteString,ByteString) +unzip ls = (pack (P.map fst ls), pack (P.map snd ls)) +{-# INLINE unzip #-} + +-- --------------------------------------------------------------------- +-- Special lists + +-- | /O(n)/ Return all initial segments of the given 'ByteString', shortest first. +inits :: ByteString -> [ByteString] +inits (PS x s l) = [PS x s n | n <- [0..l]] + +-- | /O(n)/ Return all final segments of the given 'ByteString', longest first. +tails :: ByteString -> [ByteString] +tails p | null p = [empty] + | otherwise = p : tails (unsafeTail p) + +-- less efficent spacewise: tails (PS x s l) = [PS x (s+n) (l-n) | n <- [0..l]] + +-- --------------------------------------------------------------------- +-- ** Ordered 'ByteString's + +-- | /O(n)/ Sort a ByteString efficiently, using counting sort. +sort :: ByteString -> ByteString +sort (PS input s l) = unsafeCreate l $ \p -> allocaArray 256 $ \arr -> do + + memset (castPtr arr) 0 (256 * fromIntegral (sizeOf (undefined :: CSize))) + withForeignPtr input (\x -> countOccurrences arr (x `plusPtr` s) l) + + let STRICT2(go) + go 256 _ = return () + go i ptr = do n <- peekElemOff arr i + when (n /= 0) $ memset ptr (fromIntegral i) n >> return () + go (i + 1) (ptr `plusPtr` (fromIntegral n)) + go 0 p + +{- +sort :: ByteString -> ByteString +sort (PS x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f -> do + memcpy p (f `plusPtr` s) l + c_qsort p l -- inplace +-} + +-- The 'sortBy' function is the non-overloaded version of 'sort'. +-- +-- Try some linear sorts: radix, counting +-- Or mergesort. +-- +-- sortBy :: (Word8 -> Word8 -> Ordering) -> ByteString -> ByteString +-- sortBy f ps = undefined + +-- --------------------------------------------------------------------- +-- Low level constructors + +-- | /O(n) construction/ Use a @ByteString@ with a function requiring a +-- null-terminated @CString@. The @CString@ will be freed +-- automatically. This is a memcpy(3). +useAsCString :: ByteString -> (CString -> IO a) -> IO a +useAsCString (PS fp o l) action = do + allocaBytes (l+1) $ \buf -> + withForeignPtr fp $ \p -> do + memcpy buf (p `plusPtr` o) (fromIntegral l) + pokeByteOff buf l (0::Word8) + action (castPtr buf) + +-- | /O(n) construction/ Use a @ByteString@ with a function requiring a @CStringLen@. +-- As for @useAsCString@ this function makes a copy of the original @ByteString@. +useAsCStringLen :: ByteString -> (CStringLen -> IO a) -> IO a +useAsCStringLen p@(PS _ _ l) f = useAsCString p $ \cstr -> f (cstr,l) + +------------------------------------------------------------------------ + +-- | /O(n)./ Construct a new @ByteString@ from a @CString@. The +-- resulting @ByteString@ is an immutable copy of the original +-- @CString@, and is managed on the Haskell heap. The original +-- @CString@ must be null terminated. +packCString :: CString -> IO ByteString +packCString cstr = do + len <- c_strlen cstr + packCStringLen (cstr, fromIntegral len) + +-- | /O(n)./ Construct a new @ByteString@ from a @CStringLen@. The +-- resulting @ByteString@ is an immutable copy of the original @CStringLen@. +-- The @ByteString@ is a normal Haskell value and will be managed on the +-- Haskell heap. +packCStringLen :: CStringLen -> IO ByteString +packCStringLen (cstr, len) = create len $ \p -> + memcpy p (castPtr cstr) (fromIntegral len) + +------------------------------------------------------------------------ + +-- | /O(n)/ Make a copy of the 'ByteString' with its own storage. +-- This is mainly useful to allow the rest of the data pointed +-- to by the 'ByteString' to be garbage collected, for example +-- if a large string has been read in, and only a small part of it +-- is needed in the rest of the program. +-- +copy :: ByteString -> ByteString +copy (PS x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f -> + memcpy p (f `plusPtr` s) (fromIntegral l) + +-- --------------------------------------------------------------------- +-- line IO + +-- | Read a line from stdin. +getLine :: IO ByteString +getLine = hGetLine stdin + +{- +-- | Lazily construct a list of lines of ByteStrings. This will be much +-- better on memory consumption than using 'hGetContents >>= lines' +-- If you're considering this, a better choice might be to use +-- Data.ByteString.Lazy +hGetLines :: Handle -> IO [ByteString] +hGetLines h = go + where + go = unsafeInterleaveIO $ do + e <- hIsEOF h + if e + then return [] + else do + x <- hGetLine h + xs <- go + return (x:xs) +-} + +-- | Read a line from a handle + +hGetLine :: Handle -> IO ByteString +#if !defined(__GLASGOW_HASKELL__) +hGetLine h = System.IO.hGetLine h >>= return . pack . P.map c2w +#else +hGetLine h = wantReadableHandle "Data.ByteString.hGetLine" h $ \ handle_ -> do + case haBufferMode handle_ of + NoBuffering -> error "no buffering" + _other -> hGetLineBuffered handle_ + + where + hGetLineBuffered handle_ = do + let ref = haBuffer handle_ + buf <- readIORef ref + hGetLineBufferedLoop handle_ ref buf 0 [] + + hGetLineBufferedLoop handle_ ref + buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } len xss = + len `seq` do + off <- findEOL r w raw + let new_len = len + off - r + xs <- mkPS raw r off + + -- if eol == True, then off is the offset of the '\n' + -- otherwise off == w and the buffer is now empty. + if off /= w + then do if (w == off + 1) + then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } + else writeIORef ref buf{ bufRPtr = off + 1 } + mkBigPS new_len (xs:xss) + else do + maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_) + buf{ bufWPtr=0, bufRPtr=0 } + case maybe_buf of + -- Nothing indicates we caught an EOF, and we may have a + -- partial line to return. + Nothing -> do + writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } + if new_len > 0 + then mkBigPS new_len (xs:xss) + else ioe_EOF + Just new_buf -> + hGetLineBufferedLoop handle_ ref new_buf new_len (xs:xss) + + -- find the end-of-line character, if there is one + findEOL r w raw + | r == w = return w + | otherwise = do + (c,r') <- readCharFromBuffer raw r + if c == '\n' + then return r -- NB. not r': don't include the '\n' + else findEOL r' w raw + + maybeFillReadBuffer fd is_line is_stream buf = catch + (do buf' <- fillReadBuffer fd is_line is_stream buf + return (Just buf')) + (\e -> if isEOFError e then return Nothing else ioError e) + +-- TODO, rewrite to use normal memcpy +mkPS :: RawBuffer -> Int -> Int -> IO ByteString +mkPS buf start end = + let len = end - start + in create len $ \p -> do + memcpy_ptr_baoff p buf (fromIntegral start) (fromIntegral len) + return () + +mkBigPS :: Int -> [ByteString] -> IO ByteString +mkBigPS _ [ps] = return ps +mkBigPS _ pss = return $! concat (P.reverse pss) + +#endif + +-- --------------------------------------------------------------------- +-- Block IO + +-- | Outputs a 'ByteString' to the specified 'Handle'. +hPut :: Handle -> ByteString -> IO () +hPut _ (PS _ _ 0) = return () +hPut h (PS ps s l) = withForeignPtr ps $ \p-> hPutBuf h (p `plusPtr` s) l + +-- | A synonym for @hPut@, for compatibility +hPutStr :: Handle -> ByteString -> IO () +hPutStr = hPut + +-- | Write a ByteString to a handle, appending a newline byte +hPutStrLn :: Handle -> ByteString -> IO () +hPutStrLn h ps + | length ps < 1024 = hPut h (ps `snoc` 0x0a) + | otherwise = hPut h ps >> hPut h (singleton (0x0a)) -- don't copy + +-- | Write a ByteString to stdout +putStr :: ByteString -> IO () +putStr = hPut stdout + +-- | Write a ByteString to stdout, appending a newline byte +putStrLn :: ByteString -> IO () +putStrLn = hPutStrLn stdout + +-- | Read a 'ByteString' directly from the specified 'Handle'. This +-- is far more efficient than reading the characters into a 'String' +-- and then using 'pack'. +hGet :: Handle -> Int -> IO ByteString +hGet _ 0 = return empty +hGet h i = createAndTrim i $ \p -> hGetBuf h p i + +-- | hGetNonBlocking is identical to 'hGet', except that it will never block +-- waiting for data to become available, instead it returns only whatever data +-- is available. +hGetNonBlocking :: Handle -> Int -> IO ByteString +#if defined(__GLASGOW_HASKELL__) +hGetNonBlocking _ 0 = return empty +hGetNonBlocking h i = createAndTrim i $ \p -> hGetBufNonBlocking h p i +#else +hGetNonBlocking = hGet +#endif + +-- | Read entire handle contents into a 'ByteString'. +-- This function reads chunks at a time, doubling the chunksize on each +-- read. The final buffer is then realloced to the appropriate size. For +-- files > half of available memory, this may lead to memory exhaustion. +-- Consider using 'readFile' in this case. +-- +-- As with 'hGet', the string representation in the file is assumed to +-- be ISO-8859-1. +-- +hGetContents :: Handle -> IO ByteString +hGetContents h = do + let start_size = 1024 + p <- mallocBytes start_size + i <- hGetBuf h p start_size + if i < start_size + then do p' <- reallocBytes p i + fp <- newForeignPtr finalizerFree p' + return $! PS fp 0 i + else f p start_size + where + f p s = do + let s' = 2 * s + p' <- reallocBytes p s' + i <- hGetBuf h (p' `plusPtr` s) s + if i < s + then do let i' = s + i + p'' <- reallocBytes p' i' + fp <- newForeignPtr finalizerFree p'' + return $! PS fp 0 i' + else f p' s' + +-- | getContents. Equivalent to hGetContents stdin +getContents :: IO ByteString +getContents = hGetContents stdin + +-- | The interact function takes a function of type @ByteString -> ByteString@ +-- as its argument. The entire input from the standard input device is passed +-- to this function as its argument, and the resulting string is output on the +-- standard output device. It's great for writing one line programs! +interact :: (ByteString -> ByteString) -> IO () +interact transformer = putStr . transformer =<< getContents + +-- | Read an entire file strictly into a 'ByteString'. This is far more +-- efficient than reading the characters into a 'String' and then using +-- 'pack'. It also may be more efficient than opening the file and +-- reading it using hGet. Files are read using 'binary mode' on Windows, +-- for 'text mode' use the Char8 version of this function. +readFile :: FilePath -> IO ByteString +readFile f = bracket (openBinaryFile f ReadMode) hClose + (\h -> hFileSize h >>= hGet h . fromIntegral) + +-- | Write a 'ByteString' to a file. +writeFile :: FilePath -> ByteString -> IO () +writeFile f txt = bracket (openBinaryFile f WriteMode) hClose + (\h -> hPut h txt) + +-- | Append a 'ByteString' to a file. +appendFile :: FilePath -> ByteString -> IO () +appendFile f txt = bracket (openBinaryFile f AppendMode) hClose + (\h -> hPut h txt) + +{- +-- +-- Disable until we can move it into a portable .hsc file +-- + +-- | Like readFile, this reads an entire file directly into a +-- 'ByteString', but it is even more efficient. It involves directly +-- mapping the file to memory. This has the advantage that the contents +-- of the file never need to be copied. Also, under memory pressure the +-- page may simply be discarded, while in the case of readFile it would +-- need to be written to swap. If you read many small files, mmapFile +-- will be less memory-efficient than readFile, since each mmapFile +-- takes up a separate page of memory. Also, you can run into bus +-- errors if the file is modified. As with 'readFile', the string +-- representation in the file is assumed to be ISO-8859-1. +-- +-- On systems without mmap, this is the same as a readFile. +-- +mmapFile :: FilePath -> IO ByteString +mmapFile f = mmap f >>= \(fp,l) -> return $! PS fp 0 l + +mmap :: FilePath -> IO (ForeignPtr Word8, Int) +mmap f = do + h <- openBinaryFile f ReadMode + l <- fromIntegral `fmap` hFileSize h + -- Don't bother mmaping small files because each mmapped file takes up + -- at least one full VM block. + if l < mmap_limit + then do thefp <- mallocByteString l + withForeignPtr thefp $ \p-> hGetBuf h p l + hClose h + return (thefp, l) + else do + -- unix only :( + fd <- fromIntegral `fmap` handleToFd h + p <- my_mmap l fd + fp <- if p == nullPtr + then do thefp <- mallocByteString l + withForeignPtr thefp $ \p' -> hGetBuf h p' l + return thefp + else do + -- The munmap leads to crashes on OpenBSD. + -- maybe there's a use after unmap in there somewhere? + -- Bulat suggests adding the hClose to the + -- finalizer, excellent idea. +#if !defined(__OpenBSD__) + let unmap = c_munmap p l >> return () +#else + let unmap = return () +#endif + fp <- newForeignPtr p unmap + return fp + c_close fd + hClose h + return (fp, l) + where mmap_limit = 16*1024 +-} + +-- --------------------------------------------------------------------- +-- Internal utilities + +-- | 'findIndexOrEnd' is a variant of findIndex, that returns the length +-- of the string if no element is found, rather than Nothing. +findIndexOrEnd :: (Word8 -> Bool) -> ByteString -> Int +findIndexOrEnd k (PS x s l) = inlinePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0 + where + STRICT2(go) + go ptr n | n >= l = return l + | otherwise = do w <- peek ptr + if k w + then return n + else go (ptr `plusPtr` 1) (n+1) +{-# INLINE findIndexOrEnd #-} + +-- | Perform an operation with a temporary ByteString +withPtr :: ForeignPtr a -> (Ptr a -> IO b) -> b +withPtr fp io = inlinePerformIO (withForeignPtr fp io) +{-# INLINE withPtr #-} + +-- Common up near identical calls to `error' to reduce the number +-- constant strings created when compiled: +errorEmptyList :: String -> a +errorEmptyList fun = moduleError fun "empty ByteString" +{-# NOINLINE errorEmptyList #-} + +moduleError :: String -> String -> a +moduleError fun msg = error ("Data.ByteString." ++ fun ++ ':':' ':msg) +{-# NOINLINE moduleError #-} + +-- Find from the end of the string using predicate +findFromEndUntil :: (Word8 -> Bool) -> ByteString -> Int +STRICT2(findFromEndUntil) +findFromEndUntil f ps@(PS x s l) = + if null ps then 0 + else if f (last ps) then l + else findFromEndUntil f (PS x s (l-1)) diff --git a/Data/ByteString/Char8.hs b/Data/ByteString/Char8.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Char8.hs @@ -0,0 +1,989 @@ +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} + +-- #prune + +-- | +-- Module : Data.ByteString.Char8 +-- Copyright : (c) Don Stewart 2006 +-- License : BSD-style +-- +-- Maintainer : dons@cse.unsw.edu.au +-- Stability : experimental +-- Portability : portable +-- +-- Manipulate 'ByteString's using 'Char' operations. All Chars will be +-- truncated to 8 bits. It can be expected that these functions will run +-- at identical speeds to their 'Word8' equivalents in "Data.ByteString". +-- +-- More specifically these byte strings are taken to be in the +-- subset of Unicode covered by code points 0-255. This covers +-- Unicode Basic Latin, Latin-1 Supplement and C0+C1 Controls. +-- +-- See: +-- +-- * +-- +-- * +-- +-- * +-- +-- This module is intended to be imported @qualified@, to avoid name +-- clashes with "Prelude" functions. eg. +-- +-- > import qualified Data.ByteString.Char8 as B +-- + +module Data.ByteString.Char8 ( + + -- * The @ByteString@ type + ByteString, -- abstract, instances: Eq, Ord, Show, Read, Data, Typeable, Monoid + + -- * Introducing and eliminating 'ByteString's + empty, -- :: ByteString + singleton, -- :: Char -> ByteString + pack, -- :: String -> ByteString + unpack, -- :: ByteString -> String + + -- * Basic interface + cons, -- :: Char -> ByteString -> ByteString + snoc, -- :: ByteString -> Char -> ByteString + append, -- :: ByteString -> ByteString -> ByteString + head, -- :: ByteString -> Char + uncons, -- :: ByteString -> Maybe (Char, ByteString) + last, -- :: ByteString -> Char + tail, -- :: ByteString -> ByteString + init, -- :: ByteString -> ByteString + null, -- :: ByteString -> Bool + length, -- :: ByteString -> Int + + -- * Transformating ByteStrings + map, -- :: (Char -> Char) -> ByteString -> ByteString + reverse, -- :: ByteString -> ByteString + intersperse, -- :: Char -> ByteString -> ByteString + intercalate, -- :: ByteString -> [ByteString] -> ByteString + transpose, -- :: [ByteString] -> [ByteString] + + -- * Reducing 'ByteString's (folds) + foldl, -- :: (a -> Char -> a) -> a -> ByteString -> a + foldl', -- :: (a -> Char -> a) -> a -> ByteString -> a + foldl1, -- :: (Char -> Char -> Char) -> ByteString -> Char + foldl1', -- :: (Char -> Char -> Char) -> ByteString -> Char + + foldr, -- :: (Char -> a -> a) -> a -> ByteString -> a + foldr', -- :: (Char -> a -> a) -> a -> ByteString -> a + foldr1, -- :: (Char -> Char -> Char) -> ByteString -> Char + foldr1', -- :: (Char -> Char -> Char) -> ByteString -> Char + + -- ** Special folds + concat, -- :: [ByteString] -> ByteString + concatMap, -- :: (Char -> ByteString) -> ByteString -> ByteString + any, -- :: (Char -> Bool) -> ByteString -> Bool + all, -- :: (Char -> Bool) -> ByteString -> Bool + maximum, -- :: ByteString -> Char + minimum, -- :: ByteString -> Char + + -- * Building ByteStrings + -- ** Scans + scanl, -- :: (Char -> Char -> Char) -> Char -> ByteString -> ByteString + scanl1, -- :: (Char -> Char -> Char) -> ByteString -> ByteString + scanr, -- :: (Char -> Char -> Char) -> Char -> ByteString -> ByteString + scanr1, -- :: (Char -> Char -> Char) -> ByteString -> ByteString + + -- ** Accumulating maps + mapAccumL, -- :: (acc -> Char -> (acc, Char)) -> acc -> ByteString -> (acc, ByteString) + mapAccumR, -- :: (acc -> Char -> (acc, Char)) -> acc -> ByteString -> (acc, ByteString) + mapIndexed, -- :: (Int -> Char -> Char) -> ByteString -> ByteString + + -- ** Generating and unfolding ByteStrings + replicate, -- :: Int -> Char -> ByteString + unfoldr, -- :: (a -> Maybe (Char, a)) -> a -> ByteString + unfoldrN, -- :: Int -> (a -> Maybe (Char, a)) -> a -> (ByteString, Maybe a) + + -- * Substrings + + -- ** Breaking strings + take, -- :: Int -> ByteString -> ByteString + drop, -- :: Int -> ByteString -> ByteString + splitAt, -- :: Int -> ByteString -> (ByteString, ByteString) + takeWhile, -- :: (Char -> Bool) -> ByteString -> ByteString + dropWhile, -- :: (Char -> Bool) -> ByteString -> ByteString + span, -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) + spanEnd, -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) + break, -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) + breakEnd, -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) + group, -- :: ByteString -> [ByteString] + groupBy, -- :: (Char -> Char -> Bool) -> ByteString -> [ByteString] + inits, -- :: ByteString -> [ByteString] + tails, -- :: ByteString -> [ByteString] + + -- ** Breaking into many substrings + split, -- :: Char -> ByteString -> [ByteString] + splitWith, -- :: (Char -> Bool) -> ByteString -> [ByteString] + + -- ** Breaking into lines and words + lines, -- :: ByteString -> [ByteString] + words, -- :: ByteString -> [ByteString] + unlines, -- :: [ByteString] -> ByteString + unwords, -- :: ByteString -> [ByteString] + + -- * Predicates + isPrefixOf, -- :: ByteString -> ByteString -> Bool + isSuffixOf, -- :: ByteString -> ByteString -> Bool + isInfixOf, -- :: ByteString -> ByteString -> Bool + isSubstringOf, -- :: ByteString -> ByteString -> Bool + + -- ** Search for arbitrary substrings + findSubstring, -- :: ByteString -> ByteString -> Maybe Int + findSubstrings, -- :: ByteString -> ByteString -> [Int] + + -- * Searching ByteStrings + + -- ** Searching by equality + elem, -- :: Char -> ByteString -> Bool + notElem, -- :: Char -> ByteString -> Bool + + -- ** Searching with a predicate + find, -- :: (Char -> Bool) -> ByteString -> Maybe Char + filter, -- :: (Char -> Bool) -> ByteString -> ByteString +-- partition -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) + + -- * Indexing ByteStrings + index, -- :: ByteString -> Int -> Char + elemIndex, -- :: Char -> ByteString -> Maybe Int + elemIndices, -- :: Char -> ByteString -> [Int] + elemIndexEnd, -- :: Char -> ByteString -> Maybe Int + findIndex, -- :: (Char -> Bool) -> ByteString -> Maybe Int + findIndices, -- :: (Char -> Bool) -> ByteString -> [Int] + count, -- :: Char -> ByteString -> Int + + -- * Zipping and unzipping ByteStrings + zip, -- :: ByteString -> ByteString -> [(Char,Char)] + zipWith, -- :: (Char -> Char -> c) -> ByteString -> ByteString -> [c] + unzip, -- :: [(Char,Char)] -> (ByteString,ByteString) + + -- * Ordered ByteStrings + sort, -- :: ByteString -> ByteString + + -- * Reading from ByteStrings + readInt, -- :: ByteString -> Maybe (Int, ByteString) + readInteger, -- :: ByteString -> Maybe (Integer, ByteString) + + -- * Low level CString conversions + + -- ** Copying ByteStrings + copy, -- :: ByteString -> ByteString + + -- ** Packing CStrings and pointers + packCString, -- :: CString -> IO ByteString + packCStringLen, -- :: CStringLen -> IO ByteString + + -- ** Using ByteStrings as CStrings + useAsCString, -- :: ByteString -> (CString -> IO a) -> IO a + useAsCStringLen, -- :: ByteString -> (CStringLen -> IO a) -> IO a + + -- * I\/O with 'ByteString's + + -- ** Standard input and output + getLine, -- :: IO ByteString + getContents, -- :: IO ByteString + putStr, -- :: ByteString -> IO () + putStrLn, -- :: ByteString -> IO () + interact, -- :: (ByteString -> ByteString) -> IO () + + -- ** Files + readFile, -- :: FilePath -> IO ByteString + writeFile, -- :: FilePath -> ByteString -> IO () + appendFile, -- :: FilePath -> ByteString -> IO () +-- mmapFile, -- :: FilePath -> IO ByteString + + -- ** I\/O with Handles + hGetLine, -- :: Handle -> IO ByteString + hGetContents, -- :: Handle -> IO ByteString + hGet, -- :: Handle -> Int -> IO ByteString + hGetNonBlocking, -- :: Handle -> Int -> IO ByteString + hPut, -- :: Handle -> ByteString -> IO () + hPutStr, -- :: Handle -> ByteString -> IO () + hPutStrLn, -- :: Handle -> ByteString -> IO () + + -- undocumented deprecated things: + join -- :: ByteString -> [ByteString] -> ByteString + + ) where + +import qualified Prelude as P +import Prelude hiding (reverse,head,tail,last,init,null + ,length,map,lines,foldl,foldr,unlines + ,concat,any,take,drop,splitAt,takeWhile + ,dropWhile,span,break,elem,filter,unwords + ,words,maximum,minimum,all,concatMap + ,scanl,scanl1,scanr,scanr1 + ,appendFile,readFile,writeFile + ,foldl1,foldr1,replicate + ,getContents,getLine,putStr,putStrLn,interact + ,zip,zipWith,unzip,notElem) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Unsafe as B + +-- Listy functions transparently exported +import Data.ByteString (empty,null,length,tail,init,append + ,inits,tails,reverse,transpose + ,concat,take,drop,splitAt,intercalate + ,sort,isPrefixOf,isSuffixOf,isInfixOf,isSubstringOf + ,findSubstring,findSubstrings,copy,group + + ,getLine, getContents, putStr, putStrLn, interact + ,hGetContents, hGet, hPut, hPutStr, hPutStrLn + ,hGetLine, hGetNonBlocking + ,packCString,packCStringLen + ,useAsCString,useAsCStringLen + ) + +import Data.ByteString.Internal (ByteString(PS), c2w, w2c, isSpaceWord8 + ,inlinePerformIO) + +#if defined(__GLASGOW_HASKELL__) +import Data.ByteString.Unsafe (unsafePackAddress) -- for the rule +#endif + +import Data.Char ( isSpace ) +import qualified Data.List as List (intersperse) + +import System.IO (openFile,hClose,hFileSize,IOMode(..)) +#ifndef __NHC__ +import Control.Exception (bracket) +#else +import IO (bracket) +#endif +import Foreign + +#if defined(__GLASGOW_HASKELL__) +import GHC.Base (Char(..),unpackCString#,ord#,int2Word#) +import GHC.IOBase (IO(..),stToIO) +import GHC.Prim (Addr#,writeWord8OffAddr#,plusAddr#) +import GHC.Ptr (Ptr(..)) +import GHC.ST (ST(..)) +#endif + +#define STRICT1(f) f a | a `seq` False = undefined +#define STRICT2(f) f a b | a `seq` b `seq` False = undefined +#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined +#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined + +------------------------------------------------------------------------ + +-- | /O(1)/ Convert a 'Char' into a 'ByteString' +singleton :: Char -> ByteString +singleton = B.singleton . c2w +{-# INLINE singleton #-} + +-- | /O(n)/ Convert a 'String' into a 'ByteString' +-- +-- For applications with large numbers of string literals, pack can be a +-- bottleneck. +pack :: String -> ByteString +#if !defined(__GLASGOW_HASKELL__) + +pack str = B.unsafeCreate (P.length str) $ \p -> go p str + where go _ [] = return () + go p (x:xs) = poke p (c2w x) >> go (p `plusPtr` 1) xs + +#else /* hack away */ + +pack str = B.unsafeCreate (P.length str) $ \(Ptr p) -> stToIO (go p str) + where + go :: Addr# -> [Char] -> ST a () + go _ [] = return () + go p (C# c:cs) = writeByte p (int2Word# (ord# c)) >> go (p `plusAddr#` 1#) cs + + writeByte p c = ST $ \s# -> + case writeWord8OffAddr# p 0# c s# of s2# -> (# s2#, () #) + {-# INLINE writeByte #-} +{-# INLINE [1] pack #-} + +{-# RULES + "FPS pack/packAddress" forall s . + pack (unpackCString# s) = inlinePerformIO (B.unsafePackAddress s) + #-} + +#endif + +-- | /O(n)/ Converts a 'ByteString' to a 'String'. +unpack :: ByteString -> [Char] +unpack = P.map w2c . B.unpack +{-# INLINE unpack #-} + +-- | /O(n)/ 'cons' is analogous to (:) for lists, but of different +-- complexity, as it requires a memcpy. +cons :: Char -> ByteString -> ByteString +cons = B.cons . c2w +{-# INLINE cons #-} + +-- | /O(n)/ Append a Char to the end of a 'ByteString'. Similar to +-- 'cons', this function performs a memcpy. +snoc :: ByteString -> Char -> ByteString +snoc p = B.snoc p . c2w +{-# INLINE snoc #-} + +-- | /O(1)/ Extract the head and tail of a ByteString, returning Nothing +-- if it is empty. +uncons :: ByteString -> Maybe (Char, ByteString) +uncons bs = case B.uncons bs of + Nothing -> Nothing + Just (w, bs') -> Just (w2c w, bs') +{-# INLINE uncons #-} + +-- | /O(1)/ Extract the first element of a ByteString, which must be non-empty. +head :: ByteString -> Char +head = w2c . B.head +{-# INLINE head #-} + +-- | /O(1)/ Extract the last element of a packed string, which must be non-empty. +last :: ByteString -> Char +last = w2c . B.last +{-# INLINE last #-} + +-- | /O(n)/ 'map' @f xs@ is the ByteString obtained by applying @f@ to each element of @xs@ +map :: (Char -> Char) -> ByteString -> ByteString +map f = B.map (c2w . f . w2c) +{-# INLINE map #-} + +-- | /O(n)/ The 'intersperse' function takes a Char and a 'ByteString' +-- and \`intersperses\' that Char between the elements of the +-- 'ByteString'. It is analogous to the intersperse function on Lists. +intersperse :: Char -> ByteString -> ByteString +intersperse = B.intersperse . c2w +{-# INLINE intersperse #-} + +join :: ByteString -> [ByteString] -> ByteString +join = intercalate +{-# DEPRECATED join "use intercalate" #-} + +-- | 'foldl', applied to a binary operator, a starting value (typically +-- the left-identity of the operator), and a ByteString, reduces the +-- ByteString using the binary operator, from left to right. +foldl :: (a -> Char -> a) -> a -> ByteString -> a +foldl f = B.foldl (\a c -> f a (w2c c)) +{-# INLINE foldl #-} + +-- | 'foldl\'' is like foldl, but strict in the accumulator. +foldl' :: (a -> Char -> a) -> a -> ByteString -> a +foldl' f = B.foldl' (\a c -> f a (w2c c)) +{-# INLINE foldl' #-} + +-- | 'foldr', applied to a binary operator, a starting value +-- (typically the right-identity of the operator), and a packed string, +-- reduces the packed string using the binary operator, from right to left. +foldr :: (Char -> a -> a) -> a -> ByteString -> a +foldr f = B.foldr (\c a -> f (w2c c) a) +{-# INLINE foldr #-} + +-- | 'foldr\'' is a strict variant of foldr +foldr' :: (Char -> a -> a) -> a -> ByteString -> a +foldr' f = B.foldr' (\c a -> f (w2c c) a) +{-# INLINE foldr' #-} + +-- | 'foldl1' is a variant of 'foldl' that has no starting value +-- argument, and thus must be applied to non-empty 'ByteStrings'. +foldl1 :: (Char -> Char -> Char) -> ByteString -> Char +foldl1 f ps = w2c (B.foldl1 (\x y -> c2w (f (w2c x) (w2c y))) ps) +{-# INLINE foldl1 #-} + +-- | A strict version of 'foldl1' +foldl1' :: (Char -> Char -> Char) -> ByteString -> Char +foldl1' f ps = w2c (B.foldl1' (\x y -> c2w (f (w2c x) (w2c y))) ps) +{-# INLINE foldl1' #-} + +-- | 'foldr1' is a variant of 'foldr' that has no starting value argument, +-- and thus must be applied to non-empty 'ByteString's +foldr1 :: (Char -> Char -> Char) -> ByteString -> Char +foldr1 f ps = w2c (B.foldr1 (\x y -> c2w (f (w2c x) (w2c y))) ps) +{-# INLINE foldr1 #-} + +-- | A strict variant of foldr1 +foldr1' :: (Char -> Char -> Char) -> ByteString -> Char +foldr1' f ps = w2c (B.foldr1' (\x y -> c2w (f (w2c x) (w2c y))) ps) +{-# INLINE foldr1' #-} + +-- | Map a function over a 'ByteString' and concatenate the results +concatMap :: (Char -> ByteString) -> ByteString -> ByteString +concatMap f = B.concatMap (f . w2c) +{-# INLINE concatMap #-} + +-- | Applied to a predicate and a ByteString, 'any' determines if +-- any element of the 'ByteString' satisfies the predicate. +any :: (Char -> Bool) -> ByteString -> Bool +any f = B.any (f . w2c) +{-# INLINE any #-} + +-- | Applied to a predicate and a 'ByteString', 'all' determines if +-- all elements of the 'ByteString' satisfy the predicate. +all :: (Char -> Bool) -> ByteString -> Bool +all f = B.all (f . w2c) +{-# INLINE all #-} + +-- | 'maximum' returns the maximum value from a 'ByteString' +maximum :: ByteString -> Char +maximum = w2c . B.maximum +{-# INLINE maximum #-} + +-- | 'minimum' returns the minimum value from a 'ByteString' +minimum :: ByteString -> Char +minimum = w2c . B.minimum +{-# INLINE minimum #-} + +-- | /O(n)/ map Char functions, provided with the index at each position +mapIndexed :: (Int -> Char -> Char) -> ByteString -> ByteString +mapIndexed f = B.mapIndexed (\i c -> c2w (f i (w2c c))) +{-# INLINE mapIndexed #-} + +-- | The 'mapAccumL' function behaves like a combination of 'map' and +-- 'foldl'; it applies a function to each element of a ByteString, +-- passing an accumulating parameter from left to right, and returning a +-- final value of this accumulator together with the new list. +mapAccumL :: (acc -> Char -> (acc, Char)) -> acc -> ByteString -> (acc, ByteString) +mapAccumL f = B.mapAccumL (\acc w -> case f acc (w2c w) of (acc', c) -> (acc', c2w c)) + +-- | The 'mapAccumR' function behaves like a combination of 'map' and +-- 'foldr'; it applies a function to each element of a ByteString, +-- passing an accumulating parameter from right to left, and returning a +-- final value of this accumulator together with the new ByteString. +mapAccumR :: (acc -> Char -> (acc, Char)) -> acc -> ByteString -> (acc, ByteString) +mapAccumR f = B.mapAccumR (\acc w -> case f acc (w2c w) of (acc', c) -> (acc', c2w c)) + +-- | 'scanl' is similar to 'foldl', but returns a list of successive +-- reduced values from the left: +-- +-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +-- +-- Note that +-- +-- > last (scanl f z xs) == foldl f z xs. +scanl :: (Char -> Char -> Char) -> Char -> ByteString -> ByteString +scanl f z = B.scanl (\a b -> c2w (f (w2c a) (w2c b))) (c2w z) + +-- | 'scanl1' is a variant of 'scanl' that has no starting value argument: +-- +-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] +scanl1 :: (Char -> Char -> Char) -> ByteString -> ByteString +scanl1 f = B.scanl1 (\a b -> c2w (f (w2c a) (w2c b))) + +-- | scanr is the right-to-left dual of scanl. +scanr :: (Char -> Char -> Char) -> Char -> ByteString -> ByteString +scanr f z = B.scanr (\a b -> c2w (f (w2c a) (w2c b))) (c2w z) + +-- | 'scanr1' is a variant of 'scanr' that has no starting value argument. +scanr1 :: (Char -> Char -> Char) -> ByteString -> ByteString +scanr1 f = B.scanr1 (\a b -> c2w (f (w2c a) (w2c b))) + +-- | /O(n)/ 'replicate' @n x@ is a ByteString of length @n@ with @x@ +-- the value of every element. The following holds: +-- +-- > replicate w c = unfoldr w (\u -> Just (u,u)) c +-- +-- This implemenation uses @memset(3)@ +replicate :: Int -> Char -> ByteString +replicate w = B.replicate w . c2w +{-# INLINE replicate #-} + +-- | /O(n)/, where /n/ is the length of the result. The 'unfoldr' +-- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a +-- ByteString from a seed value. The function takes the element and +-- returns 'Nothing' if it is done producing the ByteString or returns +-- 'Just' @(a,b)@, in which case, @a@ is the next character in the string, +-- and @b@ is the seed value for further production. +-- +-- Examples: +-- +-- > unfoldr (\x -> if x <= '9' then Just (x, succ x) else Nothing) '0' == "0123456789" +unfoldr :: (a -> Maybe (Char, a)) -> a -> ByteString +unfoldr f x0 = B.unfoldr (fmap k . f) x0 + where k (i, j) = (c2w i, j) + +-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a ByteString from a seed +-- value. However, the length of the result is limited by the first +-- argument to 'unfoldrN'. This function is more efficient than 'unfoldr' +-- when the maximum length of the result is known. +-- +-- The following equation relates 'unfoldrN' and 'unfoldr': +-- +-- > unfoldrN n f s == take n (unfoldr f s) +unfoldrN :: Int -> (a -> Maybe (Char, a)) -> a -> (ByteString, Maybe a) +unfoldrN n f w = B.unfoldrN n ((k `fmap`) . f) w + where k (i,j) = (c2w i, j) +{-# INLINE unfoldrN #-} + +-- | 'takeWhile', applied to a predicate @p@ and a ByteString @xs@, +-- returns the longest prefix (possibly empty) of @xs@ of elements that +-- satisfy @p@. +takeWhile :: (Char -> Bool) -> ByteString -> ByteString +takeWhile f = B.takeWhile (f . w2c) +{-# INLINE takeWhile #-} + +-- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@. +dropWhile :: (Char -> Bool) -> ByteString -> ByteString +dropWhile f = B.dropWhile (f . w2c) +#if defined(__GLASGOW_HASKELL__) +{-# INLINE [1] dropWhile #-} +#endif + +-- | 'break' @p@ is equivalent to @'span' ('not' . p)@. +break :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) +break f = B.break (f . w2c) +#if defined(__GLASGOW_HASKELL__) +{-# INLINE [1] break #-} +#endif + +-- | 'span' @p xs@ breaks the ByteString into two segments. It is +-- equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@ +span :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) +span f = B.span (f . w2c) +{-# INLINE span #-} + +-- | 'spanEnd' behaves like 'span' but from the end of the 'ByteString'. +-- We have +-- +-- > spanEnd (not.isSpace) "x y z" == ("x y ","z") +-- +-- and +-- +-- > spanEnd (not . isSpace) ps +-- > == +-- > let (x,y) = span (not.isSpace) (reverse ps) in (reverse y, reverse x) +-- +spanEnd :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) +spanEnd f = B.spanEnd (f . w2c) +{-# INLINE spanEnd #-} + +-- | 'breakEnd' behaves like 'break' but from the end of the 'ByteString' +-- +-- breakEnd p == spanEnd (not.p) +breakEnd :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) +breakEnd f = B.breakEnd (f . w2c) +{-# INLINE breakEnd #-} + +{- +-- | 'breakChar' breaks its ByteString argument at the first occurence +-- of the specified Char. It is more efficient than 'break' as it is +-- implemented with @memchr(3)@. I.e. +-- +-- > break (=='c') "abcd" == breakChar 'c' "abcd" +-- +breakChar :: Char -> ByteString -> (ByteString, ByteString) +breakChar = B.breakByte . c2w +{-# INLINE breakChar #-} + +-- | 'spanChar' breaks its ByteString argument at the first +-- occurence of a Char other than its argument. It is more efficient +-- than 'span (==)' +-- +-- > span (=='c') "abcd" == spanByte 'c' "abcd" +-- +spanChar :: Char -> ByteString -> (ByteString, ByteString) +spanChar = B.spanByte . c2w +{-# INLINE spanChar #-} +-} + +-- | /O(n)/ Break a 'ByteString' into pieces separated by the byte +-- argument, consuming the delimiter. I.e. +-- +-- > split '\n' "a\nb\nd\ne" == ["a","b","d","e"] +-- > split 'a' "aXaXaXa" == ["","X","X","X",""] +-- > split 'x' "x" == ["",""] +-- +-- and +-- +-- > intercalate [c] . split c == id +-- > split == splitWith . (==) +-- +-- As for all splitting functions in this library, this function does +-- not copy the substrings, it just constructs new 'ByteStrings' that +-- are slices of the original. +-- +split :: Char -> ByteString -> [ByteString] +split = B.split . c2w +{-# INLINE split #-} + +-- | /O(n)/ Splits a 'ByteString' into components delimited by +-- separators, where the predicate returns True for a separator element. +-- The resulting components do not contain the separators. Two adjacent +-- separators result in an empty component in the output. eg. +-- +-- > splitWith (=='a') "aabbaca" == ["","","bb","c",""] +-- +splitWith :: (Char -> Bool) -> ByteString -> [ByteString] +splitWith f = B.splitWith (f . w2c) +{-# INLINE splitWith #-} +-- the inline makes a big difference here. + +{- +-- | Like 'splitWith', except that sequences of adjacent separators are +-- treated as a single separator. eg. +-- +-- > tokens (=='a') "aabbaca" == ["bb","c"] +-- +tokens :: (Char -> Bool) -> ByteString -> [ByteString] +tokens f = B.tokens (f . w2c) +{-# INLINE tokens #-} +-} + +-- | The 'groupBy' function is the non-overloaded version of 'group'. +groupBy :: (Char -> Char -> Bool) -> ByteString -> [ByteString] +groupBy k = B.groupBy (\a b -> k (w2c a) (w2c b)) + +-- | /O(1)/ 'ByteString' index (subscript) operator, starting from 0. +index :: ByteString -> Int -> Char +index = (w2c .) . B.index +{-# INLINE index #-} + +-- | /O(n)/ The 'elemIndex' function returns the index of the first +-- element in the given 'ByteString' which is equal (by memchr) to the +-- query element, or 'Nothing' if there is no such element. +elemIndex :: Char -> ByteString -> Maybe Int +elemIndex = B.elemIndex . c2w +{-# INLINE elemIndex #-} + +-- | /O(n)/ The 'elemIndexEnd' function returns the last index of the +-- element in the given 'ByteString' which is equal to the query +-- element, or 'Nothing' if there is no such element. The following +-- holds: +-- +-- > elemIndexEnd c xs == +-- > (-) (length xs - 1) `fmap` elemIndex c (reverse xs) +-- +elemIndexEnd :: Char -> ByteString -> Maybe Int +elemIndexEnd = B.elemIndexEnd . c2w +{-# INLINE elemIndexEnd #-} + +-- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning +-- the indices of all elements equal to the query element, in ascending order. +elemIndices :: Char -> ByteString -> [Int] +elemIndices = B.elemIndices . c2w +{-# INLINE elemIndices #-} + +-- | The 'findIndex' function takes a predicate and a 'ByteString' and +-- returns the index of the first element in the ByteString satisfying the predicate. +findIndex :: (Char -> Bool) -> ByteString -> Maybe Int +findIndex f = B.findIndex (f . w2c) +{-# INLINE findIndex #-} + +-- | The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending order. +findIndices :: (Char -> Bool) -> ByteString -> [Int] +findIndices f = B.findIndices (f . w2c) + +-- | count returns the number of times its argument appears in the ByteString +-- +-- > count = length . elemIndices +-- +-- Also +-- +-- > count '\n' == length . lines +-- +-- But more efficiently than using length on the intermediate list. +count :: Char -> ByteString -> Int +count c = B.count (c2w c) + +-- | /O(n)/ 'elem' is the 'ByteString' membership predicate. This +-- implementation uses @memchr(3)@. +elem :: Char -> ByteString -> Bool +elem c = B.elem (c2w c) +{-# INLINE elem #-} + +-- | /O(n)/ 'notElem' is the inverse of 'elem' +notElem :: Char -> ByteString -> Bool +notElem c = B.notElem (c2w c) +{-# INLINE notElem #-} + +-- | /O(n)/ 'filter', applied to a predicate and a ByteString, +-- returns a ByteString containing those characters that satisfy the +-- predicate. +filter :: (Char -> Bool) -> ByteString -> ByteString +filter f = B.filter (f . w2c) +{-# INLINE filter #-} + +-- | /O(n)/ The 'find' function takes a predicate and a ByteString, +-- and returns the first element in matching the predicate, or 'Nothing' +-- if there is no such element. +find :: (Char -> Bool) -> ByteString -> Maybe Char +find f ps = w2c `fmap` B.find (f . w2c) ps +{-# INLINE find #-} + +{- +-- | /O(n)/ A first order equivalent of /filter . (==)/, for the common +-- case of filtering a single Char. It is more efficient to use +-- filterChar in this case. +-- +-- > filterChar == filter . (==) +-- +-- filterChar is around 10x faster, and uses much less space, than its +-- filter equivalent +-- +filterChar :: Char -> ByteString -> ByteString +filterChar c = B.filterByte (c2w c) +{-# INLINE filterChar #-} + +-- | /O(n)/ A first order equivalent of /filter . (\/=)/, for the common +-- case of filtering a single Char out of a list. It is more efficient +-- to use /filterNotChar/ in this case. +-- +-- > filterNotChar == filter . (/=) +-- +-- filterNotChar is around 3x faster, and uses much less space, than its +-- filter equivalent +-- +filterNotChar :: Char -> ByteString -> ByteString +filterNotChar c = B.filterNotByte (c2w c) +{-# INLINE filterNotChar #-} +-} + +-- | /O(n)/ 'zip' takes two ByteStrings and returns a list of +-- corresponding pairs of Chars. If one input ByteString is short, +-- excess elements of the longer ByteString are discarded. This is +-- equivalent to a pair of 'unpack' operations, and so space +-- usage may be large for multi-megabyte ByteStrings +zip :: ByteString -> ByteString -> [(Char,Char)] +zip ps qs + | B.null ps || B.null qs = [] + | otherwise = (unsafeHead ps, unsafeHead qs) : zip (B.unsafeTail ps) (B.unsafeTail qs) + +-- | 'zipWith' generalises 'zip' by zipping with the function given as +-- the first argument, instead of a tupling function. For example, +-- @'zipWith' (+)@ is applied to two ByteStrings to produce the list +-- of corresponding sums. +zipWith :: (Char -> Char -> a) -> ByteString -> ByteString -> [a] +zipWith f = B.zipWith ((. w2c) . f . w2c) + +-- | 'unzip' transforms a list of pairs of Chars into a pair of +-- ByteStrings. Note that this performs two 'pack' operations. +unzip :: [(Char,Char)] -> (ByteString,ByteString) +unzip ls = (pack (P.map fst ls), pack (P.map snd ls)) +{-# INLINE unzip #-} + +-- | A variety of 'head' for non-empty ByteStrings. 'unsafeHead' omits +-- the check for the empty case, which is good for performance, but +-- there is an obligation on the programmer to provide a proof that the +-- ByteString is non-empty. +unsafeHead :: ByteString -> Char +unsafeHead = w2c . B.unsafeHead +{-# INLINE unsafeHead #-} + +-- --------------------------------------------------------------------- +-- Things that depend on the encoding + +{-# RULES + "FPS specialise break -> breakSpace" + break isSpace = breakSpace + #-} + +-- | 'breakSpace' returns the pair of ByteStrings when the argument is +-- broken at the first whitespace byte. I.e. +-- +-- > break isSpace == breakSpace +-- +breakSpace :: ByteString -> (ByteString,ByteString) +breakSpace (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do + i <- firstspace (p `plusPtr` s) 0 l + return $! case () of {_ + | i == 0 -> (empty, PS x s l) + | i == l -> (PS x s l, empty) + | otherwise -> (PS x s i, PS x (s+i) (l-i)) + } +{-# INLINE breakSpace #-} + +firstspace :: Ptr Word8 -> Int -> Int -> IO Int +STRICT3(firstspace) +firstspace ptr n m + | n >= m = return n + | otherwise = do w <- peekByteOff ptr n + if (not . isSpaceWord8) w then firstspace ptr (n+1) m else return n + +{-# RULES + "FPS specialise dropWhile isSpace -> dropSpace" + dropWhile isSpace = dropSpace + #-} + +-- | 'dropSpace' efficiently returns the 'ByteString' argument with +-- white space Chars removed from the front. It is more efficient than +-- calling dropWhile for removing whitespace. I.e. +-- +-- > dropWhile isSpace == dropSpace +-- +dropSpace :: ByteString -> ByteString +dropSpace (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do + i <- firstnonspace (p `plusPtr` s) 0 l + return $! if i == l then empty else PS x (s+i) (l-i) +{-# INLINE dropSpace #-} + +firstnonspace :: Ptr Word8 -> Int -> Int -> IO Int +STRICT3(firstnonspace) +firstnonspace ptr n m + | n >= m = return n + | otherwise = do w <- peekElemOff ptr n + if isSpaceWord8 w then firstnonspace ptr (n+1) m else return n + +{- +-- | 'dropSpaceEnd' efficiently returns the 'ByteString' argument with +-- white space removed from the end. I.e. +-- +-- > reverse . (dropWhile isSpace) . reverse == dropSpaceEnd +-- +-- but it is more efficient than using multiple reverses. +-- +dropSpaceEnd :: ByteString -> ByteString +dropSpaceEnd (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do + i <- lastnonspace (p `plusPtr` s) (l-1) + return $! if i == (-1) then empty else PS x s (i+1) +{-# INLINE dropSpaceEnd #-} + +lastnonspace :: Ptr Word8 -> Int -> IO Int +STRICT2(lastnonspace) +lastnonspace ptr n + | n < 0 = return n + | otherwise = do w <- peekElemOff ptr n + if isSpaceWord8 w then lastnonspace ptr (n-1) else return n +-} + +-- | 'lines' breaks a ByteString up into a list of ByteStrings at +-- newline Chars. The resulting strings do not contain newlines. +-- +lines :: ByteString -> [ByteString] +lines ps + | null ps = [] + | otherwise = case search ps of + Nothing -> [ps] + Just n -> take n ps : lines (drop (n+1) ps) + where search = elemIndex '\n' +{-# INLINE lines #-} + +{- +-- Just as fast, but more complex. Should be much faster, I thought. +lines :: ByteString -> [ByteString] +lines (PS _ _ 0) = [] +lines (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> do + let ptr = p `plusPtr` s + + STRICT1(loop) + loop n = do + let q = memchr (ptr `plusPtr` n) 0x0a (fromIntegral (l-n)) + if q == nullPtr + then return [PS x (s+n) (l-n)] + else do let i = q `minusPtr` ptr + ls <- loop (i+1) + return $! PS x (s+n) (i-n) : ls + loop 0 +-} + +-- | 'unlines' is an inverse operation to 'lines'. It joins lines, +-- after appending a terminating newline to each. +unlines :: [ByteString] -> ByteString +unlines [] = empty +unlines ss = (concat $ List.intersperse nl ss) `append` nl -- half as much space + where nl = singleton '\n' + +-- | 'words' breaks a ByteString up into a list of words, which +-- were delimited by Chars representing white space. +words :: ByteString -> [ByteString] +words = P.filter (not . B.null) . B.splitWith isSpaceWord8 +{-# INLINE words #-} + +-- | The 'unwords' function is analogous to the 'unlines' function, on words. +unwords :: [ByteString] -> ByteString +unwords = intercalate (singleton ' ') +{-# INLINE unwords #-} + +-- --------------------------------------------------------------------- +-- Reading from ByteStrings + +-- | readInt reads an Int from the beginning of the ByteString. If there is no +-- integer at the beginning of the string, it returns Nothing, otherwise +-- it just returns the int read, and the rest of the string. +readInt :: ByteString -> Maybe (Int, ByteString) +readInt as + | null as = Nothing + | otherwise = + case unsafeHead as of + '-' -> loop True 0 0 (B.unsafeTail as) + '+' -> loop False 0 0 (B.unsafeTail as) + _ -> loop False 0 0 as + + where loop :: Bool -> Int -> Int -> ByteString -> Maybe (Int, ByteString) + STRICT4(loop) + loop neg i n ps + | null ps = end neg i n ps + | otherwise = + case B.unsafeHead ps of + w | w >= 0x30 + && w <= 0x39 -> loop neg (i+1) + (n * 10 + (fromIntegral w - 0x30)) + (B.unsafeTail ps) + | otherwise -> end neg i n ps + + end _ 0 _ _ = Nothing + end True _ n ps = Just (negate n, ps) + end _ _ n ps = Just (n, ps) + +-- | readInteger reads an Integer from the beginning of the ByteString. If +-- there is no integer at the beginning of the string, it returns Nothing, +-- otherwise it just returns the int read, and the rest of the string. +readInteger :: ByteString -> Maybe (Integer, ByteString) +readInteger as + | null as = Nothing + | otherwise = + case unsafeHead as of + '-' -> first (B.unsafeTail as) >>= \(n, bs) -> return (-n, bs) + '+' -> first (B.unsafeTail as) + _ -> first as + + where first ps | null ps = Nothing + | otherwise = + case B.unsafeHead ps of + w | w >= 0x30 && w <= 0x39 -> Just $ + loop 1 (fromIntegral w - 0x30) [] (B.unsafeTail ps) + | otherwise -> Nothing + + loop :: Int -> Int -> [Integer] + -> ByteString -> (Integer, ByteString) + STRICT4(loop) + loop d acc ns ps + | null ps = combine d acc ns empty + | otherwise = + case B.unsafeHead ps of + w | w >= 0x30 && w <= 0x39 -> + if d == 9 then loop 1 (fromIntegral w - 0x30) + (toInteger acc : ns) + (B.unsafeTail ps) + else loop (d+1) + (10*acc + (fromIntegral w - 0x30)) + ns (B.unsafeTail ps) + | otherwise -> combine d acc ns ps + + combine _ acc [] ps = (toInteger acc, ps) + combine d acc ns ps = + ((10^d * combine1 1000000000 ns + toInteger acc), ps) + + combine1 _ [n] = n + combine1 b ns = combine1 (b*b) $ combine2 b ns + + combine2 b (n:m:ns) = let t = m*b + n in t `seq` (t : combine2 b ns) + combine2 _ ns = ns + +-- | Read an entire file strictly into a 'ByteString'. This is far more +-- efficient than reading the characters into a 'String' and then using +-- 'pack'. It also may be more efficient than opening the file and +-- reading it using hGet. +readFile :: FilePath -> IO ByteString +readFile f = bracket (openFile f ReadMode) hClose + (\h -> hFileSize h >>= hGet h . fromIntegral) + +-- | Write a 'ByteString' to a file. +writeFile :: FilePath -> ByteString -> IO () +writeFile f txt = bracket (openFile f WriteMode) hClose + (\h -> hPut h txt) + +-- | Append a 'ByteString' to a file. +appendFile :: FilePath -> ByteString -> IO () +appendFile f txt = bracket (openFile f AppendMode) hClose + (\h -> hPut h txt) + diff --git a/Data/ByteString/Fusion.hs b/Data/ByteString/Fusion.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Fusion.hs @@ -0,0 +1,700 @@ +{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-} +-- | +-- Module : Data.ByteString.Fusion +-- License : BSD-style +-- Maintainer : dons@cse.unsw.edu.au +-- Stability : experimental +-- Portability : portable +-- +-- Functional array fusion for ByteStrings. +-- +-- Originally based on code from the Data Parallel Haskell project, +-- +-- + +-- #hide +module Data.ByteString.Fusion ( + + -- * Fusion utilities + loopU, loopL, fuseEFL, + NoAcc(NoAcc), loopArr, loopAcc, loopSndAcc, unSP, + mapEFL, filterEFL, foldEFL, foldEFL', scanEFL, mapAccumEFL, mapIndexEFL, + + -- ** Alternative Fusion stuff + -- | This replaces 'loopU' with 'loopUp' + -- and adds several further special cases of loops. + loopUp, loopDown, loopNoAcc, loopMap, loopFilter, + loopWrapper, sequenceLoops, + doUpLoop, doDownLoop, doNoAccLoop, doMapLoop, doFilterLoop, + + -- | These are the special fusion cases for combining each loop form perfectly. + fuseAccAccEFL, fuseAccNoAccEFL, fuseNoAccAccEFL, fuseNoAccNoAccEFL, + fuseMapAccEFL, fuseAccMapEFL, fuseMapNoAccEFL, fuseNoAccMapEFL, + fuseMapMapEFL, fuseAccFilterEFL, fuseFilterAccEFL, fuseNoAccFilterEFL, + fuseFilterNoAccEFL, fuseFilterFilterEFL, fuseMapFilterEFL, fuseFilterMapEFL, + + -- * Strict pairs and sums + PairS(..), MaybeS(..) + + ) where + +import Data.ByteString.Internal +import qualified Data.ByteString.Lazy.Internal as L + +import Foreign.ForeignPtr +import Foreign.Ptr +import Foreign.Storable (Storable(..)) + +import Data.Word (Word8) +import System.IO.Unsafe (unsafePerformIO) + +-- ----------------------------------------------------------------------------- +-- +-- Useful macros, until we have bang patterns +-- + +#define STRICT1(f) f a | a `seq` False = undefined +#define STRICT2(f) f a b | a `seq` b `seq` False = undefined +#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined +#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined +#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined + +infixl 2 :*: + +-- |Strict pair +data PairS a b = !a :*: !b deriving (Eq,Ord,Show) + +-- |Strict Maybe +data MaybeS a = NothingS | JustS !a deriving (Eq,Ord,Show) + +-- |Data type for accumulators which can be ignored. The rewrite rules rely on +-- the fact that no bottoms of this type are ever constructed; hence, we can +-- assume @(_ :: NoAcc) `seq` x = x@. +-- +data NoAcc = NoAcc + +-- |Type of loop functions +type AccEFL acc = acc -> Word8 -> (PairS acc (MaybeS Word8)) +type NoAccEFL = Word8 -> MaybeS Word8 +type MapEFL = Word8 -> Word8 +type FilterEFL = Word8 -> Bool + +infixr 9 `fuseEFL` + +-- |Fuse to flat loop functions +fuseEFL :: AccEFL acc1 -> AccEFL acc2 -> AccEFL (PairS acc1 acc2) +fuseEFL f g (acc1 :*: acc2) e1 = + case f acc1 e1 of + acc1' :*: NothingS -> (acc1' :*: acc2) :*: NothingS + acc1' :*: JustS e2 -> + case g acc2 e2 of + acc2' :*: res -> (acc1' :*: acc2') :*: res +#if defined(__GLASGOW_HASKELL__) +{-# INLINE [1] fuseEFL #-} +#endif + +-- | Special forms of loop arguments +-- +-- * These are common special cases for the three function arguments of gen +-- and loop; we give them special names to make it easier to trigger RULES +-- applying in the special cases represented by these arguments. The +-- "INLINE [1]" makes sure that these functions are only inlined in the last +-- two simplifier phases. +-- +-- * In the case where the accumulator is not needed, it is better to always +-- explicitly return a value `()', rather than just copy the input to the +-- output, as the former gives GHC better local information. +-- + +-- | Element function expressing a mapping only +#if !defined(LOOPNOACC_FUSION) +mapEFL :: (Word8 -> Word8) -> AccEFL NoAcc +mapEFL f = \_ e -> (NoAcc :*: (JustS $ f e)) +#else +mapEFL :: (Word8 -> Word8) -> NoAccEFL +mapEFL f = \e -> JustS (f e) +#endif +#if defined(__GLASGOW_HASKELL__) +{-# INLINE [1] mapEFL #-} +#endif + +-- | Element function implementing a filter function only +#if !defined(LOOPNOACC_FUSION) +filterEFL :: (Word8 -> Bool) -> AccEFL NoAcc +filterEFL p = \_ e -> if p e then (NoAcc :*: JustS e) else (NoAcc :*: NothingS) +#else +filterEFL :: (Word8 -> Bool) -> NoAccEFL +filterEFL p = \e -> if p e then JustS e else NothingS +#endif + +#if defined(__GLASGOW_HASKELL__) +{-# INLINE [1] filterEFL #-} +#endif + +-- |Element function expressing a reduction only +foldEFL :: (acc -> Word8 -> acc) -> AccEFL acc +foldEFL f = \a e -> (f a e :*: NothingS) +#if defined(__GLASGOW_HASKELL__) +{-# INLINE [1] foldEFL #-} +#endif + +-- | A strict foldEFL. +foldEFL' :: (acc -> Word8 -> acc) -> AccEFL acc +foldEFL' f = \a e -> let a' = f a e in a' `seq` (a' :*: NothingS) +#if defined(__GLASGOW_HASKELL__) +{-# INLINE [1] foldEFL' #-} +#endif + +-- | Element function expressing a prefix reduction only +-- +scanEFL :: (Word8 -> Word8 -> Word8) -> AccEFL Word8 +scanEFL f = \a e -> (f a e :*: JustS a) +#if defined(__GLASGOW_HASKELL__) +{-# INLINE [1] scanEFL #-} +#endif + +-- | Element function implementing a map and fold +-- +mapAccumEFL :: (acc -> Word8 -> (acc, Word8)) -> AccEFL acc +mapAccumEFL f = \a e -> case f a e of (a', e') -> (a' :*: JustS e') +#if defined(__GLASGOW_HASKELL__) +{-# INLINE [1] mapAccumEFL #-} +#endif + +-- | Element function implementing a map with index +-- +mapIndexEFL :: (Int -> Word8 -> Word8) -> AccEFL Int +mapIndexEFL f = \i e -> let i' = i+1 in i' `seq` (i' :*: JustS (f i e)) +#if defined(__GLASGOW_HASKELL__) +{-# INLINE [1] mapIndexEFL #-} +#endif + +-- | Projection functions that are fusion friendly (as in, we determine when +-- they are inlined) +loopArr :: (PairS acc arr) -> arr +loopArr (_ :*: arr) = arr +#if defined(__GLASGOW_HASKELL__) +{-# INLINE [1] loopArr #-} +#endif + +loopAcc :: (PairS acc arr) -> acc +loopAcc (acc :*: _) = acc +#if defined(__GLASGOW_HASKELL__) +{-# INLINE [1] loopAcc #-} +#endif + +loopSndAcc :: (PairS (PairS acc1 acc2) arr) -> (PairS acc2 arr) +loopSndAcc ((_ :*: acc) :*: arr) = (acc :*: arr) +#if defined(__GLASGOW_HASKELL__) +{-# INLINE [1] loopSndAcc #-} +#endif + +unSP :: (PairS acc arr) -> (acc, arr) +unSP (acc :*: arr) = (acc, arr) +#if defined(__GLASGOW_HASKELL__) +{-# INLINE [1] unSP #-} +#endif + +------------------------------------------------------------------------ +-- +-- Loop combinator and fusion rules for flat arrays +-- |Iteration over over ByteStrings + +-- | Iteration over over ByteStrings +loopU :: AccEFL acc -- ^ mapping & folding, once per elem + -> acc -- ^ initial acc value + -> ByteString -- ^ input ByteString + -> (PairS acc ByteString) + +loopU f start (PS z s i) = unsafePerformIO $ withForeignPtr z $ \a -> do + (ps, acc) <- createAndTrim' i $ \p -> do + (acc' :*: i') <- go (a `plusPtr` s) p start + return (0, i', acc') + return (acc :*: ps) + + where + go p ma = trans 0 0 + where + STRICT3(trans) + trans a_off ma_off acc + | a_off >= i = return (acc :*: ma_off) + | otherwise = do + x <- peekByteOff p a_off + let (acc' :*: oe) = f acc x + ma_off' <- case oe of + NothingS -> return ma_off + JustS e -> do pokeByteOff ma ma_off e + return $ ma_off + 1 + trans (a_off+1) ma_off' acc' + +#if defined(__GLASGOW_HASKELL__) +{-# INLINE [1] loopU #-} +#endif + +{-# RULES + +"FPS loop/loop fusion!" forall em1 em2 start1 start2 arr. + loopU em2 start2 (loopArr (loopU em1 start1 arr)) = + loopSndAcc (loopU (em1 `fuseEFL` em2) (start1 :*: start2) arr) + + #-} + +-- +-- Functional list/array fusion for lazy ByteStrings. +-- +loopL :: AccEFL acc -- ^ mapping & folding, once per elem + -> acc -- ^ initial acc value + -> L.ByteString -- ^ input ByteString + -> PairS acc L.ByteString +loopL f = loop + where loop s L.Empty = (s :*: L.Empty) + loop s (L.Chunk x xs) + | l == 0 = (s'' :*: ys) + | otherwise = (s'' :*: L.Chunk y ys) + where (s' :*: y@(PS _ _ l)) = loopU f s x -- avoid circular dep on S.null + (s'' :*: ys) = loop s' xs + +#if defined(__GLASGOW_HASKELL__) +{-# INLINE [1] loopL #-} +#endif + +{-# RULES + +"FPS lazy loop/loop fusion!" forall em1 em2 start1 start2 arr. + loopL em2 start2 (loopArr (loopL em1 start1 arr)) = + loopSndAcc (loopL (em1 `fuseEFL` em2) (start1 :*: start2) arr) + + #-} + + +{- + +Alternate experimental formulation of loopU which partitions it into +an allocating wrapper and an imperitive array-mutating loop. + +The point in doing this split is that we might be able to fuse multiple +loops into a single wrapper. This would save reallocating another buffer. +It should also give better cache locality by reusing the buffer. + +Note that this stuff needs ghc-6.5 from May 26 or later for the RULES to +really work reliably. + +-} + +loopUp :: AccEFL acc -> acc -> ByteString -> PairS acc ByteString +loopUp f a arr = loopWrapper (doUpLoop f a) arr +{-# INLINE loopUp #-} + +loopDown :: AccEFL acc -> acc -> ByteString -> PairS acc ByteString +loopDown f a arr = loopWrapper (doDownLoop f a) arr +{-# INLINE loopDown #-} + +loopNoAcc :: NoAccEFL -> ByteString -> PairS NoAcc ByteString +loopNoAcc f arr = loopWrapper (doNoAccLoop f NoAcc) arr +{-# INLINE loopNoAcc #-} + +loopMap :: MapEFL -> ByteString -> PairS NoAcc ByteString +loopMap f arr = loopWrapper (doMapLoop f NoAcc) arr +{-# INLINE loopMap #-} + +loopFilter :: FilterEFL -> ByteString -> PairS NoAcc ByteString +loopFilter f arr = loopWrapper (doFilterLoop f NoAcc) arr +{-# INLINE loopFilter #-} + +-- The type of imperitive loops that fill in a destination array by +-- reading a source array. They may not fill in the whole of the dest +-- array if the loop is behaving as a filter, this is why we return +-- the length that was filled in. The loop may also accumulate some +-- value as it loops over the source array. +-- +type ImperativeLoop acc = + Ptr Word8 -- pointer to the start of the source byte array + -> Ptr Word8 -- pointer to ther start of the destination byte array + -> Int -- length of the source byte array + -> IO (PairS (PairS acc Int) Int) -- result and offset, length of dest that was filled + +loopWrapper :: ImperativeLoop acc -> ByteString -> PairS acc ByteString +loopWrapper body (PS srcFPtr srcOffset srcLen) = unsafePerformIO $ + withForeignPtr srcFPtr $ \srcPtr -> do + (ps, acc) <- createAndTrim' srcLen $ \destPtr -> do + (acc :*: destOffset :*: destLen) <- + body (srcPtr `plusPtr` srcOffset) destPtr srcLen + return (destOffset, destLen, acc) + return (acc :*: ps) + +doUpLoop :: AccEFL acc -> acc -> ImperativeLoop acc +doUpLoop f acc0 src dest len = loop 0 0 acc0 + where STRICT3(loop) + loop src_off dest_off acc + | src_off >= len = return (acc :*: 0 :*: dest_off) + | otherwise = do + x <- peekByteOff src src_off + case f acc x of + (acc' :*: NothingS) -> loop (src_off+1) dest_off acc' + (acc' :*: JustS x') -> pokeByteOff dest dest_off x' + >> loop (src_off+1) (dest_off+1) acc' + +doDownLoop :: AccEFL acc -> acc -> ImperativeLoop acc +doDownLoop f acc0 src dest len = loop (len-1) (len-1) acc0 + where STRICT3(loop) + loop src_off dest_off acc + | src_off < 0 = return (acc :*: dest_off + 1 :*: len - (dest_off + 1)) + | otherwise = do + x <- peekByteOff src src_off + case f acc x of + (acc' :*: NothingS) -> loop (src_off-1) dest_off acc' + (acc' :*: JustS x') -> pokeByteOff dest dest_off x' + >> loop (src_off-1) (dest_off-1) acc' + +doNoAccLoop :: NoAccEFL -> noAcc -> ImperativeLoop noAcc +doNoAccLoop f noAcc src dest len = loop 0 0 + where STRICT2(loop) + loop src_off dest_off + | src_off >= len = return (noAcc :*: 0 :*: dest_off) + | otherwise = do + x <- peekByteOff src src_off + case f x of + NothingS -> loop (src_off+1) dest_off + JustS x' -> pokeByteOff dest dest_off x' + >> loop (src_off+1) (dest_off+1) + +doMapLoop :: MapEFL -> noAcc -> ImperativeLoop noAcc +doMapLoop f noAcc src dest len = loop 0 + where STRICT1(loop) + loop n + | n >= len = return (noAcc :*: 0 :*: len) + | otherwise = do + x <- peekByteOff src n + pokeByteOff dest n (f x) + loop (n+1) -- offset always the same, only pass 1 arg + +doFilterLoop :: FilterEFL -> noAcc -> ImperativeLoop noAcc +doFilterLoop f noAcc src dest len = loop 0 0 + where STRICT2(loop) + loop src_off dest_off + | src_off >= len = return (noAcc :*: 0 :*: dest_off) + | otherwise = do + x <- peekByteOff src src_off + if f x + then pokeByteOff dest dest_off x + >> loop (src_off+1) (dest_off+1) + else loop (src_off+1) dest_off + +-- run two loops in sequence, +-- think of it as: loop1 >> loop2 +sequenceLoops :: ImperativeLoop acc1 + -> ImperativeLoop acc2 + -> ImperativeLoop (PairS acc1 acc2) +sequenceLoops loop1 loop2 src dest len0 = do + (acc1 :*: off1 :*: len1) <- loop1 src dest len0 + (acc2 :*: off2 :*: len2) <- + let src' = dest `plusPtr` off1 + dest' = src' -- note that we are using dest == src + -- for the second loop as we are + -- mutating the dest array in-place! + in loop2 src' dest' len1 + return ((acc1 :*: acc2) :*: off1 + off2 :*: len2) + + -- TODO: prove that this is associative! (I think it is) + -- since we can't be sure how the RULES will combine loops. + +#if defined(__GLASGOW_HASKELL__) + +{-# INLINE [1] doUpLoop #-} +{-# INLINE [1] doDownLoop #-} +{-# INLINE [1] doNoAccLoop #-} +{-# INLINE [1] doMapLoop #-} +{-# INLINE [1] doFilterLoop #-} + +{-# INLINE [1] loopWrapper #-} +{-# INLINE [1] sequenceLoops #-} + +{-# INLINE [1] fuseAccAccEFL #-} +{-# INLINE [1] fuseAccNoAccEFL #-} +{-# INLINE [1] fuseNoAccAccEFL #-} +{-# INLINE [1] fuseNoAccNoAccEFL #-} +{-# INLINE [1] fuseMapAccEFL #-} +{-# INLINE [1] fuseAccMapEFL #-} +{-# INLINE [1] fuseMapNoAccEFL #-} +{-# INLINE [1] fuseNoAccMapEFL #-} +{-# INLINE [1] fuseMapMapEFL #-} +{-# INLINE [1] fuseAccFilterEFL #-} +{-# INLINE [1] fuseFilterAccEFL #-} +{-# INLINE [1] fuseNoAccFilterEFL #-} +{-# INLINE [1] fuseFilterNoAccEFL #-} +{-# INLINE [1] fuseFilterFilterEFL #-} +{-# INLINE [1] fuseMapFilterEFL #-} +{-# INLINE [1] fuseFilterMapEFL #-} + +#endif + +{-# RULES + +"FPS loopArr/loopSndAcc" forall x. + loopArr (loopSndAcc x) = loopArr x + +"FPS seq/NoAcc" forall (u::NoAcc) e. + u `seq` e = e + +"FPS loop/loop wrapper elimination" forall loop1 loop2 arr. + loopWrapper loop2 (loopArr (loopWrapper loop1 arr)) = + loopSndAcc (loopWrapper (sequenceLoops loop1 loop2) arr) + +-- +-- n.b in the following, when reading n/m fusion, recall sequenceLoops +-- is monadic, so its really n >> m fusion (i.e. m.n), not n . m fusion. +-- + +"FPS up/up loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doUpLoop f1 acc1) (doUpLoop f2 acc2) = + doUpLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2) + +"FPS map/map loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doMapLoop f1 acc1) (doMapLoop f2 acc2) = + doMapLoop (f1 `fuseMapMapEFL` f2) (acc1 :*: acc2) + +"FPS filter/filter loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doFilterLoop f1 acc1) (doFilterLoop f2 acc2) = + doFilterLoop (f1 `fuseFilterFilterEFL` f2) (acc1 :*: acc2) + +"FPS map/filter loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doMapLoop f1 acc1) (doFilterLoop f2 acc2) = + doNoAccLoop (f1 `fuseMapFilterEFL` f2) (acc1 :*: acc2) + +"FPS filter/map loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doFilterLoop f1 acc1) (doMapLoop f2 acc2) = + doNoAccLoop (f1 `fuseFilterMapEFL` f2) (acc1 :*: acc2) + +"FPS map/up loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doMapLoop f1 acc1) (doUpLoop f2 acc2) = + doUpLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2) + +"FPS up/map loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doUpLoop f1 acc1) (doMapLoop f2 acc2) = + doUpLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2) + +"FPS filter/up loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doFilterLoop f1 acc1) (doUpLoop f2 acc2) = + doUpLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2) + +"FPS up/filter loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doUpLoop f1 acc1) (doFilterLoop f2 acc2) = + doUpLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2) + +"FPS down/down loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doDownLoop f1 acc1) (doDownLoop f2 acc2) = + doDownLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2) + +"FPS map/down fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doMapLoop f1 acc1) (doDownLoop f2 acc2) = + doDownLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2) + +"FPS down/map loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doDownLoop f1 acc1) (doMapLoop f2 acc2) = + doDownLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2) + +"FPS filter/down fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doFilterLoop f1 acc1) (doDownLoop f2 acc2) = + doDownLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2) + +"FPS down/filter loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doDownLoop f1 acc1) (doFilterLoop f2 acc2) = + doDownLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2) + +"FPS noAcc/noAcc loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doNoAccLoop f1 acc1) (doNoAccLoop f2 acc2) = + doNoAccLoop (f1 `fuseNoAccNoAccEFL` f2) (acc1 :*: acc2) + +"FPS noAcc/up loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doNoAccLoop f1 acc1) (doUpLoop f2 acc2) = + doUpLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2) + +"FPS up/noAcc loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doUpLoop f1 acc1) (doNoAccLoop f2 acc2) = + doUpLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2) + +"FPS map/noAcc loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doMapLoop f1 acc1) (doNoAccLoop f2 acc2) = + doNoAccLoop (f1 `fuseMapNoAccEFL` f2) (acc1 :*: acc2) + +"FPS noAcc/map loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doNoAccLoop f1 acc1) (doMapLoop f2 acc2) = + doNoAccLoop (f1 `fuseNoAccMapEFL` f2) (acc1 :*: acc2) + +"FPS filter/noAcc loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doFilterLoop f1 acc1) (doNoAccLoop f2 acc2) = + doNoAccLoop (f1 `fuseFilterNoAccEFL` f2) (acc1 :*: acc2) + +"FPS noAcc/filter loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doNoAccLoop f1 acc1) (doFilterLoop f2 acc2) = + doNoAccLoop (f1 `fuseNoAccFilterEFL` f2) (acc1 :*: acc2) + +"FPS noAcc/down loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doNoAccLoop f1 acc1) (doDownLoop f2 acc2) = + doDownLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2) + +"FPS down/noAcc loop fusion" forall f1 f2 acc1 acc2. + sequenceLoops (doDownLoop f1 acc1) (doNoAccLoop f2 acc2) = + doDownLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2) + + #-} + +{- + +up = up loop +down = down loop +map = map special case +filter = filter special case +noAcc = noAcc undirectional loop (unused) + +heirarchy: + up down + ^ ^ + \ / + noAcc + ^ ^ + / \ + map filter + +each is a special case of the things above + +so we get rules that combine things on the same level +and rules that combine things on different levels +to get something on the higher level + +so all the cases: +up/up --> up fuseAccAccEFL +down/down --> down fuseAccAccEFL +noAcc/noAcc --> noAcc fuseNoAccNoAccEFL + +noAcc/up --> up fuseNoAccAccEFL +up/noAcc --> up fuseAccNoAccEFL +noAcc/down --> down fuseNoAccAccEFL +down/noAcc --> down fuseAccNoAccEFL + +and if we do the map, filter special cases then it adds a load more: + +map/map --> map fuseMapMapEFL +filter/filter --> filter fuseFilterFilterEFL + +map/filter --> noAcc fuseMapFilterEFL +filter/map --> noAcc fuseFilterMapEFL + +map/noAcc --> noAcc fuseMapNoAccEFL +noAcc/map --> noAcc fuseNoAccMapEFL + +map/up --> up fuseMapAccEFL +up/map --> up fuseAccMapEFL + +map/down --> down fuseMapAccEFL +down/map --> down fuseAccMapEFL + +filter/noAcc --> noAcc fuseNoAccFilterEFL +noAcc/filter --> noAcc fuseFilterNoAccEFL + +filter/up --> up fuseFilterAccEFL +up/filter --> up fuseAccFilterEFL + +filter/down --> down fuseFilterAccEFL +down/filter --> down fuseAccFilterEFL +-} + +fuseAccAccEFL :: AccEFL acc1 -> AccEFL acc2 -> AccEFL (PairS acc1 acc2) +fuseAccAccEFL f g (acc1 :*: acc2) e1 = + case f acc1 e1 of + acc1' :*: NothingS -> (acc1' :*: acc2) :*: NothingS + acc1' :*: JustS e2 -> + case g acc2 e2 of + acc2' :*: res -> (acc1' :*: acc2') :*: res + +fuseAccNoAccEFL :: AccEFL acc -> NoAccEFL -> AccEFL (PairS acc noAcc) +fuseAccNoAccEFL f g (acc :*: noAcc) e1 = + case f acc e1 of + acc' :*: NothingS -> (acc' :*: noAcc) :*: NothingS + acc' :*: JustS e2 -> (acc' :*: noAcc) :*: g e2 + +fuseNoAccAccEFL :: NoAccEFL -> AccEFL acc -> AccEFL (PairS noAcc acc) +fuseNoAccAccEFL f g (noAcc :*: acc) e1 = + case f e1 of + NothingS -> (noAcc :*: acc) :*: NothingS + JustS e2 -> + case g acc e2 of + acc' :*: res -> (noAcc :*: acc') :*: res + +fuseNoAccNoAccEFL :: NoAccEFL -> NoAccEFL -> NoAccEFL +fuseNoAccNoAccEFL f g e1 = + case f e1 of + NothingS -> NothingS + JustS e2 -> g e2 + +fuseMapAccEFL :: MapEFL -> AccEFL acc -> AccEFL (PairS noAcc acc) +fuseMapAccEFL f g (noAcc :*: acc) e1 = + case g acc (f e1) of + (acc' :*: res) -> (noAcc :*: acc') :*: res + +fuseAccMapEFL :: AccEFL acc -> MapEFL -> AccEFL (PairS acc noAcc) +fuseAccMapEFL f g (acc :*: noAcc) e1 = + case f acc e1 of + (acc' :*: NothingS) -> (acc' :*: noAcc) :*: NothingS + (acc' :*: JustS e2) -> (acc' :*: noAcc) :*: JustS (g e2) + +fuseMapMapEFL :: MapEFL -> MapEFL -> MapEFL +fuseMapMapEFL f g e1 = g (f e1) -- n.b. perfect fusion + +fuseMapNoAccEFL :: MapEFL -> NoAccEFL -> NoAccEFL +fuseMapNoAccEFL f g e1 = g (f e1) + +fuseNoAccMapEFL :: NoAccEFL -> MapEFL -> NoAccEFL +fuseNoAccMapEFL f g e1 = + case f e1 of + NothingS -> NothingS + JustS e2 -> JustS (g e2) + +fuseAccFilterEFL :: AccEFL acc -> FilterEFL -> AccEFL (PairS acc noAcc) +fuseAccFilterEFL f g (acc :*: noAcc) e1 = + case f acc e1 of + acc' :*: NothingS -> (acc' :*: noAcc) :*: NothingS + acc' :*: JustS e2 -> + case g e2 of + False -> (acc' :*: noAcc) :*: NothingS + True -> (acc' :*: noAcc) :*: JustS e2 + +fuseFilterAccEFL :: FilterEFL -> AccEFL acc -> AccEFL (PairS noAcc acc) +fuseFilterAccEFL f g (noAcc :*: acc) e1 = + case f e1 of + False -> (noAcc :*: acc) :*: NothingS + True -> + case g acc e1 of + acc' :*: res -> (noAcc :*: acc') :*: res + +fuseNoAccFilterEFL :: NoAccEFL -> FilterEFL -> NoAccEFL +fuseNoAccFilterEFL f g e1 = + case f e1 of + NothingS -> NothingS + JustS e2 -> + case g e2 of + False -> NothingS + True -> JustS e2 + +fuseFilterNoAccEFL :: FilterEFL -> NoAccEFL -> NoAccEFL +fuseFilterNoAccEFL f g e1 = + case f e1 of + False -> NothingS + True -> g e1 + +fuseFilterFilterEFL :: FilterEFL -> FilterEFL -> FilterEFL +fuseFilterFilterEFL f g e1 = f e1 && g e1 + +fuseMapFilterEFL :: MapEFL -> FilterEFL -> NoAccEFL +fuseMapFilterEFL f g e1 = + case f e1 of + e2 -> case g e2 of + False -> NothingS + True -> JustS e2 + +fuseFilterMapEFL :: FilterEFL -> MapEFL -> NoAccEFL +fuseFilterMapEFL f g e1 = + case f e1 of + False -> NothingS + True -> JustS (g e1) + diff --git a/Data/ByteString/Internal.hs b/Data/ByteString/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Internal.hs @@ -0,0 +1,374 @@ +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +-- | +-- Module : Data.ByteString.Internal +-- License : BSD-style +-- Maintainer : dons@cse.unsw.edu.au +-- Stability : experimental +-- Portability : portable +-- +-- A module containing semi-public 'ByteString' internals. This exposes +-- the 'ByteString' representation and low level construction functions. +-- Modules which extend the 'ByteString' system will need to use this module +-- while ideally most users will be able to make do with the public interface +-- modules. +-- +module Data.ByteString.Internal ( + + -- * The @ByteString@ type and representation + ByteString(..), -- instances: Eq, Ord, Show, Read, Data, Typeable + + -- * Low level introduction and elimination + create, -- :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString + createAndTrim, -- :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString + createAndTrim', -- :: Int -> (Ptr Word8 -> IO (Int, Int, a)) -> IO (ByteString, a) + unsafeCreate, -- :: Int -> (Ptr Word8 -> IO ()) -> ByteString + mallocByteString, -- :: Int -> IO (ForeignPtr a) + + -- * Conversion to and from ForeignPtrs + fromForeignPtr, -- :: ForeignPtr Word8 -> Int -> Int -> ByteString + toForeignPtr, -- :: ByteString -> (ForeignPtr Word8, Int, Int) + + -- * Utilities + inlinePerformIO, -- :: IO a -> a + nullForeignPtr, -- :: ForeignPtr Word8 + + countOccurrences, -- :: (Storable a, Num a) => Ptr a -> Ptr Word8 -> Int -> IO () + + -- * Standard C Functions + c_strlen, -- :: CString -> IO CInt + c_free_finalizer, -- :: FunPtr (Ptr Word8 -> IO ()) + + memchr, -- :: Ptr Word8 -> Word8 -> CSize -> IO Ptr Word8 + memcmp, -- :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt + memcpy, -- :: Ptr Word8 -> Ptr Word8 -> CSize -> IO () + memmove, -- :: Ptr Word8 -> Ptr Word8 -> CSize -> IO () + memset, -- :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8) + + -- * cbits functions + c_reverse, -- :: Ptr Word8 -> Ptr Word8 -> CInt -> IO () + c_intersperse, -- :: Ptr Word8 -> Ptr Word8 -> CInt -> Word8 -> IO () + c_maximum, -- :: Ptr Word8 -> CInt -> IO Word8 + c_minimum, -- :: Ptr Word8 -> CInt -> IO Word8 + c_count, -- :: Ptr Word8 -> CInt -> Word8 -> IO CInt + +#if defined(__GLASGOW_HASKELL__) + -- * Internal GHC magic + memcpy_ptr_baoff, -- :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ()) +#endif + + -- * Chars + w2c, c2w, isSpaceWord8 + + ) where + +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr, FunPtr, plusPtr) +import Foreign.Storable (Storable(..)) +import Foreign.C.Types (CInt, CSize, CULong) +import Foreign.C.String (CString) + +#ifndef __NHC__ +import Control.Exception (assert) +#endif + +import Data.Char (ord) +import Data.Word (Word8) + +#if defined(__GLASGOW_HASKELL__) +import Data.Generics (Data(..), Typeable(..)) +import GHC.Ptr (Ptr(..)) +import GHC.Base (realWorld#,unsafeChr) +import GHC.IOBase (IO(IO), unsafePerformIO, RawBuffer) +#else +import Data.Char (chr) +import System.IO.Unsafe (unsafePerformIO) +#endif + +#if __GLASGOW_HASKELL__ >= 605 && !defined(SLOW_FOREIGN_PTR) +import GHC.ForeignPtr (mallocPlainForeignPtrBytes) +#else +import Foreign.ForeignPtr (mallocForeignPtrBytes) +#endif + +#if __GLASGOW_HASKELL__>=605 +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 stuff is Hugs only +{-# CFILES cbits/fpstring.c #-} + +-- An alternative to Control.Exception (assert) for nhc98 +#ifdef __NHC__ +#define assert assertS "__FILE__ : __LINE__" +assertS :: String -> Bool -> a -> a +assertS _ True = id +assertS s False = error ("assertion failed at "++s) +#endif + +-- ----------------------------------------------------------------------------- +-- +-- Useful macros, until we have bang patterns +-- + +#define STRICT1(f) f a | a `seq` False = undefined +#define STRICT2(f) f a b | a `seq` b `seq` False = undefined +#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined +#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined +#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined + +-- ----------------------------------------------------------------------------- + +-- | A space-efficient representation of a Word8 vector, supporting many +-- efficient operations. A 'ByteString' contains 8-bit characters only. +-- +-- Instances of Eq, Ord, Read, Show, Data, Typeable +-- +data ByteString = PS {-# UNPACK #-} !(ForeignPtr Word8) + {-# UNPACK #-} !Int -- offset + {-# UNPACK #-} !Int -- length + +#if defined(__GLASGOW_HASKELL__) + deriving (Data, Typeable) +#endif + +instance Show ByteString where + showsPrec p ps r = showsPrec p (unpackWith w2c ps) r + +instance Read ByteString where + readsPrec p str = [ (packWith c2w x, y) | (x, y) <- readsPrec p str ] + +-- | /O(n)/ Converts a 'ByteString' to a '[a]', using a conversion function. +unpackWith :: (Word8 -> a) -> ByteString -> [a] +unpackWith _ (PS _ _ 0) = [] +unpackWith k (PS ps s l) = inlinePerformIO $ withForeignPtr ps $ \p -> + go (p `plusPtr` s) (l - 1) [] + where + STRICT3(go) + go p 0 acc = peek p >>= \e -> return (k e : acc) + go p n acc = peekByteOff p n >>= \e -> go p (n-1) (k e : acc) +{-# INLINE unpackWith #-} +{-# SPECIALIZE unpackWith :: (Word8 -> Char) -> ByteString -> [Char] #-} + +-- | /O(n)/ Convert a '[a]' into a 'ByteString' using some +-- conversion function +packWith :: (a -> Word8) -> [a] -> ByteString +packWith k str = unsafeCreate (length str) $ \p -> go p str + where + STRICT2(go) + go _ [] = return () + go p (x:xs) = poke p (k x) >> go (p `plusPtr` 1) xs -- less space than pokeElemOff +{-# INLINE packWith #-} +{-# SPECIALIZE packWith :: (Char -> Word8) -> [Char] -> ByteString #-} + +------------------------------------------------------------------------ + +nullForeignPtr :: ForeignPtr Word8 +#if __GLASGOW_HASKELL__>=605 +nullForeignPtr = ForeignPtr nullAddr# undefined --TODO: should ForeignPtrContents be strict? +#else +nullForeignPtr = unsafePerformIO $ newForeignPtr_ nullPtr +{-# NOINLINE nullForeignPtr #-} +#endif + +-- --------------------------------------------------------------------- +-- Low level constructors + +-- | /O(1)/ Build a ByteString from a ForeignPtr +fromForeignPtr :: ForeignPtr Word8 -> Int -> Int -> ByteString +fromForeignPtr fp s l = PS fp s l + +-- | /O(1)/ Deconstruct a ForeignPtr from a ByteString +toForeignPtr :: ByteString -> (ForeignPtr Word8, Int, Int) +toForeignPtr (PS ps s l) = (ps, s, l) + +-- | A way of creating ByteStrings outside the IO monad. The @Int@ +-- argument gives the final size of the ByteString. Unlike +-- 'createAndTrim' the ByteString is not reallocated if the final size +-- is less than the estimated size. +unsafeCreate :: Int -> (Ptr Word8 -> IO ()) -> ByteString +unsafeCreate l f = unsafePerformIO (create l f) +{-# INLINE unsafeCreate #-} + +-- | Create ByteString of size @l@ and use action @f@ to fill it's contents. +create :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString +create l f = do + fp <- mallocByteString l + withForeignPtr fp $ \p -> f p + return $! PS fp 0 l + +-- | Given the maximum size needed and a function to make the contents +-- of a ByteString, createAndTrim makes the 'ByteString'. The generating +-- function is required to return the actual final size (<= the maximum +-- size), and the resulting byte array is realloced to this size. +-- +-- createAndTrim is the main mechanism for creating custom, efficient +-- ByteString functions, using Haskell or C functions to fill the space. +-- +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 (fromIntegral 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) (fromIntegral l') + return $! (ps, res) + +-- | Wrapper of mallocForeignPtrBytes with faster implementation +-- for GHC 6.5 builds newer than 06/06/06 +mallocByteString :: Int -> IO (ForeignPtr a) +mallocByteString l = do +#if __GLASGOW_HASKELL__ >= 605 && !defined(SLOW_FOREIGN_PTR) + mallocPlainForeignPtrBytes l +#else + mallocForeignPtrBytes l +#endif + +------------------------------------------------------------------------ + +-- | Conversion between 'Word8' and 'Char'. Should compile to a no-op. +w2c :: Word8 -> Char +#if !defined(__GLASGOW_HASKELL__) +w2c = chr . fromIntegral +#else +w2c = unsafeChr . fromIntegral +#endif +{-# INLINE w2c #-} + +-- | Unsafe conversion between 'Char' and 'Word8'. This is a no-op and +-- silently truncates to 8 bits Chars > '\255'. It is provided as +-- convenience for ByteString construction. +c2w :: Char -> Word8 +c2w = fromIntegral . ord +{-# INLINE c2w #-} + +-- Selects white-space characters in the Latin-1 range +-- ordered by frequency +-- Idea from Ketil +isSpaceWord8 :: Word8 -> Bool +isSpaceWord8 w = case w of + 0x20 -> True -- SPACE + 0x0A -> True -- LF, \n + 0x09 -> True -- HT, \t + 0x0C -> True -- FF, \f + 0x0D -> True -- CR, \r + 0x0B -> True -- VT, \v + 0xA0 -> True -- spotted by QC.. + _ -> False +{-# INLINE isSpaceWord8 #-} + +------------------------------------------------------------------------ + +-- | Just like unsafePerformIO, but we inline it. Big performance gains as +-- it exposes lots of things to further inlining. /Very unsafe/. In +-- particular, you should do no memory allocation inside an +-- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@. +-- +{-# INLINE inlinePerformIO #-} +inlinePerformIO :: IO a -> a +#if defined(__GLASGOW_HASKELL__) +inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r +#else +inlinePerformIO = unsafePerformIO +#endif + +-- | Count the number of occurrences of each byte. +-- +countOccurrences :: (Storable a, Num a) => Ptr a -> Ptr Word8 -> Int -> IO () +STRICT3(countOccurrences) +countOccurrences counts str l = go 0 + where + STRICT1(go) + go i | i == l = return () + | otherwise = do k <- fromIntegral `fmap` peekElemOff str i + x <- peekElemOff counts k + pokeElemOff counts k (x + 1) + go (i + 1) +{-# SPECIALIZE countOccurrences :: Ptr CSize -> Ptr Word8 -> Int -> IO () #-} + +-- --------------------------------------------------------------------- +-- +-- Standard C functions +-- + +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" memcmp + :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt + +foreign import ccall unsafe "string.h memcpy" c_memcpy + :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8) + +memcpy :: Ptr Word8 -> Ptr Word8 -> CSize -> IO () +memcpy p q s = do c_memcpy p q s + return () + +foreign import ccall unsafe "string.h memmove" c_memmove + :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8) + +memmove :: Ptr Word8 -> Ptr Word8 -> CSize -> IO () +memmove p q s = do c_memmove p q 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 + +-- --------------------------------------------------------------------- +-- +-- Uses our C code +-- + +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 + +-- --------------------------------------------------------------------- +-- Internal GHC Haskell magic + +#if defined(__GLASGOW_HASKELL__) +foreign import ccall unsafe "__hscore_memcpy_src_off" + memcpy_ptr_baoff :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ()) +#endif diff --git a/Data/ByteString/Lazy.hs b/Data/ByteString/Lazy.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy.hs @@ -0,0 +1,1285 @@ +{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fno-warn-incomplete-patterns #-} + +-- #prune + +-- | +-- Module : Data.ByteString.Lazy +-- Copyright : (c) Don Stewart 2006 +-- (c) Duncan Coutts 2006 +-- License : BSD-style +-- +-- Maintainer : dons@cse.unsw.edu.au +-- Stability : experimental +-- Portability : portable +-- +-- A time and space-efficient implementation of lazy byte vectors +-- using lists of packed 'Word8' arrays, suitable for high performance +-- use, both in terms of large data quantities, or high speed +-- requirements. Byte vectors are encoded as lazy lists of strict 'Word8' +-- arrays of bytes. They provide a means to manipulate large byte vectors +-- without requiring the entire vector be resident in memory. +-- +-- Some operations, such as concat, append, reverse and cons, have +-- better complexity than their "Data.ByteString" equivalents, due to +-- optimisations resulting from the list spine structure. And for other +-- operations lazy ByteStrings are usually within a few percent of +-- strict ones, but with better heap usage. For data larger than the +-- available memory, or if you have tight memory constraints, this +-- module will be the only option. The default chunk size is 64k, which +-- should be good in most circumstances. For people with large L2 +-- caches, you may want to increase this to fit your cache. +-- +-- This module is intended to be imported @qualified@, to avoid name +-- clashes with "Prelude" functions. eg. +-- +-- > import qualified Data.ByteString.Lazy as B +-- +-- Original GHC implementation by Bryan O\'Sullivan. +-- Rewritten to use 'Data.Array.Unboxed.UArray' by Simon Marlow. +-- Rewritten to support slices and use 'Foreign.ForeignPtr.ForeignPtr' +-- by David Roundy. +-- Polished and extended by Don Stewart. +-- Lazy variant by Duncan Coutts and Don Stewart. +-- + +module Data.ByteString.Lazy ( + + -- * The @ByteString@ type + ByteString, -- instances: Eq, Ord, Show, Read, Data, Typeable + + -- * Introducing and eliminating 'ByteString's + empty, -- :: ByteString + singleton, -- :: Word8 -> ByteString + pack, -- :: [Word8] -> ByteString + unpack, -- :: ByteString -> [Word8] + fromChunks, -- :: [Strict.ByteString] -> ByteString + toChunks, -- :: ByteString -> [Strict.ByteString] + + -- * Basic interface + cons, -- :: Word8 -> ByteString -> ByteString + cons', -- :: Word8 -> ByteString -> ByteString + snoc, -- :: ByteString -> Word8 -> ByteString + append, -- :: ByteString -> ByteString -> ByteString + head, -- :: ByteString -> Word8 + uncons, -- :: ByteString -> Maybe (Word8, ByteString) + last, -- :: ByteString -> Word8 + tail, -- :: ByteString -> ByteString + init, -- :: ByteString -> ByteString + null, -- :: ByteString -> Bool + length, -- :: ByteString -> Int64 + + -- * Transforming ByteStrings + map, -- :: (Word8 -> Word8) -> ByteString -> ByteString + reverse, -- :: ByteString -> ByteString + intersperse, -- :: Word8 -> ByteString -> ByteString + intercalate, -- :: ByteString -> [ByteString] -> ByteString + transpose, -- :: [ByteString] -> [ByteString] + + -- * Reducing 'ByteString's (folds) + foldl, -- :: (a -> Word8 -> a) -> a -> ByteString -> a + foldl', -- :: (a -> Word8 -> a) -> a -> ByteString -> a + foldl1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 + foldl1', -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 + foldr, -- :: (Word8 -> a -> a) -> a -> ByteString -> a + foldr1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 + + -- ** Special folds + concat, -- :: [ByteString] -> ByteString + concatMap, -- :: (Word8 -> ByteString) -> ByteString -> ByteString + any, -- :: (Word8 -> Bool) -> ByteString -> Bool + all, -- :: (Word8 -> Bool) -> ByteString -> Bool + maximum, -- :: ByteString -> Word8 + minimum, -- :: ByteString -> Word8 + + -- * Building ByteStrings + -- ** Scans + scanl, -- :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString +-- scanl1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString +-- scanr, -- :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString +-- scanr1, -- :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString + + -- ** Accumulating maps + mapAccumL, -- :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) + mapAccumR, -- :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) + mapIndexed, -- :: (Int64 -> Word8 -> Word8) -> ByteString -> ByteString + + -- ** Infinite ByteStrings + repeat, -- :: Word8 -> ByteString + replicate, -- :: Int64 -> Word8 -> ByteString + cycle, -- :: ByteString -> ByteString + iterate, -- :: (Word8 -> Word8) -> Word8 -> ByteString + + -- ** Unfolding ByteStrings + unfoldr, -- :: (a -> Maybe (Word8, a)) -> a -> ByteString + + -- * Substrings + + -- ** Breaking strings + take, -- :: Int64 -> ByteString -> ByteString + drop, -- :: Int64 -> ByteString -> ByteString + splitAt, -- :: Int64 -> ByteString -> (ByteString, ByteString) + takeWhile, -- :: (Word8 -> Bool) -> ByteString -> ByteString + dropWhile, -- :: (Word8 -> Bool) -> ByteString -> ByteString + span, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) + break, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) + group, -- :: ByteString -> [ByteString] + groupBy, -- :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString] + inits, -- :: ByteString -> [ByteString] + tails, -- :: ByteString -> [ByteString] + + -- ** Breaking into many substrings + split, -- :: Word8 -> ByteString -> [ByteString] + splitWith, -- :: (Word8 -> Bool) -> ByteString -> [ByteString] + + -- * Predicates + isPrefixOf, -- :: ByteString -> ByteString -> Bool + isSuffixOf, -- :: ByteString -> ByteString -> Bool +-- isInfixOf, -- :: ByteString -> ByteString -> Bool + + -- ** Search for arbitrary substrings +-- isSubstringOf, -- :: ByteString -> ByteString -> Bool +-- findSubstring, -- :: ByteString -> ByteString -> Maybe Int +-- findSubstrings, -- :: ByteString -> ByteString -> [Int] + + -- * Searching ByteStrings + + -- ** Searching by equality + elem, -- :: Word8 -> ByteString -> Bool + notElem, -- :: Word8 -> ByteString -> Bool + + -- ** Searching with a predicate + find, -- :: (Word8 -> Bool) -> ByteString -> Maybe Word8 + filter, -- :: (Word8 -> Bool) -> ByteString -> ByteString + partition, -- :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) + + -- * Indexing ByteStrings + index, -- :: ByteString -> Int64 -> Word8 + elemIndex, -- :: Word8 -> ByteString -> Maybe Int64 + elemIndices, -- :: Word8 -> ByteString -> [Int64] + findIndex, -- :: (Word8 -> Bool) -> ByteString -> Maybe Int64 + findIndices, -- :: (Word8 -> Bool) -> ByteString -> [Int64] + count, -- :: Word8 -> ByteString -> Int64 + + -- * Zipping and unzipping ByteStrings + zip, -- :: ByteString -> ByteString -> [(Word8,Word8)] + zipWith, -- :: (Word8 -> Word8 -> c) -> ByteString -> ByteString -> [c] + unzip, -- :: [(Word8,Word8)] -> (ByteString,ByteString) + + -- * Ordered ByteStrings +-- sort, -- :: ByteString -> ByteString + + -- * Low level conversions + -- ** Copying ByteStrings + copy, -- :: ByteString -> ByteString +-- defrag, -- :: ByteString -> ByteString + + -- * I\/O with 'ByteString's + + -- ** Standard input and output + getContents, -- :: IO ByteString + putStr, -- :: ByteString -> IO () + putStrLn, -- :: ByteString -> IO () + interact, -- :: (ByteString -> ByteString) -> IO () + + -- ** Files + readFile, -- :: FilePath -> IO ByteString + writeFile, -- :: FilePath -> ByteString -> IO () + appendFile, -- :: FilePath -> ByteString -> IO () + + -- ** I\/O with Handles + hGetContents, -- :: Handle -> IO ByteString + hGet, -- :: Handle -> Int -> IO ByteString + hGetNonBlocking, -- :: Handle -> Int -> IO ByteString + hPut, -- :: Handle -> ByteString -> IO () + hPutStr, -- :: Handle -> ByteString -> IO () + +-- hGetN, -- :: Int -> Handle -> Int -> IO ByteString +-- hGetContentsN, -- :: Int -> Handle -> IO ByteString +-- hGetNonBlockingN, -- :: Int -> Handle -> IO ByteString + + -- undocumented deprecated things: + join -- :: ByteString -> [ByteString] -> ByteString + + ) where + +import qualified Prelude +import Prelude hiding + (reverse,head,tail,last,init,null,length,map,lines,foldl,foldr,unlines + ,concat,any,take,drop,splitAt,takeWhile,dropWhile,span,break,elem,filter,maximum + ,minimum,all,concatMap,foldl1,foldr1,scanl, scanl1, scanr, scanr1 + ,repeat, cycle, interact, iterate,readFile,writeFile,appendFile,replicate + ,getContents,getLine,putStr,putStrLn ,zip,zipWith,unzip,notElem) + +import qualified Data.List as L -- L for list/lazy +import qualified Data.ByteString as S -- S for strict (hmm...) +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Unsafe as S +import Data.ByteString.Lazy.Internal +import qualified Data.ByteString.Fusion as F + +import Data.Monoid (Monoid(..)) + +import Data.Word (Word8) +import Data.Int (Int64) +import System.IO (Handle,stdin,stdout,openBinaryFile,IOMode(..) + ,hClose,hWaitForInput,hIsEOF) +import System.IO.Unsafe +#ifndef __NHC__ +import Control.Exception (bracket) +#else +import IO (bracket) +#endif + +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr +import Foreign.Storable + +-- ----------------------------------------------------------------------------- +-- +-- Useful macros, until we have bang patterns +-- + +#define STRICT1(f) f a | a `seq` False = undefined +#define STRICT2(f) f a b | a `seq` b `seq` False = undefined +#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined +#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined +#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined + +-- ----------------------------------------------------------------------------- + +instance Eq ByteString + where (==) = eq + +instance Ord ByteString + where compare = cmp + +instance Monoid ByteString where + mempty = empty + mappend = append + mconcat = concat + +eq :: ByteString -> ByteString -> Bool +eq Empty Empty = True +eq Empty _ = False +eq _ Empty = False +eq (Chunk a as) (Chunk b bs) = + case compare (S.length a) (S.length b) of + LT -> a == (S.take (S.length a) b) && eq as (Chunk (S.drop (S.length a) b) bs) + EQ -> a == b && eq as bs + GT -> (S.take (S.length b) a) == b && eq (Chunk (S.drop (S.length b) a) as) bs + +cmp :: ByteString -> ByteString -> Ordering +cmp Empty Empty = EQ +cmp Empty _ = LT +cmp _ Empty = GT +cmp (Chunk a as) (Chunk b bs) = + case compare (S.length a) (S.length b) of + LT -> case compare a (S.take (S.length a) b) of + EQ -> cmp as (Chunk (S.drop (S.length a) b) bs) + result -> result + EQ -> case compare a b of + EQ -> cmp as bs + result -> result + GT -> case compare (S.take (S.length b) a) b of + EQ -> cmp (Chunk (S.drop (S.length b) a) as) bs + result -> result + +-- ----------------------------------------------------------------------------- +-- Introducing and eliminating 'ByteString's + +-- | /O(1)/ The empty 'ByteString' +empty :: ByteString +empty = Empty + +-- | /O(1)/ Convert a 'Word8' into a 'ByteString' +singleton :: Word8 -> ByteString +singleton w = Chunk (S.singleton w) Empty + +-- | /O(n)/ Convert a '[Word8]' into a 'ByteString'. +pack :: [Word8] -> ByteString +pack ws = L.foldr (Chunk . S.pack) Empty (chunks defaultChunkSize ws) + where + chunks :: Int -> [a] -> [[a]] + chunks _ [] = [] + chunks size xs = case L.splitAt size xs of + (xs', xs'') -> xs' : chunks size xs'' + +-- | /O(n)/ Converts a 'ByteString' to a '[Word8]'. +unpack :: ByteString -> [Word8] +unpack cs = L.concatMap S.unpack (toChunks cs) +--TODO: we can do better here by integrating the concat with the unpack + +-- | /O(c)/ Convert a list of strict 'ByteString' into a lazy 'ByteString' +fromChunks :: [S.ByteString] -> ByteString +fromChunks cs = L.foldr chunk Empty cs + +-- | /O(n)/ Convert a lazy 'ByteString' into a list of strict 'ByteString' +toChunks :: ByteString -> [S.ByteString] +toChunks cs = foldrChunks (:) [] cs + +------------------------------------------------------------------------ + +{- +-- | /O(n)/ Convert a '[a]' into a 'ByteString' using some +-- conversion function +packWith :: (a -> Word8) -> [a] -> ByteString +packWith k str = LPS $ L.map (P.packWith k) (chunk defaultChunkSize str) +{-# INLINE packWith #-} +{-# SPECIALIZE packWith :: (Char -> Word8) -> [Char] -> ByteString #-} + +-- | /O(n)/ Converts a 'ByteString' to a '[a]', using a conversion function. +unpackWith :: (Word8 -> a) -> ByteString -> [a] +unpackWith k (LPS ss) = L.concatMap (S.unpackWith k) ss +{-# INLINE unpackWith #-} +{-# SPECIALIZE unpackWith :: (Word8 -> Char) -> ByteString -> [Char] #-} +-} + +-- --------------------------------------------------------------------- +-- Basic interface + +-- | /O(1)/ Test whether a ByteString is empty. +null :: ByteString -> Bool +null Empty = True +null _ = False + +-- | /O(n\/c)/ 'length' returns the length of a ByteString as an 'Int64' +length :: ByteString -> Int64 +length cs = foldlChunks (\n c -> n + fromIntegral (S.length c)) 0 cs + +-- | /O(1)/ 'cons' is analogous to '(:)' for lists. +-- +cons :: Word8 -> ByteString -> ByteString +cons c cs = Chunk (S.singleton c) cs + +-- | /O(1)/ Unlike 'cons', 'cons\'' is +-- strict in the ByteString that we are consing onto. More precisely, it forces +-- the head and the first chunk. It does this because, for space efficiency, it +-- may coalesce the new byte onto the first \'chunk\' rather than starting a +-- new \'chunk\'. +-- +-- So that means you can't use a lazy recursive contruction like this: +-- +-- > let xs = cons\' c xs in xs +-- +-- You can however use 'cons', as well as 'repeat' and 'cycle', to build +-- infinite lazy ByteStrings. +-- +cons' :: Word8 -> ByteString -> ByteString +cons' w (Chunk c cs) | S.length c < 16 = Chunk (S.cons w c) cs +cons' w cs = Chunk (S.singleton w) cs + +-- | /O(n\/c)/ Append a byte to the end of a 'ByteString' +snoc :: ByteString -> Word8 -> ByteString +snoc cs w = foldrChunks Chunk (singleton w) cs + +-- | /O(1)/ Extract the first element of a ByteString, which must be non-empty. +head :: ByteString -> Word8 +head Empty = errorEmptyList "head" +head (Chunk c _) = S.unsafeHead c +{-# INLINE head #-} + +-- | /O(1)/ Extract the head and tail of a ByteString, returning Nothing +-- if it is empty. +uncons :: ByteString -> Maybe (Word8, ByteString) +uncons Empty = Nothing +uncons (Chunk c cs) + = Just (S.unsafeHead c, + if S.length c == 1 then cs else Chunk (S.unsafeTail c) cs) +{-# INLINE uncons #-} + +-- | /O(1)/ Extract the elements after the head of a ByteString, which must be +-- non-empty. +tail :: ByteString -> ByteString +tail Empty = errorEmptyList "tail" +tail (Chunk c cs) + | S.length c == 1 = cs + | otherwise = Chunk (S.unsafeTail c) cs + +-- | /O(n\/c)/ Extract the last element of a ByteString, which must be finite +-- and non-empty. +last :: ByteString -> Word8 +last Empty = errorEmptyList "last" +last (Chunk c0 cs0) = go c0 cs0 + where go c Empty = S.last c + go _ (Chunk c cs) = go c cs + +-- | /O(n\/c)/ Return all the elements of a 'ByteString' except the last one. +init :: ByteString -> ByteString +init Empty = errorEmptyList "init" +init (Chunk c0 cs0) = go c0 cs0 + where go c Empty | S.length c == 1 = Empty + | otherwise = Chunk (S.init c) Empty + go c (Chunk c' cs) = Chunk c (go c' cs) + +-- | /O(n\/c)/ Append two ByteStrings +append :: ByteString -> ByteString -> ByteString +append xs ys = foldrChunks Chunk ys xs + +-- --------------------------------------------------------------------- +-- Transformations + +-- | /O(n)/ 'map' @f xs@ is the ByteString obtained by applying @f@ to each +-- element of @xs@. +map :: (Word8 -> Word8) -> ByteString -> ByteString +map f = F.loopArr . F.loopL (F.mapEFL f) F.NoAcc +{-# INLINE map #-} + +-- | /O(n)/ 'reverse' @xs@ returns the elements of @xs@ in reverse order. +reverse :: ByteString -> ByteString +reverse cs0 = rev Empty cs0 + where rev a Empty = a + rev a (Chunk c cs) = rev (Chunk (S.reverse c) a) cs +{-# INLINE reverse #-} + +-- | The 'intersperse' function takes a 'Word8' and a 'ByteString' and +-- \`intersperses\' that byte between the elements of the 'ByteString'. +-- It is analogous to the intersperse function on Lists. +intersperse :: Word8 -> ByteString -> ByteString +intersperse _ Empty = Empty +intersperse w (Chunk c cs) = Chunk (S.intersperse w c) + (foldrChunks (Chunk . intersperse') Empty cs) + where intersperse' :: S.ByteString -> S.ByteString + intersperse' (S.PS fp o l) = + S.unsafeCreate (2*l) $ \p' -> withForeignPtr fp $ \p -> do + poke p' w + S.c_intersperse (p' `plusPtr` 1) (p `plusPtr` o) (fromIntegral l) w + +-- | The 'transpose' function transposes the rows and columns of its +-- 'ByteString' argument. +transpose :: [ByteString] -> [ByteString] +transpose css = L.map (\ss -> Chunk (S.pack ss) Empty) + (L.transpose (L.map unpack css)) +--TODO: make this fast + +-- --------------------------------------------------------------------- +-- Reducing 'ByteString's + +-- | 'foldl', applied to a binary operator, a starting value (typically +-- the left-identity of the operator), and a ByteString, reduces the +-- ByteString using the binary operator, from left to right. +foldl :: (a -> Word8 -> a) -> a -> ByteString -> a +foldl f z = F.loopAcc . F.loopL (F.foldEFL f) z +{-# INLINE foldl #-} + +-- | 'foldl\'' is like 'foldl', but strict in the accumulator. +foldl' :: (a -> Word8 -> a) -> a -> ByteString -> a +foldl' f z = F.loopAcc . F.loopL (F.foldEFL' f) z +{-# INLINE foldl' #-} + +-- | 'foldr', applied to a binary operator, a starting value +-- (typically the right-identity of the operator), and a ByteString, +-- reduces the ByteString using the binary operator, from right to left. +foldr :: (Word8 -> a -> a) -> a -> ByteString -> a +foldr k z cs = foldrChunks (flip (S.foldr k)) z cs +{-# INLINE foldr #-} + +-- | 'foldl1' is a variant of 'foldl' that has no starting value +-- argument, and thus must be applied to non-empty 'ByteStrings'. +-- This function is subject to array fusion. +foldl1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 +foldl1 _ Empty = errorEmptyList "foldl1" +foldl1 f (Chunk c cs) = foldl f (S.unsafeHead c) (Chunk (S.unsafeTail c) cs) + +-- | 'foldl1\'' is like 'foldl1', but strict in the accumulator. +foldl1' :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 +foldl1' _ Empty = errorEmptyList "foldl1'" +foldl1' f (Chunk c cs) = foldl' f (S.unsafeHead c) (Chunk (S.unsafeTail c) cs) + +-- | 'foldr1' is a variant of 'foldr' that has no starting value argument, +-- and thus must be applied to non-empty 'ByteString's +foldr1 :: (Word8 -> Word8 -> Word8) -> ByteString -> Word8 +foldr1 _ Empty = errorEmptyList "foldr1" +foldr1 f (Chunk c0 cs0) = go c0 cs0 + where go c Empty = S.foldr1 f c + go c (Chunk c' cs) = S.foldr f (go c' cs) c + +-- --------------------------------------------------------------------- +-- Special folds + +-- | /O(n)/ Concatenate a list of ByteStrings. +concat :: [ByteString] -> ByteString +concat css0 = to css0 + where + go Empty css = to css + go (Chunk c cs) css = Chunk c (go cs css) + to [] = Empty + to (cs:css) = go cs css + +-- | Map a function over a 'ByteString' and concatenate the results +concatMap :: (Word8 -> ByteString) -> ByteString -> ByteString +concatMap _ Empty = Empty +concatMap f (Chunk c0 cs0) = to c0 cs0 + where + go :: ByteString -> S.ByteString -> ByteString -> ByteString + go Empty c' cs' = to c' cs' + go (Chunk c cs) c' cs' = Chunk c (go cs c' cs') + + to :: S.ByteString -> ByteString -> ByteString + to c cs | S.null c = case cs of + Empty -> Empty + (Chunk c' cs') -> to c' cs' + | otherwise = go (f (S.unsafeHead c)) (S.unsafeTail c) cs + +-- | /O(n)/ Applied to a predicate and a ByteString, 'any' determines if +-- any element of the 'ByteString' satisfies the predicate. +any :: (Word8 -> Bool) -> ByteString -> Bool +any f cs = foldrChunks (\c rest -> S.any f c || rest) False cs +-- todo fuse + +-- | /O(n)/ Applied to a predicate and a 'ByteString', 'all' determines +-- if all elements of the 'ByteString' satisfy the predicate. +all :: (Word8 -> Bool) -> ByteString -> Bool +all f cs = foldrChunks (\c rest -> S.all f c && rest) True cs +-- todo fuse + +-- | /O(n)/ 'maximum' returns the maximum value from a 'ByteString' +maximum :: ByteString -> Word8 +maximum Empty = errorEmptyList "maximum" +maximum (Chunk c cs) = foldlChunks (\n c' -> n `max` S.maximum c') + (S.maximum c) cs +{-# INLINE maximum #-} + +-- | /O(n)/ 'minimum' returns the minimum value from a 'ByteString' +minimum :: ByteString -> Word8 +minimum Empty = errorEmptyList "minimum" +minimum (Chunk c cs) = foldlChunks (\n c' -> n `min` S.minimum c') + (S.minimum c) cs +{-# INLINE minimum #-} + +-- | The 'mapAccumL' function behaves like a combination of 'map' and +-- 'foldl'; it applies a function to each element of a ByteString, +-- passing an accumulating parameter from left to right, and returning a +-- final value of this accumulator together with the new ByteString. +mapAccumL :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) +mapAccumL f s0 cs0 = go s0 cs0 + where + go s Empty = (s, Empty) + go s (Chunk c cs) = (s'', Chunk c' cs') + where (s', c') = S.mapAccumL f s c + (s'', cs') = go s' cs + +-- | The 'mapAccumR' function behaves like a combination of 'map' and +-- 'foldr'; it applies a function to each element of a ByteString, +-- passing an accumulating parameter from right to left, and returning a +-- final value of this accumulator together with the new ByteString. +mapAccumR :: (acc -> Word8 -> (acc, Word8)) -> acc -> ByteString -> (acc, ByteString) +mapAccumR f s0 cs0 = go s0 cs0 + where + go s Empty = (s, Empty) + go s (Chunk c cs) = (s'', Chunk c' cs') + where (s'', c') = S.mapAccumR f s' c + (s', cs') = go s cs + +-- | /O(n)/ map Word8 functions, provided with the index at each position +mapIndexed :: (Int -> Word8 -> Word8) -> ByteString -> ByteString +mapIndexed f = F.loopArr . F.loopL (F.mapIndexEFL f) 0 + +-- --------------------------------------------------------------------- +-- Building ByteStrings + +-- | 'scanl' is similar to 'foldl', but returns a list of successive +-- reduced values from the left. This function will fuse. +-- +-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +-- +-- Note that +-- +-- > last (scanl f z xs) == foldl f z xs. +scanl :: (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> ByteString +scanl f z ps = F.loopArr . F.loopL (F.scanEFL f) z $ (ps `snoc` 0) +{-# INLINE scanl #-} + +-- --------------------------------------------------------------------- +-- Unfolds and replicates + +-- | @'iterate' f x@ returns an infinite ByteString of repeated applications +-- of @f@ to @x@: +-- +-- > iterate f x == [x, f x, f (f x), ...] +-- +iterate :: (Word8 -> Word8) -> Word8 -> ByteString +iterate f = unfoldr (\x -> case f x of x' -> x' `seq` Just (x', x')) + +-- | @'repeat' x@ is an infinite ByteString, with @x@ the value of every +-- element. +-- +repeat :: Word8 -> ByteString +repeat w = cs where cs = Chunk (S.replicate smallChunkSize w) cs + +-- | /O(n)/ @'replicate' n x@ is a ByteString of length @n@ with @x@ +-- the value of every element. +-- +replicate :: Int64 -> Word8 -> ByteString +replicate n w + | n <= 0 = Empty + | n < fromIntegral smallChunkSize = Chunk (S.replicate (fromIntegral n) w) Empty + | r == 0 = cs -- preserve invariant + | otherwise = Chunk (S.unsafeTake (fromIntegral r) c) cs + where + c = S.replicate smallChunkSize w + cs = nChunks q + (q, r) = quotRem n (fromIntegral smallChunkSize) + nChunks 0 = Empty + nChunks m = Chunk c (nChunks (m-1)) + + +-- | 'cycle' ties a finite ByteString into a circular one, or equivalently, +-- the infinite repetition of the original ByteString. +-- +cycle :: ByteString -> ByteString +cycle Empty = errorEmptyList "cycle" +cycle cs = cs' where cs' = foldrChunks Chunk cs' cs + +-- | /O(n)/ The 'unfoldr' function is analogous to the List \'unfoldr\'. +-- 'unfoldr' builds a ByteString from a seed value. The function takes +-- the element and returns 'Nothing' if it is done producing the +-- ByteString or returns 'Just' @(a,b)@, in which case, @a@ is a +-- prepending to the ByteString and @b@ is used as the next element in a +-- recursive call. +unfoldr :: (a -> Maybe (Word8, a)) -> a -> ByteString +unfoldr f s0 = unfoldChunk 32 s0 + where unfoldChunk n s = + case S.unfoldrN n f s of + (c, Nothing) + | S.null c -> Empty + | otherwise -> Chunk c Empty + (c, Just s') -> Chunk c (unfoldChunk (n*2) s') + +-- --------------------------------------------------------------------- +-- Substrings + +-- | /O(n\/c)/ 'take' @n@, applied to a ByteString @xs@, returns the prefix +-- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@. +take :: Int64 -> ByteString -> ByteString +take i _ | i <= 0 = Empty +take i cs0 = take' i cs0 + where take' 0 _ = Empty + take' _ Empty = Empty + take' n (Chunk c cs) = + if n < fromIntegral (S.length c) + then Chunk (S.take (fromIntegral n) c) Empty + else Chunk c (take' (n - fromIntegral (S.length c)) cs) + +-- | /O(n\/c)/ 'drop' @n xs@ returns the suffix of @xs@ after the first @n@ +-- elements, or @[]@ if @n > 'length' xs@. +drop :: Int64 -> ByteString -> ByteString +drop i p | i <= 0 = p +drop i cs0 = drop' i cs0 + where drop' 0 cs = cs + drop' _ Empty = Empty + drop' n (Chunk c cs) = + if n < fromIntegral (S.length c) + then Chunk (S.drop (fromIntegral n) c) cs + else drop' (n - fromIntegral (S.length c)) cs + +-- | /O(n\/c)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@. +splitAt :: Int64 -> ByteString -> (ByteString, ByteString) +splitAt i cs0 | i <= 0 = (Empty, cs0) +splitAt i cs0 = splitAt' i cs0 + where splitAt' 0 cs = (Empty, cs) + splitAt' _ Empty = (Empty, Empty) + splitAt' n (Chunk c cs) = + if n < fromIntegral (S.length c) + then (Chunk (S.take (fromIntegral n) c) Empty + ,Chunk (S.drop (fromIntegral n) c) cs) + else let (cs', cs'') = splitAt' (n - fromIntegral (S.length c)) cs + in (Chunk c cs', cs'') + + +-- | 'takeWhile', applied to a predicate @p@ and a ByteString @xs@, +-- returns the longest prefix (possibly empty) of @xs@ of elements that +-- satisfy @p@. +takeWhile :: (Word8 -> Bool) -> ByteString -> ByteString +takeWhile f cs0 = takeWhile' cs0 + where takeWhile' Empty = Empty + takeWhile' (Chunk c cs) = + case findIndexOrEnd (not . f) c of + 0 -> Empty + n | n < S.length c -> Chunk (S.take n c) Empty + | otherwise -> Chunk c (takeWhile' cs) + +-- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@. +dropWhile :: (Word8 -> Bool) -> ByteString -> ByteString +dropWhile f cs0 = dropWhile' cs0 + where dropWhile' Empty = Empty + dropWhile' (Chunk c cs) = + case findIndexOrEnd (not . f) c of + n | n < S.length c -> Chunk (S.drop n c) cs + | otherwise -> dropWhile' cs + +-- | 'break' @p@ is equivalent to @'span' ('not' . p)@. +break :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) +break f cs0 = break' cs0 + where break' Empty = (Empty, Empty) + break' (Chunk c cs) = + case findIndexOrEnd f c of + 0 -> (Empty, Chunk c cs) + n | n < S.length c -> (Chunk (S.take n c) Empty + ,Chunk (S.drop n c) cs) + | otherwise -> let (cs', cs'') = break' cs + in (Chunk c cs', cs'') + +-- +-- TODO +-- +-- Add rules +-- + +{- +-- | 'breakByte' breaks its ByteString argument at the first occurence +-- of the specified byte. It is more efficient than 'break' as it is +-- implemented with @memchr(3)@. I.e. +-- +-- > break (=='c') "abcd" == breakByte 'c' "abcd" +-- +breakByte :: Word8 -> ByteString -> (ByteString, ByteString) +breakByte c (LPS ps) = case (breakByte' ps) of (a,b) -> (LPS a, LPS b) + where breakByte' [] = ([], []) + breakByte' (x:xs) = + case P.elemIndex c x of + Just 0 -> ([], x : xs) + Just n -> (P.take n x : [], P.drop n x : xs) + Nothing -> let (xs', xs'') = breakByte' xs + in (x : xs', xs'') + +-- | 'spanByte' breaks its ByteString argument at the first +-- occurence of a byte other than its argument. It is more efficient +-- than 'span (==)' +-- +-- > span (=='c') "abcd" == spanByte 'c' "abcd" +-- +spanByte :: Word8 -> ByteString -> (ByteString, ByteString) +spanByte c (LPS ps) = case (spanByte' ps) of (a,b) -> (LPS a, LPS b) + where spanByte' [] = ([], []) + spanByte' (x:xs) = + case P.spanByte c x of + (x', x'') | P.null x' -> ([], x : xs) + | P.null x'' -> let (xs', xs'') = spanByte' xs + in (x : xs', xs'') + | otherwise -> (x' : [], x'' : xs) +-} + +-- | 'span' @p xs@ breaks the ByteString into two segments. It is +-- equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@ +span :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) +span p = break (not . p) + +-- | /O(n)/ Splits a 'ByteString' into components delimited by +-- separators, where the predicate returns True for a separator element. +-- The resulting components do not contain the separators. Two adjacent +-- separators result in an empty component in the output. eg. +-- +-- > splitWith (=='a') "aabbaca" == ["","","bb","c",""] +-- > splitWith (=='a') [] == [] +-- +splitWith :: (Word8 -> Bool) -> ByteString -> [ByteString] +splitWith _ Empty = [] +splitWith p (Chunk c0 cs0) = comb [] (S.splitWith p c0) cs0 + + where comb :: [S.ByteString] -> [S.ByteString] -> ByteString -> [ByteString] + comb acc (s:[]) Empty = revChunks (s:acc) : [] + comb acc (s:[]) (Chunk c cs) = comb (s:acc) (S.splitWith p c) cs + comb acc (s:ss) cs = revChunks (s:acc) : comb [] ss cs + +{-# INLINE splitWith #-} + +-- | /O(n)/ Break a 'ByteString' into pieces separated by the byte +-- argument, consuming the delimiter. I.e. +-- +-- > split '\n' "a\nb\nd\ne" == ["a","b","d","e"] +-- > split 'a' "aXaXaXa" == ["","X","X","X",""] +-- > split 'x' "x" == ["",""] +-- +-- and +-- +-- > intercalate [c] . split c == id +-- > split == splitWith . (==) +-- +-- As for all splitting functions in this library, this function does +-- not copy the substrings, it just constructs new 'ByteStrings' that +-- are slices of the original. +-- +split :: Word8 -> ByteString -> [ByteString] +split _ Empty = [] +split w (Chunk c0 cs0) = comb [] (S.split w c0) cs0 + + where comb :: [S.ByteString] -> [S.ByteString] -> ByteString -> [ByteString] + comb acc (s:[]) Empty = revChunks (s:acc) : [] + comb acc (s:[]) (Chunk c cs) = comb (s:acc) (S.split w c) cs + comb acc (s:ss) cs = revChunks (s:acc) : comb [] ss cs +{-# INLINE split #-} + +{- +-- | Like 'splitWith', except that sequences of adjacent separators are +-- treated as a single separator. eg. +-- +-- > tokens (=='a') "aabbaca" == ["bb","c"] +-- +tokens :: (Word8 -> Bool) -> ByteString -> [ByteString] +tokens f = L.filter (not.null) . splitWith f +-} + +-- | The 'group' function takes a ByteString and returns a list of +-- ByteStrings such that the concatenation of the result is equal to the +-- argument. Moreover, each sublist in the result contains only equal +-- elements. For example, +-- +-- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"] +-- +-- It is a special case of 'groupBy', which allows the programmer to +-- supply their own equality test. +group :: ByteString -> [ByteString] +group Empty = [] +group (Chunk c0 cs0) = group' [] (S.group c0) cs0 + where + group' :: [S.ByteString] -> [S.ByteString] -> ByteString -> [ByteString] + group' acc@(s':_) ss@(s:_) cs + | S.unsafeHead s' + /= S.unsafeHead s = revNonEmptyChunks acc : group' [] ss cs + group' acc (s:[]) Empty = revNonEmptyChunks (s:acc) : [] + group' acc (s:[]) (Chunk c cs) = group' (s:acc) (S.group c) cs + group' acc (s:ss) cs = revNonEmptyChunks (s:acc) : group' [] ss cs + +{- +TODO: check if something like this might be faster + +group :: ByteString -> [ByteString] +group xs + | null xs = [] + | otherwise = ys : group zs + where + (ys, zs) = spanByte (unsafeHead xs) xs +-} + +-- | The 'groupBy' function is the non-overloaded version of 'group'. +-- +groupBy :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString] +groupBy _ Empty = [] +groupBy k (Chunk c0 cs0) = groupBy' [] 0 (S.groupBy k c0) cs0 + where + groupBy' :: [S.ByteString] -> Word8 -> [S.ByteString] -> ByteString -> [ByteString] + groupBy' acc@(_:_) c ss@(s:_) cs + | not (c `k` S.unsafeHead s) = revNonEmptyChunks acc : groupBy' [] 0 ss cs + groupBy' acc _ (s:[]) Empty = revNonEmptyChunks (s : acc) : [] + groupBy' acc w (s:[]) (Chunk c cs) = groupBy' (s:acc) w' (S.groupBy k c) cs + where w' | L.null acc = S.unsafeHead s + | otherwise = w + groupBy' acc _ (s:ss) cs = revNonEmptyChunks (s : acc) : groupBy' [] 0 ss cs + +{- +TODO: check if something like this might be faster + +groupBy :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString] +groupBy k xs + | null xs = [] + | otherwise = take n xs : groupBy k (drop n xs) + where + n = 1 + findIndexOrEnd (not . k (head xs)) (tail xs) +-} + +-- | /O(n)/ The 'intercalate' function takes a 'ByteString' and a list of +-- 'ByteString's and concatenates the list after interspersing the first +-- argument between each element of the list. +intercalate :: ByteString -> [ByteString] -> ByteString +intercalate s = concat . (L.intersperse s) + +join :: ByteString -> [ByteString] -> ByteString +join = intercalate +{-# DEPRECATED join "use intercalate" #-} + +-- --------------------------------------------------------------------- +-- Indexing ByteStrings + +-- | /O(c)/ 'ByteString' index (subscript) operator, starting from 0. +index :: ByteString -> Int64 -> Word8 +index _ i | i < 0 = moduleError "index" ("negative index: " ++ show i) +index cs0 i = index' cs0 i + where index' Empty n = moduleError "index" ("index too large: " ++ show n) + index' (Chunk c cs) n + | n >= fromIntegral (S.length c) = + index' cs (n - fromIntegral (S.length c)) + | otherwise = S.unsafeIndex c (fromIntegral n) + +-- | /O(n)/ The 'elemIndex' function returns the index of the first +-- element in the given 'ByteString' which is equal to the query +-- element, or 'Nothing' if there is no such element. +-- This implementation uses memchr(3). +elemIndex :: Word8 -> ByteString -> Maybe Int64 +elemIndex w cs0 = elemIndex' 0 cs0 + where elemIndex' _ Empty = Nothing + elemIndex' n (Chunk c cs) = + case S.elemIndex w c of + Nothing -> elemIndex' (n + fromIntegral (S.length c)) cs + Just i -> Just (n + fromIntegral i) + +{- +-- | /O(n)/ The 'elemIndexEnd' function returns the last index of the +-- element in the given 'ByteString' which is equal to the query +-- element, or 'Nothing' if there is no such element. The following +-- holds: +-- +-- > elemIndexEnd c xs == +-- > (-) (length xs - 1) `fmap` elemIndex c (reverse xs) +-- +elemIndexEnd :: Word8 -> ByteString -> Maybe Int +elemIndexEnd ch (PS x s l) = inlinePerformIO $ withForeignPtr x $ \p -> + go (p `plusPtr` s) (l-1) + where + STRICT2(go) + go p i | i < 0 = return Nothing + | otherwise = do ch' <- peekByteOff p i + if ch == ch' + then return $ Just i + else go p (i-1) +-} +-- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning +-- the indices of all elements equal to the query element, in ascending order. +-- This implementation uses memchr(3). +elemIndices :: Word8 -> ByteString -> [Int64] +elemIndices w cs0 = elemIndices' 0 cs0 + where elemIndices' _ Empty = [] + elemIndices' n (Chunk c cs) = L.map ((+n).fromIntegral) (S.elemIndices w c) + ++ elemIndices' (n + fromIntegral (S.length c)) cs + +-- | count returns the number of times its argument appears in the ByteString +-- +-- > count = length . elemIndices +-- +-- But more efficiently than using length on the intermediate list. +count :: Word8 -> ByteString -> Int64 +count w cs = foldlChunks (\n c -> n + fromIntegral (S.count w c)) 0 cs + +-- | The 'findIndex' function takes a predicate and a 'ByteString' and +-- returns the index of the first element in the ByteString +-- satisfying the predicate. +findIndex :: (Word8 -> Bool) -> ByteString -> Maybe Int64 +findIndex k cs0 = findIndex' 0 cs0 + where findIndex' _ Empty = Nothing + findIndex' n (Chunk c cs) = + case S.findIndex k c of + Nothing -> findIndex' (n + fromIntegral (S.length c)) cs + Just i -> Just (n + fromIntegral i) +{-# INLINE findIndex #-} + +-- | /O(n)/ The 'find' function takes a predicate and a ByteString, +-- and returns the first element in matching the predicate, or 'Nothing' +-- if there is no such element. +-- +-- > find f p = case findIndex f p of Just n -> Just (p ! n) ; _ -> Nothing +-- +find :: (Word8 -> Bool) -> ByteString -> Maybe Word8 +find f cs0 = find' cs0 + where find' Empty = Nothing + find' (Chunk c cs) = case S.find f c of + Nothing -> find' cs + Just w -> Just w +{-# INLINE find #-} + +-- | The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending order. +findIndices :: (Word8 -> Bool) -> ByteString -> [Int64] +findIndices k cs0 = findIndices' 0 cs0 + where findIndices' _ Empty = [] + findIndices' n (Chunk c cs) = L.map ((+n).fromIntegral) (S.findIndices k c) + ++ findIndices' (n + fromIntegral (S.length c)) cs + +-- --------------------------------------------------------------------- +-- Searching ByteStrings + +-- | /O(n)/ 'elem' is the 'ByteString' membership predicate. +elem :: Word8 -> ByteString -> Bool +elem w cs = case elemIndex w cs of Nothing -> False ; _ -> True + +-- | /O(n)/ 'notElem' is the inverse of 'elem' +notElem :: Word8 -> ByteString -> Bool +notElem w cs = not (elem w cs) + +-- | /O(n)/ 'filter', applied to a predicate and a ByteString, +-- returns a ByteString containing those characters that satisfy the +-- predicate. +filter :: (Word8 -> Bool) -> ByteString -> ByteString +filter p = F.loopArr . F.loopL (F.filterEFL p) F.NoAcc +{-# INLINE filter #-} + +{- +-- | /O(n)/ and /O(n\/c) space/ A first order equivalent of /filter . +-- (==)/, for the common case of filtering a single byte. It is more +-- efficient to use /filterByte/ in this case. +-- +-- > filterByte == filter . (==) +-- +-- filterByte is around 10x faster, and uses much less space, than its +-- filter equivalent +filterByte :: Word8 -> ByteString -> ByteString +filterByte w ps = replicate (count w ps) w +-- filterByte w (LPS xs) = LPS (filterMap (P.filterByte w) xs) + +-- | /O(n)/ A first order equivalent of /filter . (\/=)/, for the common +-- case of filtering a single byte out of a list. It is more efficient +-- to use /filterNotByte/ in this case. +-- +-- > filterNotByte == filter . (/=) +-- +-- filterNotByte is around 2x faster than its filter equivalent. +filterNotByte :: Word8 -> ByteString -> ByteString +filterNotByte w (LPS xs) = LPS (filterMap (P.filterNotByte w) xs) +-} + +-- | /O(n)/ The 'partition' function takes a predicate a ByteString and returns +-- the pair of ByteStrings with elements which do and do not satisfy the +-- predicate, respectively; i.e., +-- +-- > partition p bs == (filter p xs, filter (not . p) xs) +-- +partition :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) +partition f p = (filter f p, filter (not . f) p) +--TODO: use a better implementation + +-- --------------------------------------------------------------------- +-- Searching for substrings + +-- | /O(n)/ The 'isPrefixOf' function takes two ByteStrings and returns 'True' +-- iff the first is a prefix of the second. +isPrefixOf :: ByteString -> ByteString -> Bool +isPrefixOf Empty _ = True +isPrefixOf _ Empty = False +isPrefixOf (Chunk x xs) (Chunk y ys) + | S.length x == S.length y = x == y && isPrefixOf xs ys + | S.length x < S.length y = x == yh && isPrefixOf xs (Chunk yt ys) + | otherwise = xh == y && isPrefixOf (Chunk xt xs) ys + where (xh,xt) = S.splitAt (S.length y) x + (yh,yt) = S.splitAt (S.length x) y + +-- | /O(n)/ The 'isSuffixOf' function takes two ByteStrings and returns 'True' +-- iff the first is a suffix of the second. +-- +-- The following holds: +-- +-- > isSuffixOf x y == reverse x `isPrefixOf` reverse y +-- +isSuffixOf :: ByteString -> ByteString -> Bool +isSuffixOf x y = reverse x `isPrefixOf` reverse y +--TODO: a better implementation + +-- --------------------------------------------------------------------- +-- Zipping + +-- | /O(n)/ 'zip' takes two ByteStrings and returns a list of +-- corresponding pairs of bytes. If one input ByteString is short, +-- excess elements of the longer ByteString are discarded. This is +-- equivalent to a pair of 'unpack' operations. +zip :: ByteString -> ByteString -> [(Word8,Word8)] +zip = zipWith (,) + +-- | 'zipWith' generalises 'zip' by zipping with the function given as +-- the first argument, instead of a tupling function. For example, +-- @'zipWith' (+)@ is applied to two ByteStrings to produce the list of +-- corresponding sums. +zipWith :: (Word8 -> Word8 -> a) -> ByteString -> ByteString -> [a] +zipWith _ Empty _ = [] +zipWith _ _ Empty = [] +zipWith f (Chunk a as) (Chunk b bs) = go a as b bs + where + go x xs y ys = f (S.unsafeHead x) (S.unsafeHead y) + : to (S.unsafeTail x) xs (S.unsafeTail y) ys + + to x Empty _ _ | S.null x = [] + to _ _ y Empty | S.null y = [] + to x xs y ys | not (S.null x) + && not (S.null y) = go x xs y ys + to x xs _ (Chunk y' ys) | not (S.null x) = go x xs y' ys + to _ (Chunk x' xs) y ys | not (S.null y) = go x' xs y ys + to _ (Chunk x' xs) _ (Chunk y' ys) = go x' xs y' ys + +-- | /O(n)/ 'unzip' transforms a list of pairs of bytes into a pair of +-- ByteStrings. Note that this performs two 'pack' operations. +unzip :: [(Word8,Word8)] -> (ByteString,ByteString) +unzip ls = (pack (L.map fst ls), pack (L.map snd ls)) +{-# INLINE unzip #-} + +-- --------------------------------------------------------------------- +-- Special lists + +-- | /O(n)/ Return all initial segments of the given 'ByteString', shortest first. +inits :: ByteString -> [ByteString] +inits = (Empty :) . inits' + where inits' Empty = [] + inits' (Chunk c cs) = L.map (\c' -> Chunk c' Empty) (L.tail (S.inits c)) + ++ L.map (Chunk c) (inits' cs) + +-- | /O(n)/ Return all final segments of the given 'ByteString', longest first. +tails :: ByteString -> [ByteString] +tails Empty = Empty : [] +tails cs@(Chunk c cs') + | S.length c == 1 = cs : tails cs' + | otherwise = cs : tails (Chunk (S.unsafeTail c) cs') + +-- --------------------------------------------------------------------- +-- Low level constructors + +-- | /O(n)/ Make a copy of the 'ByteString' with its own storage. +-- This is mainly useful to allow the rest of the data pointed +-- to by the 'ByteString' to be garbage collected, for example +-- if a large string has been read in, and only a small part of it +-- is needed in the rest of the program. +copy :: ByteString -> ByteString +copy cs = foldrChunks (Chunk . S.copy) Empty cs +--TODO, we could coalese small blocks here +--FIXME: probably not strict enough, if we're doing this to avoid retaining +-- the parent blocks then we'd better copy strictly. + +-- --------------------------------------------------------------------- + +-- TODO defrag func that concatenates block together that are below a threshold +-- defrag :: ByteString -> ByteString + +-- --------------------------------------------------------------------- +-- Lazy ByteString IO + +-- | Read entire handle contents /lazily/ into a 'ByteString'. Chunks +-- are read on demand, in at most @k@-sized chunks. It does not block +-- waiting for a whole @k@-sized chunk, so if less than @k@ bytes are +-- available then they will be returned immediately as a smaller chunk. +hGetContentsN :: Int -> Handle -> IO ByteString +hGetContentsN k h = lazyRead + where + lazyRead = unsafeInterleaveIO loop + + loop = do + c <- S.hGetNonBlocking h k + --TODO: I think this should distinguish EOF from no data available + -- the underlying POSIX call makes this distincion, returning either + -- 0 or EAGAIN + if S.null c + then do eof <- hIsEOF h + if eof then return Empty + else hWaitForInput h (-1) + >> loop + else do cs <- lazyRead + return (Chunk c cs) + +-- | Read @n@ bytes into a 'ByteString', directly from the +-- specified 'Handle', in chunks of size @k@. +hGetN :: Int -> Handle -> Int -> IO ByteString +hGetN _ _ 0 = return empty +hGetN k h n = readChunks n + where + STRICT1(readChunks) + readChunks i = do + c <- S.hGet h (min k i) + case S.length c of + 0 -> return Empty + m -> do cs <- readChunks (i - m) + return (Chunk c cs) + +-- | hGetNonBlockingN is similar to 'hGetContentsN', except that it will never block +-- waiting for data to become available, instead it returns only whatever data +-- is available. Chunks are read on demand, in @k@-sized chunks. +hGetNonBlockingN :: Int -> Handle -> Int -> IO ByteString +#if defined(__GLASGOW_HASKELL__) +hGetNonBlockingN _ _ 0 = return empty +hGetNonBlockingN k h n = readChunks n + where + STRICT1(readChunks) + readChunks i = do + c <- S.hGetNonBlocking h (min k i) + case S.length c of + 0 -> return Empty + m -> do cs <- readChunks (i - m) + return (Chunk c cs) +#else +hGetNonBlockingN = hGetN +#endif + +-- | Read entire handle contents /lazily/ into a 'ByteString'. Chunks +-- are read on demand, using the default chunk size. +hGetContents :: Handle -> IO ByteString +hGetContents = hGetContentsN defaultChunkSize + +-- | Read @n@ bytes into a 'ByteString', directly from the specified 'Handle'. +hGet :: Handle -> Int -> IO ByteString +hGet = hGetN defaultChunkSize + +-- | hGetNonBlocking is similar to 'hGet', except that it will never block +-- waiting for data to become available, instead it returns only whatever data +-- is available. +#if defined(__GLASGOW_HASKELL__) +hGetNonBlocking :: Handle -> Int -> IO ByteString +hGetNonBlocking = hGetNonBlockingN defaultChunkSize +#else +hGetNonBlocking = hGet +#endif + +-- | Read an entire file /lazily/ into a 'ByteString'. +readFile :: FilePath -> IO ByteString +readFile f = openBinaryFile f ReadMode >>= hGetContents + +-- | Write a 'ByteString' to a file. +writeFile :: FilePath -> ByteString -> IO () +writeFile f txt = bracket (openBinaryFile f WriteMode) hClose + (\hdl -> hPut hdl txt) + +-- | Append a 'ByteString' to a file. +appendFile :: FilePath -> ByteString -> IO () +appendFile f txt = bracket (openBinaryFile f AppendMode) hClose + (\hdl -> hPut hdl txt) + +-- | getContents. Equivalent to hGetContents stdin. Will read /lazily/ +getContents :: IO ByteString +getContents = hGetContents stdin + +-- | Outputs a 'ByteString' to the specified 'Handle'. +hPut :: Handle -> ByteString -> IO () +hPut h cs = foldrChunks (\c rest -> S.hPut h c >> rest) (return ()) cs + +-- | A synonym for @hPut@, for compatibility +hPutStr :: Handle -> ByteString -> IO () +hPutStr = hPut + +-- | Write a ByteString to stdout +putStr :: ByteString -> IO () +putStr = hPut stdout + +-- | Write a ByteString to stdout, appending a newline byte +putStrLn :: ByteString -> IO () +putStrLn ps = hPut stdout ps >> hPut stdout (singleton 0x0a) + +-- | The interact function takes a function of type @ByteString -> ByteString@ +-- as its argument. The entire input from the standard input device is passed +-- to this function as its argument, and the resulting string is output on the +-- standard output device. It's great for writing one line programs! +interact :: (ByteString -> ByteString) -> IO () +interact transformer = putStr . transformer =<< getContents + +-- --------------------------------------------------------------------- +-- Internal utilities + +-- Common up near identical calls to `error' to reduce the number +-- constant strings created when compiled: +errorEmptyList :: String -> a +errorEmptyList fun = moduleError fun "empty ByteString" + +moduleError :: String -> String -> a +moduleError fun msg = error ("Data.ByteString.Lazy." ++ fun ++ ':':' ':msg) + + +-- reverse a list of non-empty chunks into a lazy ByteString +revNonEmptyChunks :: [S.ByteString] -> ByteString +revNonEmptyChunks cs = L.foldl' (flip Chunk) Empty cs + +-- reverse a list of possibly-empty chunks into a lazy ByteString +revChunks :: [S.ByteString] -> ByteString +revChunks cs = L.foldl' (flip chunk) Empty cs + +-- | 'findIndexOrEnd' is a variant of findIndex, that returns the length +-- of the string if no element is found, rather than Nothing. +findIndexOrEnd :: (Word8 -> Bool) -> S.ByteString -> Int +findIndexOrEnd k (S.PS x s l) = S.inlinePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0 + where + STRICT2(go) + go ptr n | n >= l = return l + | otherwise = do w <- peek ptr + if k w + then return n + else go (ptr `plusPtr` 1) (n+1) +{-# INLINE findIndexOrEnd #-} diff --git a/Data/ByteString/Lazy/Char8.hs b/Data/ByteString/Lazy/Char8.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/Char8.hs @@ -0,0 +1,799 @@ +{-# OPTIONS_GHC -cpp -fno-warn-orphans #-} + +-- #prune + +-- | +-- Module : Data.ByteString.Lazy.Char8 +-- Copyright : (c) Don Stewart 2006 +-- License : BSD-style +-- +-- Maintainer : dons@cse.unsw.edu.au +-- Stability : experimental +-- Portability : non-portable (imports Data.ByteString.Lazy) +-- +-- Manipulate /lazy/ 'ByteString's using 'Char' operations. All Chars will +-- be truncated to 8 bits. It can be expected that these functions will +-- run at identical speeds to their 'Data.Word.Word8' equivalents in +-- "Data.ByteString.Lazy". +-- +-- This module is intended to be imported @qualified@, to avoid name +-- clashes with "Prelude" functions. eg. +-- +-- > import qualified Data.ByteString.Lazy.Char8 as C +-- + +module Data.ByteString.Lazy.Char8 ( + + -- * The @ByteString@ type + ByteString, -- instances: Eq, Ord, Show, Read, Data, Typeable + + -- * Introducing and eliminating 'ByteString's + empty, -- :: ByteString + singleton, -- :: Char -> ByteString + pack, -- :: String -> ByteString + unpack, -- :: ByteString -> String + fromChunks, -- :: [Strict.ByteString] -> ByteString + toChunks, -- :: ByteString -> [Strict.ByteString] + + -- * Basic interface + cons, -- :: Char -> ByteString -> ByteString + cons', -- :: Char -> ByteString -> ByteString + snoc, -- :: ByteString -> Char -> ByteString + append, -- :: ByteString -> ByteString -> ByteString + head, -- :: ByteString -> Char + uncons, -- :: ByteString -> Maybe (Char, ByteString) + last, -- :: ByteString -> Char + tail, -- :: ByteString -> ByteString + init, -- :: ByteString -> ByteString + null, -- :: ByteString -> Bool + length, -- :: ByteString -> Int64 + + -- * Transforming ByteStrings + map, -- :: (Char -> Char) -> ByteString -> ByteString + reverse, -- :: ByteString -> ByteString + intersperse, -- :: Char -> ByteString -> ByteString + intercalate, -- :: ByteString -> [ByteString] -> ByteString + transpose, -- :: [ByteString] -> [ByteString] + + -- * Reducing 'ByteString's (folds) + foldl, -- :: (a -> Char -> a) -> a -> ByteString -> a + foldl', -- :: (a -> Char -> a) -> a -> ByteString -> a + foldl1, -- :: (Char -> Char -> Char) -> ByteString -> Char + foldl1', -- :: (Char -> Char -> Char) -> ByteString -> Char + foldr, -- :: (Char -> a -> a) -> a -> ByteString -> a + foldr1, -- :: (Char -> Char -> Char) -> ByteString -> Char + + -- ** Special folds + concat, -- :: [ByteString] -> ByteString + concatMap, -- :: (Char -> ByteString) -> ByteString -> ByteString + any, -- :: (Char -> Bool) -> ByteString -> Bool + all, -- :: (Char -> Bool) -> ByteString -> Bool + maximum, -- :: ByteString -> Char + minimum, -- :: ByteString -> Char + + -- * Building ByteStrings + -- ** Scans + scanl, -- :: (Char -> Char -> Char) -> Char -> ByteString -> ByteString +-- scanl1, -- :: (Char -> Char -> Char) -> ByteString -> ByteString +-- scanr, -- :: (Char -> Char -> Char) -> Char -> ByteString -> ByteString +-- scanr1, -- :: (Char -> Char -> Char) -> ByteString -> ByteString + + -- ** Accumulating maps + mapAccumL, -- :: (acc -> Char -> (acc, Char)) -> acc -> ByteString -> (acc, ByteString) + mapIndexed, -- :: (Int64 -> Char -> Char) -> ByteString -> ByteString + + -- ** Infinite ByteStrings + repeat, -- :: Char -> ByteString + replicate, -- :: Int64 -> Char -> ByteString + cycle, -- :: ByteString -> ByteString + iterate, -- :: (Char -> Char) -> Char -> ByteString + + -- ** Unfolding ByteStrings + unfoldr, -- :: (a -> Maybe (Char, a)) -> a -> ByteString + + -- * Substrings + + -- ** Breaking strings + take, -- :: Int64 -> ByteString -> ByteString + drop, -- :: Int64 -> ByteString -> ByteString + splitAt, -- :: Int64 -> ByteString -> (ByteString, ByteString) + takeWhile, -- :: (Char -> Bool) -> ByteString -> ByteString + dropWhile, -- :: (Char -> Bool) -> ByteString -> ByteString + span, -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) + break, -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) + group, -- :: ByteString -> [ByteString] + groupBy, -- :: (Char -> Char -> Bool) -> ByteString -> [ByteString] + inits, -- :: ByteString -> [ByteString] + tails, -- :: ByteString -> [ByteString] + + -- ** Breaking into many substrings + split, -- :: Char -> ByteString -> [ByteString] + splitWith, -- :: (Char -> Bool) -> ByteString -> [ByteString] + + -- ** Breaking into lines and words + lines, -- :: ByteString -> [ByteString] + words, -- :: ByteString -> [ByteString] + unlines, -- :: [ByteString] -> ByteString + unwords, -- :: ByteString -> [ByteString] + + -- * Predicates + isPrefixOf, -- :: ByteString -> ByteString -> Bool +-- isSuffixOf, -- :: ByteString -> ByteString -> Bool + + -- * Searching ByteStrings + + -- ** Searching by equality + elem, -- :: Char -> ByteString -> Bool + notElem, -- :: Char -> ByteString -> Bool + + -- ** Searching with a predicate + find, -- :: (Char -> Bool) -> ByteString -> Maybe Char + filter, -- :: (Char -> Bool) -> ByteString -> ByteString +-- partition -- :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) + + -- * Indexing ByteStrings + index, -- :: ByteString -> Int64 -> Char + elemIndex, -- :: Char -> ByteString -> Maybe Int64 + elemIndices, -- :: Char -> ByteString -> [Int64] + findIndex, -- :: (Char -> Bool) -> ByteString -> Maybe Int64 + findIndices, -- :: (Char -> Bool) -> ByteString -> [Int64] + count, -- :: Char -> ByteString -> Int64 + + -- * Zipping and unzipping ByteStrings + zip, -- :: ByteString -> ByteString -> [(Char,Char)] + zipWith, -- :: (Char -> Char -> c) -> ByteString -> ByteString -> [c] +-- unzip, -- :: [(Char,Char)] -> (ByteString,ByteString) + + -- * Ordered ByteStrings +-- sort, -- :: ByteString -> ByteString + + -- * Low level conversions + -- ** Copying ByteStrings + copy, -- :: ByteString -> ByteString + + -- * Reading from ByteStrings + readInt, + readInteger, + + -- * I\/O with 'ByteString's + + -- ** Standard input and output + getContents, -- :: IO ByteString + putStr, -- :: ByteString -> IO () + putStrLn, -- :: ByteString -> IO () + interact, -- :: (ByteString -> ByteString) -> IO () + + -- ** Files + readFile, -- :: FilePath -> IO ByteString + writeFile, -- :: FilePath -> ByteString -> IO () + appendFile, -- :: FilePath -> ByteString -> IO () + + -- ** I\/O with Handles + hGetContents, -- :: Handle -> IO ByteString + hGet, -- :: Handle -> Int64 -> IO ByteString + hGetNonBlocking, -- :: Handle -> Int64 -> IO ByteString + hPut, -- :: Handle -> ByteString -> IO () + +-- hGetN, -- :: Int -> Handle -> Int64 -> IO ByteString +-- hGetContentsN, -- :: Int -> Handle -> IO ByteString +-- hGetNonBlockingN, -- :: Int -> Handle -> IO ByteString + + -- undocumented deprecated things: + join -- :: ByteString -> [ByteString] -> ByteString + + ) where + +-- Functions transparently exported +import Data.ByteString.Lazy + (ByteString, fromChunks, toChunks + ,empty,null,length,tail,init,append,reverse,transpose,cycle + ,concat,take,drop,splitAt,intercalate,isPrefixOf,group,inits,tails,copy + ,hGetContents, hGet, hPut, getContents + ,hGetNonBlocking + ,putStr, putStrLn, interact) + +-- Functions we need to wrap. +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Unsafe as B +import Data.ByteString.Lazy.Internal + +import Data.ByteString.Internal (w2c, c2w, isSpaceWord8) + +import Data.Int (Int64) +import qualified Data.List as List + +import Prelude hiding + (reverse,head,tail,last,init,null,length,map,lines,foldl,foldr,unlines + ,concat,any,take,drop,splitAt,takeWhile,dropWhile,span,break,elem,filter + ,unwords,words,maximum,minimum,all,concatMap,scanl,scanl1,foldl1,foldr1 + ,readFile,writeFile,appendFile,replicate,getContents,getLine,putStr,putStrLn + ,zip,zipWith,unzip,notElem,repeat,iterate,interact,cycle) + +import System.IO (hClose,openFile,IOMode(..)) +#ifndef __NHC__ +import Control.Exception (bracket) +#else +import IO (bracket) +#endif + +#define STRICT1(f) f a | a `seq` False = undefined +#define STRICT2(f) f a b | a `seq` b `seq` False = undefined +#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined +#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined +#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined + +------------------------------------------------------------------------ + +-- | /O(1)/ Convert a 'Char' into a 'ByteString' +singleton :: Char -> ByteString +singleton = L.singleton . c2w +{-# INLINE singleton #-} + +-- | /O(n)/ Convert a 'String' into a 'ByteString'. +pack :: [Char] -> ByteString +pack = L.pack. List.map c2w + +-- | /O(n)/ Converts a 'ByteString' to a 'String'. +unpack :: ByteString -> [Char] +unpack = List.map w2c . L.unpack +{-# INLINE unpack #-} + +-- | /O(1)/ 'cons' is analogous to '(:)' for lists. +cons :: Char -> ByteString -> ByteString +cons = L.cons . c2w +{-# INLINE cons #-} + +-- | /O(1)/ Unlike 'cons', 'cons\'' is +-- strict in the ByteString that we are consing onto. More precisely, it forces +-- the head and the first chunk. It does this because, for space efficiency, it +-- may coalesce the new byte onto the first \'chunk\' rather than starting a +-- new \'chunk\'. +-- +-- So that means you can't use a lazy recursive contruction like this: +-- +-- > let xs = cons\' c xs in xs +-- +-- You can however use 'cons', as well as 'repeat' and 'cycle', to build +-- infinite lazy ByteStrings. +-- +cons' :: Char -> ByteString -> ByteString +cons' = L.cons' . c2w +{-# INLINE cons' #-} + +-- | /O(n)/ Append a Char to the end of a 'ByteString'. Similar to +-- 'cons', this function performs a memcpy. +snoc :: ByteString -> Char -> ByteString +snoc p = L.snoc p . c2w +{-# INLINE snoc #-} + +-- | /O(1)/ Extract the first element of a ByteString, which must be non-empty. +head :: ByteString -> Char +head = w2c . L.head +{-# INLINE head #-} + +-- | /O(1)/ Extract the head and tail of a ByteString, returning Nothing +-- if it is empty. +uncons :: ByteString -> Maybe (Char, ByteString) +uncons bs = case L.uncons bs of + Nothing -> Nothing + Just (w, bs') -> Just (w2c w, bs') +{-# INLINE uncons #-} + +-- | /O(1)/ Extract the last element of a packed string, which must be non-empty. +last :: ByteString -> Char +last = w2c . L.last +{-# INLINE last #-} + +-- | /O(n)/ 'map' @f xs@ is the ByteString obtained by applying @f@ to each element of @xs@ +map :: (Char -> Char) -> ByteString -> ByteString +map f = L.map (c2w . f . w2c) +{-# INLINE map #-} + +-- | /O(n)/ The 'intersperse' function takes a Char and a 'ByteString' +-- and \`intersperses\' that Char between the elements of the +-- 'ByteString'. It is analogous to the intersperse function on Lists. +intersperse :: Char -> ByteString -> ByteString +intersperse = L.intersperse . c2w +{-# INLINE intersperse #-} + +join :: ByteString -> [ByteString] -> ByteString +join = intercalate +{-# DEPRECATED join "use intercalate" #-} + +-- | 'foldl', applied to a binary operator, a starting value (typically +-- the left-identity of the operator), and a ByteString, reduces the +-- ByteString using the binary operator, from left to right. +foldl :: (a -> Char -> a) -> a -> ByteString -> a +foldl f = L.foldl (\a c -> f a (w2c c)) +{-# INLINE foldl #-} + +-- | 'foldl\'' is like foldl, but strict in the accumulator. +foldl' :: (a -> Char -> a) -> a -> ByteString -> a +foldl' f = L.foldl' (\a c -> f a (w2c c)) +{-# INLINE foldl' #-} + +-- | 'foldr', applied to a binary operator, a starting value +-- (typically the right-identity of the operator), and a packed string, +-- reduces the packed string using the binary operator, from right to left. +foldr :: (Char -> a -> a) -> a -> ByteString -> a +foldr f = L.foldr (\c a -> f (w2c c) a) +{-# INLINE foldr #-} + +-- | 'foldl1' is a variant of 'foldl' that has no starting value +-- argument, and thus must be applied to non-empty 'ByteStrings'. +foldl1 :: (Char -> Char -> Char) -> ByteString -> Char +foldl1 f ps = w2c (L.foldl1 (\x y -> c2w (f (w2c x) (w2c y))) ps) +{-# INLINE foldl1 #-} + +-- | 'foldl1\'' is like 'foldl1', but strict in the accumulator. +foldl1' :: (Char -> Char -> Char) -> ByteString -> Char +foldl1' f ps = w2c (L.foldl1' (\x y -> c2w (f (w2c x) (w2c y))) ps) + +-- | 'foldr1' is a variant of 'foldr' that has no starting value argument, +-- and thus must be applied to non-empty 'ByteString's +foldr1 :: (Char -> Char -> Char) -> ByteString -> Char +foldr1 f ps = w2c (L.foldr1 (\x y -> c2w (f (w2c x) (w2c y))) ps) +{-# INLINE foldr1 #-} + +-- | Map a function over a 'ByteString' and concatenate the results +concatMap :: (Char -> ByteString) -> ByteString -> ByteString +concatMap f = L.concatMap (f . w2c) +{-# INLINE concatMap #-} + +-- | Applied to a predicate and a ByteString, 'any' determines if +-- any element of the 'ByteString' satisfies the predicate. +any :: (Char -> Bool) -> ByteString -> Bool +any f = L.any (f . w2c) +{-# INLINE any #-} + +-- | Applied to a predicate and a 'ByteString', 'all' determines if +-- all elements of the 'ByteString' satisfy the predicate. +all :: (Char -> Bool) -> ByteString -> Bool +all f = L.all (f . w2c) +{-# INLINE all #-} + +-- | 'maximum' returns the maximum value from a 'ByteString' +maximum :: ByteString -> Char +maximum = w2c . L.maximum +{-# INLINE maximum #-} + +-- | 'minimum' returns the minimum value from a 'ByteString' +minimum :: ByteString -> Char +minimum = w2c . L.minimum +{-# INLINE minimum #-} + +-- --------------------------------------------------------------------- +-- Building ByteStrings + +-- | 'scanl' is similar to 'foldl', but returns a list of successive +-- reduced values from the left. This function will fuse. +-- +-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +-- +-- Note that +-- +-- > last (scanl f z xs) == foldl f z xs. +scanl :: (Char -> Char -> Char) -> Char -> ByteString -> ByteString +scanl f z = L.scanl (\a b -> c2w (f (w2c a) (w2c b))) (c2w z) + +-- | The 'mapAccumL' function behaves like a combination of 'map' and +-- 'foldl'; it applies a function to each element of a ByteString, +-- passing an accumulating parameter from left to right, and returning a +-- final value of this accumulator together with the new ByteString. +mapAccumL :: (acc -> Char -> (acc, Char)) -> acc -> ByteString -> (acc, ByteString) +mapAccumL f = L.mapAccumL (\a w -> case f a (w2c w) of (a',c) -> (a', c2w c)) + +-- | /O(n)/ map Char functions, provided with the index at each position +mapIndexed :: (Int -> Char -> Char) -> ByteString -> ByteString +mapIndexed f = L.mapIndexed (\i w -> c2w (f i (w2c w))) + +------------------------------------------------------------------------ +-- Generating and unfolding ByteStrings + +-- | @'iterate' f x@ returns an infinite ByteString of repeated applications +-- of @f@ to @x@: +-- +-- > iterate f x == [x, f x, f (f x), ...] +-- +iterate :: (Char -> Char) -> Char -> ByteString +iterate f = L.iterate (c2w . f . w2c) . c2w + +-- | @'repeat' x@ is an infinite ByteString, with @x@ the value of every +-- element. +-- +repeat :: Char -> ByteString +repeat = L.repeat . c2w + +-- | /O(n)/ @'replicate' n x@ is a ByteString of length @n@ with @x@ +-- the value of every element. +-- +replicate :: Int64 -> Char -> ByteString +replicate w c = L.replicate w (c2w c) + +-- | /O(n)/ The 'unfoldr' function is analogous to the List \'unfoldr\'. +-- 'unfoldr' builds a ByteString from a seed value. The function takes +-- the element and returns 'Nothing' if it is done producing the +-- ByteString or returns 'Just' @(a,b)@, in which case, @a@ is a +-- prepending to the ByteString and @b@ is used as the next element in a +-- recursive call. +unfoldr :: (a -> Maybe (Char, a)) -> a -> ByteString +unfoldr f = L.unfoldr $ \a -> case f a of + Nothing -> Nothing + Just (c, a') -> Just (c2w c, a') + +------------------------------------------------------------------------ + +-- | 'takeWhile', applied to a predicate @p@ and a ByteString @xs@, +-- returns the longest prefix (possibly empty) of @xs@ of elements that +-- satisfy @p@. +takeWhile :: (Char -> Bool) -> ByteString -> ByteString +takeWhile f = L.takeWhile (f . w2c) +{-# INLINE takeWhile #-} + +-- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@. +dropWhile :: (Char -> Bool) -> ByteString -> ByteString +dropWhile f = L.dropWhile (f . w2c) +{-# INLINE dropWhile #-} + +-- | 'break' @p@ is equivalent to @'span' ('not' . p)@. +break :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) +break f = L.break (f . w2c) +{-# INLINE break #-} + +-- | 'span' @p xs@ breaks the ByteString into two segments. It is +-- equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@ +span :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) +span f = L.span (f . w2c) +{-# INLINE span #-} + +{- +-- | 'breakChar' breaks its ByteString argument at the first occurence +-- of the specified Char. It is more efficient than 'break' as it is +-- implemented with @memchr(3)@. I.e. +-- +-- > break (=='c') "abcd" == breakChar 'c' "abcd" +-- +breakChar :: Char -> ByteString -> (ByteString, ByteString) +breakChar = L.breakByte . c2w +{-# INLINE breakChar #-} + +-- | 'spanChar' breaks its ByteString argument at the first +-- occurence of a Char other than its argument. It is more efficient +-- than 'span (==)' +-- +-- > span (=='c') "abcd" == spanByte 'c' "abcd" +-- +spanChar :: Char -> ByteString -> (ByteString, ByteString) +spanChar = L.spanByte . c2w +{-# INLINE spanChar #-} +-} + +-- +-- TODO, more rules for breakChar* +-- + +-- | /O(n)/ Break a 'ByteString' into pieces separated by the byte +-- argument, consuming the delimiter. I.e. +-- +-- > split '\n' "a\nb\nd\ne" == ["a","b","d","e"] +-- > split 'a' "aXaXaXa" == ["","X","X","X"] +-- > split 'x' "x" == ["",""] +-- +-- and +-- +-- > intercalate [c] . split c == id +-- > split == splitWith . (==) +-- +-- As for all splitting functions in this library, this function does +-- not copy the substrings, it just constructs new 'ByteStrings' that +-- are slices of the original. +-- +split :: Char -> ByteString -> [ByteString] +split = L.split . c2w +{-# INLINE split #-} + +-- | /O(n)/ Splits a 'ByteString' into components delimited by +-- separators, where the predicate returns True for a separator element. +-- The resulting components do not contain the separators. Two adjacent +-- separators result in an empty component in the output. eg. +-- +-- > splitWith (=='a') "aabbaca" == ["","","bb","c",""] +-- +splitWith :: (Char -> Bool) -> ByteString -> [ByteString] +splitWith f = L.splitWith (f . w2c) +{-# INLINE splitWith #-} + +-- | The 'groupBy' function is the non-overloaded version of 'group'. +groupBy :: (Char -> Char -> Bool) -> ByteString -> [ByteString] +groupBy k = L.groupBy (\a b -> k (w2c a) (w2c b)) + +-- | /O(1)/ 'ByteString' index (subscript) operator, starting from 0. +index :: ByteString -> Int64 -> Char +index = (w2c .) . L.index +{-# INLINE index #-} + +-- | /O(n)/ The 'elemIndex' function returns the index of the first +-- element in the given 'ByteString' which is equal (by memchr) to the +-- query element, or 'Nothing' if there is no such element. +elemIndex :: Char -> ByteString -> Maybe Int64 +elemIndex = L.elemIndex . c2w +{-# INLINE elemIndex #-} + +-- | /O(n)/ The 'elemIndices' function extends 'elemIndex', by returning +-- the indices of all elements equal to the query element, in ascending order. +elemIndices :: Char -> ByteString -> [Int64] +elemIndices = L.elemIndices . c2w +{-# INLINE elemIndices #-} + +-- | The 'findIndex' function takes a predicate and a 'ByteString' and +-- returns the index of the first element in the ByteString satisfying the predicate. +findIndex :: (Char -> Bool) -> ByteString -> Maybe Int64 +findIndex f = L.findIndex (f . w2c) +{-# INLINE findIndex #-} + +-- | The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending order. +findIndices :: (Char -> Bool) -> ByteString -> [Int64] +findIndices f = L.findIndices (f . w2c) + +-- | count returns the number of times its argument appears in the ByteString +-- +-- > count == length . elemIndices +-- > count '\n' == length . lines +-- +-- But more efficiently than using length on the intermediate list. +count :: Char -> ByteString -> Int64 +count c = L.count (c2w c) + +-- | /O(n)/ 'elem' is the 'ByteString' membership predicate. This +-- implementation uses @memchr(3)@. +elem :: Char -> ByteString -> Bool +elem c = L.elem (c2w c) +{-# INLINE elem #-} + +-- | /O(n)/ 'notElem' is the inverse of 'elem' +notElem :: Char -> ByteString -> Bool +notElem c = L.notElem (c2w c) +{-# INLINE notElem #-} + +-- | /O(n)/ 'filter', applied to a predicate and a ByteString, +-- returns a ByteString containing those characters that satisfy the +-- predicate. +filter :: (Char -> Bool) -> ByteString -> ByteString +filter f = L.filter (f . w2c) +{-# INLINE filter #-} + +-- | /O(n)/ The 'find' function takes a predicate and a ByteString, +-- and returns the first element in matching the predicate, or 'Nothing' +-- if there is no such element. +find :: (Char -> Bool) -> ByteString -> Maybe Char +find f ps = w2c `fmap` L.find (f . w2c) ps +{-# INLINE find #-} + +{- +-- | /O(n)/ A first order equivalent of /filter . (==)/, for the common +-- case of filtering a single Char. It is more efficient to use +-- filterChar in this case. +-- +-- > filterChar == filter . (==) +-- +-- filterChar is around 10x faster, and uses much less space, than its +-- filter equivalent +-- +filterChar :: Char -> ByteString -> ByteString +filterChar c = L.filterByte (c2w c) +{-# INLINE filterChar #-} + +-- | /O(n)/ A first order equivalent of /filter . (\/=)/, for the common +-- case of filtering a single Char out of a list. It is more efficient +-- to use /filterNotChar/ in this case. +-- +-- > filterNotChar == filter . (/=) +-- +-- filterNotChar is around 3x faster, and uses much less space, than its +-- filter equivalent +-- +filterNotChar :: Char -> ByteString -> ByteString +filterNotChar c = L.filterNotByte (c2w c) +{-# INLINE filterNotChar #-} +-} + +-- | /O(n)/ 'zip' takes two ByteStrings and returns a list of +-- corresponding pairs of Chars. If one input ByteString is short, +-- excess elements of the longer ByteString are discarded. This is +-- equivalent to a pair of 'unpack' operations, and so space +-- usage may be large for multi-megabyte ByteStrings +zip :: ByteString -> ByteString -> [(Char,Char)] +zip ps qs + | L.null ps || L.null qs = [] + | otherwise = (head ps, head qs) : zip (L.tail ps) (L.tail qs) + +-- | 'zipWith' generalises 'zip' by zipping with the function given as +-- the first argument, instead of a tupling function. For example, +-- @'zipWith' (+)@ is applied to two ByteStrings to produce the list +-- of corresponding sums. +zipWith :: (Char -> Char -> a) -> ByteString -> ByteString -> [a] +zipWith f = L.zipWith ((. w2c) . f . w2c) + +-- | 'lines' breaks a ByteString up into a list of ByteStrings at +-- newline Chars. The resulting strings do not contain newlines. +-- +lines :: ByteString -> [ByteString] +lines Empty = [] +lines (Chunk c0 cs0) = loop0 c0 cs0 + where + -- this is a really performance sensitive function but the + -- chunked representation makes the general case a bit expensive + -- however assuming a large chunk size and normalish line lengths + -- we will find line endings much more frequently than chunk + -- endings so it makes sense to optimise for that common case. + -- So we partition into two special cases depending on whether we + -- are keeping back a list of chunks that will eventually be output + -- once we get to the end of the current line. + + -- the common special case where we have no existing chunks of + -- the current line + loop0 :: B.ByteString -> ByteString -> [ByteString] + STRICT2(loop0) + loop0 c cs = + case B.elemIndex (c2w '\n') c of + Nothing -> case cs of + Empty | B.null c -> [] + | otherwise -> Chunk c Empty : [] + (Chunk c' cs') + | B.null c -> loop0 c' cs' + | otherwise -> loop c' [c] cs' + + Just n | n /= 0 -> Chunk (B.unsafeTake n c) Empty + : loop0 (B.unsafeDrop (n+1) c) cs + | otherwise -> Empty + : loop0 (B.unsafeTail c) cs + + -- the general case when we are building a list of chunks that are + -- part of the same line + loop :: B.ByteString -> [B.ByteString] -> ByteString -> [ByteString] + STRICT3(loop) + loop c line cs = + case B.elemIndex (c2w '\n') c of + Nothing -> + case cs of + Empty -> let c' = revChunks (c : line) + in c' `seq` (c' : []) + + (Chunk c' cs') -> loop c' (c : line) cs' + + Just n -> + let c' = revChunks (B.unsafeTake n c : line) + in c' `seq` (c' : loop0 (B.unsafeDrop (n+1) c) cs) + +-- | 'unlines' is an inverse operation to 'lines'. It joins lines, +-- after appending a terminating newline to each. +unlines :: [ByteString] -> ByteString +unlines [] = empty +unlines ss = (concat $ List.intersperse nl ss) `append` nl -- half as much space + where nl = singleton '\n' + +-- | 'words' breaks a ByteString up into a list of words, which +-- were delimited by Chars representing white space. And +-- +-- > tokens isSpace = words +-- +words :: ByteString -> [ByteString] +words = List.filter (not . L.null) . L.splitWith isSpaceWord8 +{-# INLINE words #-} + +-- | The 'unwords' function is analogous to the 'unlines' function, on words. +unwords :: [ByteString] -> ByteString +unwords = intercalate (singleton ' ') +{-# INLINE unwords #-} + +-- | readInt reads an Int from the beginning of the ByteString. If +-- there is no integer at the beginning of the string, it returns +-- Nothing, otherwise it just returns the int read, and the rest of the +-- string. +readInt :: ByteString -> Maybe (Int, ByteString) +readInt Empty = Nothing +readInt (Chunk x xs) = + case w2c (B.unsafeHead x) of + '-' -> loop True 0 0 (B.unsafeTail x) xs + '+' -> loop False 0 0 (B.unsafeTail x) xs + _ -> loop False 0 0 x xs + + where loop :: Bool -> Int -> Int -> B.ByteString -> ByteString -> Maybe (Int, ByteString) + STRICT5(loop) + loop neg i n c cs + | B.null c = case cs of + Empty -> end neg i n c cs + (Chunk c' cs') -> loop neg i n c' cs' + | otherwise = + case B.unsafeHead c of + w | w >= 0x30 + && w <= 0x39 -> loop neg (i+1) + (n * 10 + (fromIntegral w - 0x30)) + (B.unsafeTail c) cs + | otherwise -> end neg i n c cs + + end _ 0 _ _ _ = Nothing + end neg _ n c cs = let n' | neg = negate n + | otherwise = n + c' = chunk c cs + in n' `seq` c' `seq` Just $! (n', c') + + +-- | readInteger reads an Integer from the beginning of the ByteString. If +-- there is no integer at the beginning of the string, it returns Nothing, +-- otherwise it just returns the int read, and the rest of the string. +readInteger :: ByteString -> Maybe (Integer, ByteString) +readInteger Empty = Nothing +readInteger (Chunk c0 cs0) = + case w2c (B.unsafeHead c0) of + '-' -> first (B.unsafeTail c0) cs0 >>= \(n, cs') -> return (-n, cs') + '+' -> first (B.unsafeTail c0) cs0 + _ -> first c0 cs0 + + where first c cs + | B.null c = case cs of + Empty -> Nothing + (Chunk c' cs') -> first' c' cs' + | otherwise = first' c cs + + first' c cs = case B.unsafeHead c of + w | w >= 0x30 && w <= 0x39 -> Just $ + loop 1 (fromIntegral w - 0x30) [] (B.unsafeTail c) cs + | otherwise -> Nothing + + loop :: Int -> Int -> [Integer] + -> B.ByteString -> ByteString -> (Integer, ByteString) + STRICT5(loop) + loop d acc ns c cs + | B.null c = case cs of + Empty -> combine d acc ns c cs + (Chunk c' cs') -> loop d acc ns c' cs' + | otherwise = + case B.unsafeHead c of + w | w >= 0x30 && w <= 0x39 -> + if d < 9 then loop (d+1) + (10*acc + (fromIntegral w - 0x30)) + ns (B.unsafeTail c) cs + else loop 1 (fromIntegral w - 0x30) + (fromIntegral acc : ns) + (B.unsafeTail c) cs + | otherwise -> combine d acc ns c cs + + combine _ acc [] c cs = end (fromIntegral acc) c cs + combine d acc ns c cs = + end (10^d * combine1 1000000000 ns + fromIntegral acc) c cs + + combine1 _ [n] = n + combine1 b ns = combine1 (b*b) $ combine2 b ns + + combine2 b (n:m:ns) = let t = n+m*b in t `seq` (t : combine2 b ns) + combine2 _ ns = ns + + end n c cs = let c' = chunk c cs + in c' `seq` (n, c') + +-- | Read an entire file /lazily/ into a 'ByteString'. Use 'text mode' +-- on Windows to interpret newlines +readFile :: FilePath -> IO ByteString +readFile f = openFile f ReadMode >>= hGetContents + +-- | Write a 'ByteString' to a file. +writeFile :: FilePath -> ByteString -> IO () +writeFile f txt = bracket (openFile f WriteMode) hClose + (\hdl -> hPut hdl txt) + +-- | Append a 'ByteString' to a file. +appendFile :: FilePath -> ByteString -> IO () +appendFile f txt = bracket (openFile f AppendMode) hClose + (\hdl -> hPut hdl txt) + + +-- --------------------------------------------------------------------- +-- Internal utilities + +-- reverse a list of possibly-empty chunks into a lazy ByteString +revChunks :: [B.ByteString] -> ByteString +revChunks cs = List.foldl' (flip chunk) Empty cs diff --git a/Data/ByteString/Lazy/Internal.hs b/Data/ByteString/Lazy/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/Internal.hs @@ -0,0 +1,121 @@ +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +-- | +-- Module : Data.ByteString.Lazy.Internal +-- License : BSD-style +-- Maintainer : dons@cse.unsw.edu.au, duncan@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- A module containing semi-public 'ByteString' internals. This exposes +-- the 'ByteString' representation and low level construction functions. +-- Modules which extend the 'ByteString' system will need to use this module +-- while ideally most users will be able to make do with the public interface +-- modules. +-- +module Data.ByteString.Lazy.Internal ( + + -- * The lazy @ByteString@ type and representation + ByteString(..), -- instances: Eq, Ord, Show, Read, Data, Typeable + chunk, + foldrChunks, + foldlChunks, + + -- * Data type invariant and abstraction function + invariant, + checkInvariant, + + -- * Chunk allocation sizes + defaultChunkSize, + smallChunkSize, + chunkOverhead + + ) where + +import qualified Data.ByteString.Internal as S + +import Foreign.Storable (sizeOf) + +#if defined(__GLASGOW_HASKELL__) +import Data.Generics (Data(..), Typeable(..)) +#endif + +-- | A space-efficient representation of a Word8 vector, supporting many +-- efficient operations. A 'ByteString' contains 8-bit characters only. +-- +-- Instances of Eq, Ord, Read, Show, Data, Typeable +-- +data ByteString = Empty | Chunk {-# UNPACK #-} !S.ByteString ByteString + deriving (Show, Read +#if defined(__GLASGOW_HASKELL__) + ,Data, Typeable +#endif + ) + +------------------------------------------------------------------------ + +-- | The data type invariant: +-- Every ByteString is either 'Empty' or consists of non-null 'S.ByteString's. +-- All functions must preserve this, and the QC properties must check this. +-- +invariant :: ByteString -> Bool +invariant Empty = True +invariant (Chunk (S.PS _ _ len) cs) = len > 0 && invariant cs + +-- | In a form that checks the invariant lazily. +checkInvariant :: ByteString -> ByteString +checkInvariant Empty = Empty +checkInvariant (Chunk c@(S.PS _ _ len) cs) + | len > 0 = Chunk c (checkInvariant cs) + | otherwise = error $ "Data.ByteString.Lazy: invariant violation:" + ++ show (Chunk c cs) + +------------------------------------------------------------------------ + +-- | Smart constructor for 'Chunk'. Guarantees the data type invariant. +chunk :: S.ByteString -> ByteString -> ByteString +chunk c@(S.PS _ _ len) cs | len == 0 = cs + | otherwise = Chunk c cs +{-# INLINE chunk #-} + +-- | Consume the chunks of a lazy ByteString with a natural right fold. +foldrChunks :: (S.ByteString -> a -> a) -> a -> ByteString -> a +foldrChunks f z = go + where go Empty = z + go (Chunk c cs) = f c (go cs) +{-# INLINE foldrChunks #-} + +-- | Consume the chunks of a lazy ByteString with a strict, tail-recursive, +-- accumulating left fold. +foldlChunks :: (a -> S.ByteString -> a) -> a -> ByteString -> a +foldlChunks f z = go z + where go a _ | a `seq` False = undefined + go a Empty = a + go a (Chunk c cs) = go (f a c) cs +{-# INLINE foldlChunks #-} + +------------------------------------------------------------------------ + +-- The representation uses lists of packed chunks. When we have to convert from +-- a lazy list to the chunked representation, then by default we use this +-- chunk size. Some functions give you more control over the chunk size. +-- +-- Measurements here: +-- http://www.cse.unsw.edu.au/~dons/tmp/chunksize_v_cache.png +-- +-- indicate that a value around 0.5 to 1 x your L2 cache is best. +-- The following value assumes people have something greater than 128k, +-- and need to share the cache with other programs. + +-- | Currently set to 32k, less the memory management overhead +defaultChunkSize :: Int +defaultChunkSize = 32 * k - chunkOverhead + where k = 1024 + +-- | Currently set to 4k, less the memory management overhead +smallChunkSize :: Int +smallChunkSize = 4 * k - chunkOverhead + where k = 1024 + +-- | The memory management overhead. Currently this is tuned for GHC only. +chunkOverhead :: Int +chunkOverhead = 2 * sizeOf (undefined :: Int) diff --git a/Data/ByteString/Unsafe.hs b/Data/ByteString/Unsafe.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Unsafe.hs @@ -0,0 +1,297 @@ +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +-- | +-- Module : Data.ByteString.Unsafe +-- License : BSD-style +-- Maintainer : dons@cse.unsw.edu.au, duncan@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- A module containing unsafe 'ByteString' operations. This exposes +-- the 'ByteString' representation and low level construction functions. +-- Modules which extend the 'ByteString' system will need to use this module +-- while ideally most users will be able to make do with the public interface +-- modules. +-- +module Data.ByteString.Unsafe ( + + -- * Unchecked access + unsafeHead, -- :: ByteString -> Word8 + unsafeTail, -- :: ByteString -> ByteString + unsafeIndex, -- :: ByteString -> Int -> Word8 + unsafeTake, -- :: Int -> ByteString -> ByteString + unsafeDrop, -- :: Int -> ByteString -> ByteString + + -- * Low level interaction with CStrings + -- ** Using ByteStrings with functions for CStrings + unsafeUseAsCString, -- :: ByteString -> (CString -> IO a) -> IO a + unsafeUseAsCStringLen, -- :: ByteString -> (CStringLen -> IO a) -> IO a + + -- ** Converting CStrings to ByteStrings + unsafePackCString, -- :: CString -> IO ByteString + unsafePackCStringLen, -- :: CStringLen -> IO ByteString + unsafePackMallocCString,-- :: CString -> IO ByteString + +#if defined(__GLASGOW_HASKELL__) + unsafePackAddress, -- :: Addr# -> IO ByteString + unsafePackAddressLen, -- :: Int -> Addr# -> IO ByteString + unsafePackCStringFinalizer, -- :: Ptr Word8 -> Int -> IO () -> IO ByteString + unsafeFinalize, -- :: ByteString -> IO () +#endif + + ) where + +import Data.ByteString.Internal + +import Foreign.ForeignPtr (newForeignPtr_, newForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr, plusPtr, castPtr) + +import Foreign.Storable (Storable(..)) +import Foreign.C.String (CString, CStringLen) + +#ifndef __NHC__ +import Control.Exception (assert) +#endif + +import Data.Word (Word8) + +#if defined(__GLASGOW_HASKELL__) +import qualified Foreign.ForeignPtr as FC (finalizeForeignPtr) +import qualified Foreign.Concurrent as FC (newForeignPtr) + +--import Data.Generics (Data(..), Typeable(..)) + +import GHC.Prim (Addr#) +import GHC.Ptr (Ptr(..)) +#endif + +-- An alternative to Control.Exception (assert) for nhc98 +#ifdef __NHC__ +#define assert assertS "__FILE__ : __LINE__" +assertS :: String -> Bool -> a -> a +assertS _ True = id +assertS s False = error ("assertion failed at "++s) +#endif + +-- ----------------------------------------------------------------------------- +-- +-- Useful macros, until we have bang patterns +-- + +#define STRICT1(f) f a | a `seq` False = undefined +#define STRICT2(f) f a b | a `seq` b `seq` False = undefined +#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined +#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined +#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined + +-- --------------------------------------------------------------------- +-- +-- Extensions to the basic interface +-- + +-- | A variety of 'head' for non-empty ByteStrings. 'unsafeHead' omits the +-- check for the empty case, so there is an obligation on the programmer +-- to provide a proof that the ByteString is non-empty. +unsafeHead :: ByteString -> Word8 +unsafeHead (PS x s l) = assert (l > 0) $ + inlinePerformIO $ withForeignPtr x $ \p -> peekByteOff p s +{-# INLINE unsafeHead #-} + +-- | A variety of 'tail' for non-empty ByteStrings. 'unsafeTail' omits the +-- check for the empty case. As with 'unsafeHead', the programmer must +-- provide a separate proof that the ByteString is non-empty. +unsafeTail :: ByteString -> ByteString +unsafeTail (PS ps s l) = assert (l > 0) $ PS ps (s+1) (l-1) +{-# INLINE unsafeTail #-} + +-- | Unsafe 'ByteString' index (subscript) operator, starting from 0, returning a 'Word8' +-- This omits the bounds check, which means there is an accompanying +-- obligation on the programmer to ensure the bounds are checked in some +-- other way. +unsafeIndex :: ByteString -> Int -> Word8 +unsafeIndex (PS x s l) i = assert (i >= 0 && i < l) $ + inlinePerformIO $ withForeignPtr x $ \p -> peekByteOff p (s+i) +{-# INLINE unsafeIndex #-} + +-- | A variety of 'take' which omits the checks on @n@ so there is an +-- obligation on the programmer to provide a proof that @0 <= n <= 'length' xs@. +unsafeTake :: Int -> ByteString -> ByteString +unsafeTake n (PS x s l) = assert (0 <= n && n <= l) $ PS x s n +{-# INLINE unsafeTake #-} + +-- | A variety of 'drop' which omits the checks on @n@ so there is an +-- obligation on the programmer to provide a proof that @0 <= n <= 'length' xs@. +unsafeDrop :: Int -> ByteString -> ByteString +unsafeDrop n (PS x s l) = assert (0 <= n && n <= l) $ PS x (s+n) (l-n) +{-# INLINE unsafeDrop #-} + + +#if defined(__GLASGOW_HASKELL__) +-- | /O(n)/ Pack a null-terminated sequence of bytes, pointed to by an +-- Addr\# (an arbitrary machine address assumed to point outside the +-- garbage-collected heap) into a @ByteString@. A much faster way to +-- create an Addr\# is with an unboxed string literal, than to pack a +-- boxed string. A unboxed string literal is compiled to a static @char +-- []@ by GHC. Establishing the length of the string requires a call to +-- @strlen(3)@, so the Addr# must point to a null-terminated buffer (as +-- is the case with "string"# literals in GHC). Use 'unsafePackAddress' +-- if you know the length of the string statically. +-- +-- An example: +-- +-- > literalFS = packAddress "literal"# +-- +-- This function is /unsafe/. If you modify the buffer pointed to by the +-- original Addr# this modification will be reflected in the resulting +-- @ByteString@, breaking referential transparency. +-- +unsafePackAddress :: Addr# -> IO ByteString +unsafePackAddress addr# = do + p <- newForeignPtr_ cstr + l <- c_strlen cstr + return $ PS p 0 (fromIntegral l) + where + cstr = Ptr addr# +{-# INLINE unsafePackAddress #-} + +-- | /O(1)/ 'unsafePackAddressLen' provides constant-time construction of +-- 'ByteStrings' which is ideal for string literals. It packs a +-- null-terminated sequence of bytes into a 'ByteString', given a raw +-- 'Addr\#' to the string, and the length of the string. +-- +-- This function is /unsafe/ in two ways: +-- +-- * the length argument is assumed to be correct. If the length +-- argument is incorrect, it is possible to overstep the end of the +-- byte array. +-- +-- * if the underying Addr# is later modified, this change will be +-- reflected in resulting @ByteString@, breaking referential +-- transparency. +-- +-- If in doubt, don't use these functions. +-- +unsafePackAddressLen :: Int -> Addr# -> IO ByteString +unsafePackAddressLen len addr# = do + p <- newForeignPtr_ (Ptr addr#) + return $ PS p 0 len +{-# INLINE unsafePackAddressLen #-} + +-- | /O(1)/ Construct a 'ByteString' given a Ptr Word8 to a buffer, a +-- length, and an IO action representing a finalizer. This function is +-- not available on Hugs. +-- +-- This function is /unsafe/, it is possible to break referential +-- transparency by modifying the underlying buffer pointed to by the +-- first argument. Any changes to the original buffer will be reflected +-- in the resulting @ByteString@. +-- +unsafePackCStringFinalizer :: Ptr Word8 -> Int -> IO () -> IO ByteString +unsafePackCStringFinalizer p l f = do + fp <- FC.newForeignPtr p f + return $ PS fp 0 l + +-- | Explicitly run the finaliser associated with a 'ByteString'. +-- References to this value after finalisation may generate invalid memory +-- references. +-- +-- This function is /unsafe/, as there may be other +-- 'ByteStrings' referring to the same underlying pages. If you use +-- this, you need to have a proof of some kind that all 'ByteString's +-- ever generated from the underlying byte array are no longer live. +-- +unsafeFinalize :: ByteString -> IO () +unsafeFinalize (PS p _ _) = FC.finalizeForeignPtr p + +#endif + +------------------------------------------------------------------------ +-- Packing CStrings into ByteStrings + +-- | /O(n)/ Build a @ByteString@ from a @CString@. This value will have /no/ +-- finalizer associated to it, and will not be garbage collected by +-- Haskell. The ByteString length is calculated using /strlen(3)/, +-- and thus the complexity is a /O(n)/. +-- +-- This function is /unsafe/. If the @CString@ is later modified, this +-- change will be reflected in the resulting @ByteString@, breaking +-- referential transparency. +-- +unsafePackCString :: CString -> IO ByteString +unsafePackCString cstr = do + fp <- newForeignPtr_ (castPtr cstr) + l <- c_strlen cstr + return $! PS fp 0 (fromIntegral l) + +-- | /O(1)/ Build a @ByteString@ from a @CStringLen@. This value will +-- have /no/ finalizer associated with it, and will not be garbage +-- collected by Haskell. This operation has /O(1)/ complexity as we +-- already know the final size, so no /strlen(3)/ is required. +-- +-- This funtion is /unsafe/. If the original @CStringLen@ is later +-- modified, this change will be reflected in the resulting @ByteString@, +-- breaking referential transparency. +-- +unsafePackCStringLen :: CStringLen -> IO ByteString +unsafePackCStringLen (ptr,len) = do + fp <- newForeignPtr_ (castPtr ptr) + return $! PS fp 0 (fromIntegral len) + +-- | /O(n)/ Build a @ByteString@ from a malloced @CString@. This value will +-- have a @free(3)@ finalizer associated to it. +-- +-- This funtion is /unsafe/. If the original @CStringLen@ is later +-- modified, this change will be reflected in the resulting @ByteString@, +-- breaking referential transparency. +-- +-- This function is also unsafe if you call its finalizer twice, +-- which will result in a /double free/ error. +-- +unsafePackMallocCString :: CString -> IO ByteString +unsafePackMallocCString cstr = do + fp <- newForeignPtr c_free_finalizer (castPtr cstr) + len <- c_strlen cstr + return $! PS fp 0 (fromIntegral len) + +-- --------------------------------------------------------------------- + +-- | /O(1) construction/ Use a @ByteString@ with a function requiring a +-- @CString@. +-- +-- This function does zero copying, and merely unwraps a @ByteString@ to +-- appear as a @CString@. It is /unsafe/ in two ways: +-- +-- * After calling this function the @CString@ shares the underlying +-- byte buffer with the original @ByteString@. Thus modifying the +-- @CString@, either in C, or using poke, will cause the contents of the +-- @ByteString@ to change, breaking referential transparency. Other +-- @ByteStrings@ created by sharing (such as those produced via 'take' +-- or 'drop') will also reflect these changes. Modifying the @CString@ +-- will break referential transparency. To avoid this, use +-- @useAsCString@, which makes a copy of the original @ByteString@. +-- +-- * @CStrings@ are often passed to functions that require them to be +-- null-terminated. If the original @ByteString@ wasn't null terminated, +-- neither will the @CString@ be. It is the programmers responsibility +-- to guarantee that the @ByteString@ is indeed null terminated. If in +-- doubt, use @useAsCString@. +-- +unsafeUseAsCString :: ByteString -> (CString -> IO a) -> IO a +unsafeUseAsCString (PS ps s _) ac = withForeignPtr ps $ \p -> ac (castPtr p `plusPtr` s) + +-- | /O(1) construction/ Use a @ByteString@ with a function requiring a +-- @CStringLen@. +-- +-- This function does zero copying, and merely unwraps a @ByteString@ to +-- appear as a @CStringLen@. It is /unsafe/: +-- +-- * After calling this function the @CStringLen@ shares the underlying +-- byte buffer with the original @ByteString@. Thus modifying the +-- @CStringLen@, either in C, or using poke, will cause the contents of the +-- @ByteString@ to change, breaking referential transparency. Other +-- @ByteStrings@ created by sharing (such as those produced via 'take' +-- or 'drop') will also reflect these changes. Modifying the @CStringLen@ +-- will break referential transparency. To avoid this, use +-- @useAsCStringLen@, which makes a copy of the original @ByteString@. +-- +unsafeUseAsCStringLen :: ByteString -> (CStringLen -> IO a) -> IO a +unsafeUseAsCStringLen (PS ps s l) f = withForeignPtr ps $ \p -> f (castPtr p `plusPtr` s,l) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) Don Stewart 2005-2007 + (c) Duncan Coutts 2006-2007 + (c) David Roundy 2003-2005. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/bytestring.cabal b/bytestring.cabal new file mode 100644 --- /dev/null +++ b/bytestring.cabal @@ -0,0 +1,40 @@ +Name: bytestring +Version: 0.9 +Synopsis: Fast, packed, strict and lazy byte arrays with a list interface +License: BSD3 +License-file: LICENSE +Copyright: Copyright (c) Don Stewart 2005-2007, + (c) Duncan Coutts 2006-2007, + (c) David Roundy 2003-2005. +Author: Don Stewart, Duncan Coutts +Maintainer: dons@cse.unsw.edu.au, duncan@haskell.org +Stability: provisional +Homepage: http://www.cse.unsw.edu.au/~dons/fps.html +Tested-With: GHC ==6.6.1, GHC ==6.4.2 +Build-Type: Simple +Cabal-Version: >= 1.2 + +flag split-base + +library + if flag(split-base) + build-depends: base >= 3, array + else + build-depends: base < 3 + extensions: CPP, ForeignFunctionInterface + exposed-modules: Data.ByteString + Data.ByteString.Char8 + Data.ByteString.Unsafe + Data.ByteString.Internal + Data.ByteString.Lazy + Data.ByteString.Lazy.Char8 + Data.ByteString.Lazy.Internal + Data.ByteString.Fusion + ghc-options: -Wall -fglasgow-exts -O2 + if impl(ghc <= 6.4.2) + ghc-options: -DSLOW_FOREIGN_PTR + nhc98-options: -K4M -K3M + c-sources: cbits/fpstring.c + include-dirs: include + includes: fpstring.h + install-includes: fpstring.h diff --git a/cbits/fpstring.c b/cbits/fpstring.c new file mode 100644 --- /dev/null +++ b/cbits/fpstring.c @@ -0,0 +1,82 @@ +/* + * Copyright (c) 2003 David Roundy + * Copyright (c) 2005-6 Don Stewart + * + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. Neither the names of the authors or the names of any contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ + +#include "fpstring.h" + +/* copy a string in reverse */ +void fps_reverse(unsigned char *q, unsigned char *p, unsigned long n) { + p += n-1; + while (n-- != 0) + *q++ = *p--; +} + +/* duplicate a string, interspersing the character through the elements + of the duplicated string */ +void fps_intersperse(unsigned char *q, + unsigned char *p, + unsigned long n, + unsigned char c) { + + while (n > 1) { + *q++ = *p++; + *q++ = c; + n--; + } + if (n == 1) + *q = *p; +} + +/* find maximum char in a packed string */ +unsigned char fps_maximum(unsigned char *p, unsigned long len) { + unsigned char *q, c = *p; + for (q = p; q < p + len; q++) + if (*q > c) + c = *q; + return c; +} + +/* find minimum char in a packed string */ +unsigned char fps_minimum(unsigned char *p, unsigned long len) { + unsigned char *q, c = *p; + for (q = p; q < p + len; q++) + if (*q < c) + c = *q; + return c; +} + +/* count the number of occurences of a char in a string */ +unsigned long fps_count(unsigned char *p, unsigned long len, unsigned char w) { + unsigned long c; + for (c = 0; len-- != 0; ++p) + if (*p == w) + ++c; + return c; +} diff --git a/include/fpstring.h b/include/fpstring.h new file mode 100644 --- /dev/null +++ b/include/fpstring.h @@ -0,0 +1,6 @@ + +void fps_reverse(unsigned char *dest, unsigned char *from, unsigned long len); +void fps_intersperse(unsigned char *dest, unsigned char *from, unsigned long len, unsigned char c); +unsigned char fps_maximum(unsigned char *p, unsigned long len); +unsigned char fps_minimum(unsigned char *p, unsigned long len); +unsigned long fps_count(unsigned char *p, unsigned long len, unsigned char w);