bytestring 0.9.0.4 → 0.9.1.0
raw patch · 20 files changed
+1384/−926 lines, 20 filesdep −arraydep ~base
Dependencies removed: array
Dependency ranges changed: base
Files
- Data/ByteString.hs +188/−98
- Data/ByteString/Char8.hs +52/−36
- Data/ByteString/Fusion.hs +4/−683
- Data/ByteString/Internal.hs +17/−4
- Data/ByteString/Lazy.hs +12/−28
- Data/ByteString/Lazy/Char8.hs +15/−20
- Data/ByteString/Lazy/Internal.hs +2/−1
- Data/ByteString/Unsafe.hs +9/−4
- TODO +0/−2
- bytestring.cabal +25/−17
- tests/Bench.hs +4/−4
- tests/Hash.hs +88/−0
- tests/Makefile +16/−2
- tests/Properties.hs +703/−15
- tests/QuickCheckUtils.hs +67/−9
- tests/Rules.hs +32/−0
- tests/Words.hs +70/−0
- tests/pack.hs +3/−0
- tests/revcomp.hs +5/−3
- tests/test-compare.hs +72/−0
Data/ByteString.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -XMagicHash -XUnboxedTuples #-} -- #prune @@ -7,8 +8,8 @@ -- 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+-- (c) Don Stewart 2005-2008 -- -- Array fusion code: -- (c) 2001,2002 Manuel M T Chakravarty & Gabriele Keller@@ -96,7 +97,6 @@ -- ** 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@@ -128,9 +128,9 @@ isPrefixOf, -- :: ByteString -> ByteString -> Bool isSuffixOf, -- :: ByteString -> ByteString -> Bool isInfixOf, -- :: ByteString -> ByteString -> Bool- isSubstringOf, -- :: ByteString -> ByteString -> Bool -- ** Search for arbitrary substrings+ breakSubstring, -- :: ByteString -> ByteString -> (ByteString,ByteString) findSubstring, -- :: ByteString -> ByteString -> Maybe Int findSubstrings, -- :: ByteString -> ByteString -> [Int] @@ -187,7 +187,6 @@ readFile, -- :: FilePath -> IO ByteString writeFile, -- :: FilePath -> ByteString -> IO () appendFile, -- :: FilePath -> ByteString -> IO ()--- mmapFile, -- :: FilePath -> IO ByteString -- ** I\/O with Handles hGetLine, -- :: Handle -> IO ByteString@@ -198,8 +197,7 @@ hPutStr, -- :: Handle -> ByteString -> IO () hPutStrLn, -- :: Handle -> ByteString -> IO () - -- undocumented deprecated things:- join -- :: ByteString -> [ByteString] -> ByteString+ breakByte ) where @@ -216,14 +214,11 @@ 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 ((!))+import Data.Maybe (isJust, listToMaybe) -- Control.Exception.bracket not available in yhc or nhc #ifndef __NHC__@@ -291,23 +286,17 @@ -- ----------------------------------------------------------------------------- -instance Eq ByteString- where (==) = eq+instance Eq ByteString where+ (==) = eq -instance Ord ByteString- where compare = compareBytes+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')@@ -315,12 +304,12 @@ | p == p' && s == s' = True -- short cut for the same string | otherwise = compareBytes a b == EQ {-# INLINE eq #-}+-- ^ still needed -- | /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@@ -328,32 +317,32 @@ 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 $++-- Pure Haskell version++compareBytes (PS fp1 off1 len1) (PS fp2 off2 len2)+-- | len1 == 0 && len2 == 0 = EQ -- short cut for empty strings+-- | fp1 == fp2 && off1 == off2 && len1 == len2 = EQ -- short cut for the same string+ | otherwise = inlinePerformIO $ withForeignPtr fp1 $ \p1 -> withForeignPtr fp2 $ \p2 -> cmp (p1 `plusPtr` off1) (p2 `plusPtr` off2) 0 len1 len2 +-- XXX todo. 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+ a <- peekByteOff p1 n :: IO Word8+ b <- peekByteOff p2 n case a `compare` b of EQ -> cmp p1 p2 (n+1) len1 len2 LT -> return LT GT -> return GT-{-# INLINE compareBytes #-} -} -- -----------------------------------------------------------------------------@@ -368,8 +357,10 @@ singleton c = unsafeCreate 1 $ \p -> poke p c {-# INLINE [1] singleton #-} +-- Inline [1] for intercalate rule+ ----- XXX The unsafePerformIO is critical!+-- XXX The use of unsafePerformIO in allocating functions (unsafeCreate) is critical! -- -- Otherwise: --@@ -432,6 +423,8 @@ {-# INLINE unpack #-} --+-- Have unpack fuse with good list consumers+-- -- 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@@ -457,7 +450,8 @@ loop (p `plusPtr` off) (len-1) [] {-# RULES- "FPS unpack-list" [1] forall p . unpackFoldr p (:) [] = unpackList p+"ByteString unpack-list" [1] forall p .+ unpackFoldr p (:) [] = unpackList p #-} #endif@@ -578,10 +572,6 @@ | 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]@@ -593,7 +583,9 @@ -- | '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 foldl f v (PS x s l) = inlinePerformIO $ withForeignPtr x $ \ptr -> lgo v (ptr `plusPtr` s) (ptr `plusPtr` (s+l))@@ -605,7 +597,8 @@ {-# INLINE foldl #-} -- | 'foldl\'' is like 'foldl', but strict in the accumulator.--- Though actually foldl is also strict in the accumulator.+-- However, for ByteStrings, all left folds are strict in the accumulator.+-- foldl' :: (a -> Word8 -> a) -> a -> ByteString -> a foldl' = foldl {-# INLINE foldl' #-}@@ -750,11 +743,19 @@ -- 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+mapAccumL f acc (PS fp o len) = inlinePerformIO $ withForeignPtr fp $ \a -> do+ gp <- mallocByteString len+ acc' <- withForeignPtr gp $ \p -> mapAccumL_ acc 0 (a `plusPtr` o) p+ return $! (acc', PS gp 0 len)+ where+ STRICT4(mapAccumL_)+ mapAccumL_ s n p1 p2+ | n >= len = return s+ | otherwise = do+ x <- peekByteOff p1 n+ let (s', y) = f s x+ pokeByteOff p2 n y+ mapAccumL_ s' (n+1) p1 p2 {-# INLINE mapAccumL #-} -- | The 'mapAccumR' function behaves like a combination of 'map' and@@ -762,14 +763,21 @@ -- 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+mapAccumR f acc (PS fp o len) = inlinePerformIO $ withForeignPtr fp $ \a -> do+ gp <- mallocByteString len+ acc' <- withForeignPtr gp $ \p -> mapAccumR_ acc (len-1) (a `plusPtr` o) p+ return $! (acc', PS gp 0 len)+ where+ STRICT4(mapAccumR_)+ mapAccumR_ s n p q+ | n < 0 = return s+ | otherwise = do+ x <- peekByteOff p n+ let (s', y) = f s x+ pokeByteOff q n y+ mapAccumR_ s' (n-1) p q {-# 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 @@ -781,17 +789,27 @@ -- 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 +scanl f v (PS fp s len) = inlinePerformIO $ withForeignPtr fp $ \a ->+ create (len+1) $ \q -> do+ poke q v+ scanl_ v 0 (a `plusPtr` s) (q `plusPtr` 1)+ where+ STRICT4(scanl_)+ scanl_ z n p q+ | n >= len = return ()+ | otherwise = do+ x <- peekByteOff p n+ let z' = f z x+ pokeByteOff q n z'+ scanl_ z' (n+1) p q+{-# INLINE scanl #-}+ -- 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.@@ -805,7 +823,19 @@ -- | 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+scanr f v (PS fp s len) = inlinePerformIO $ withForeignPtr fp $ \a ->+ create (len+1) $ \q -> do+ poke (q `plusPtr` len) v+ scanr_ v (len-1) (a `plusPtr` s) q+ where+ STRICT4(scanr_)+ scanr_ z n p q+ | n < 0 = return ()+ | otherwise = do+ x <- peekByteOff p n+ let z' = f x z+ pokeByteOff q n z'+ scanr_ z' (n-1) p q {-# INLINE scanr #-} -- | 'scanr1' is a variant of 'scanr' that has no starting value argument.@@ -917,19 +947,28 @@ -- instead of findIndexOrEnd, we could use memchr here. -- | 'break' @p@ is equivalent to @'span' ('not' . p)@.+--+-- Under GHC, a rewrite rule will transform break (==) into a+-- call to the specialised breakByte:+--+-- > break ((==) x) = breakByte x+-- > break (==x) = breakByte x+-- break :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString) break p ps = case findIndexOrEnd p ps of n -> (unsafeTake n ps, unsafeDrop n ps) #if __GLASGOW_HASKELL__ {-# INLINE [1] break #-}+#endif {-# RULES-"FPS specialise break (x==)" forall x.+"ByteString specialise break (x==)" forall x. break ((==) x) = breakByte x-"FPS specialise break (==x)" forall x.+"ByteString specialise break (==x)" forall x. break (==x) = breakByte x #-}-#endif +-- INTERNAL:+ -- | '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.@@ -975,9 +1014,9 @@ {-# INLINE spanByte #-} {-# RULES-"FPS specialise span (x==)" forall x.+"ByteString specialise span (x==)" forall x. span ((==) x) = spanByte x-"FPS specialise span (==x)" forall x.+"ByteString specialise span (==x)" forall x. span (==x) = spanByte x #-} @@ -1021,7 +1060,6 @@ -> 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')@@ -1088,7 +1126,6 @@ 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')@@ -1141,12 +1178,8 @@ 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 .+"ByteString specialise intercalate c -> intercalateByte" forall c s1 s2 . intercalate (singleton c) (s1 : s2 : []) = intercalateWithByte c s1 s2 #-} @@ -1315,10 +1348,9 @@ if k w then poke t w >> go (f `plusPtr` 1) (t `plusPtr` 1) end else go (f `plusPtr` 1) t end-#if __GLASGOW_HASKELL__-{-# INLINE [1] filter #-}-#endif+{-# 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@@ -1334,14 +1366,12 @@ {-# INLINE filterByte #-} {-# RULES- "FPS specialise filter (== x)" forall x.- filter ((==) x) = filterByte x- #-}--{-# RULES- "FPS specialise filter (== x)" forall x.- filter (== x) = filterByte x+"ByteString specialise filter (== x)" forall x.+ filter ((==) x) = filterByte x+"ByteString specialise filter (== x)" forall x.+ filter (== x) = filterByte x #-}+-} -- | /O(n)/ The 'find' function takes a predicate and a ByteString, -- and returns the first element in matching the predicate, or 'Nothing'@@ -1407,34 +1437,95 @@ i <- memcmp (p1 `plusPtr` s1) (p2 `plusPtr` s2 `plusPtr` (l2 - l1)) (fromIntegral l1) return $! i == 0 --- | Alias of 'isSubstringOf'+-- | Check whether one string is a substring of another. @isInfixOf+-- p s@ is equivalent to @not (null (findSubstrings p s))@. isInfixOf :: ByteString -> ByteString -> Bool-isInfixOf = isSubstringOf+isInfixOf p s = isJust (findSubstring p s) --- | 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+-- | Break a string on a substring, returning a pair of the part of the+-- string prior to the match, and the rest of the string.+--+-- The following relationships hold:+--+-- > break (== c) l == breakSubstring (singleton c) l+--+-- and:+--+-- > findSubstring s l ==+-- > if null s then Just 0+-- > else case breakSubstring s l of+-- > (x,y) | null y -> Nothing+-- > | otherwise -> Just (length x)+--+-- For example, to tokenise a string, dropping delimiters:+--+-- > tokenise x y = h : if null t then [] else tokenise x (drop (length x) t)+-- > where (h,t) = breakSubstring x y+--+-- To skip to the first occurence of a string:+-- +-- > snd (breakSubstring x y) +--+-- To take the parts of a string before a delimiter:+--+-- > fst (breakSubstring x y) +--+breakSubstring :: ByteString -- ^ String to search for+ -> ByteString -- ^ String to search in+ -> (ByteString,ByteString) -- ^ Head and tail of string broken at substring -{-# DEPRECATED findSubstring "Do not use. The ByteString searching api is about to be replaced." #-}+breakSubstring pat src = search 0 src+ where+ STRICT2(search)+ search n s+ | null s = (src,empty) -- not found+ | pat `isPrefixOf` s = (take n src,s)+ | otherwise = search (n+1) (unsafeTail s)+ -- | 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+findSubstring f i = listToMaybe (findSubstrings f i) -{-# DEPRECATED findSubstrings "Do not use. The ByteString searching api is about to be replaced." #-}+{-# DEPRECATED findSubstring "findSubstring is deprecated in favour of breakSubstring." #-}++{-+findSubstring pat str = search 0 str+ where+ STRICT2(search)+ search n s+ = let x = pat `isPrefixOf` s+ in+ if null s+ then if x then Just n else Nothing+ else if x then Just n+ else search (n+1) (unsafeTail s)+-}+ -- | Find the indexes of all (possibly overlapping) occurances of a--- substring in a string. This function uses the Knuth-Morris-Pratt--- string matching algorithm.+-- substring in a string.+-- findSubstrings :: ByteString -- ^ String to search for. -> ByteString -- ^ String to seach in. -> [Int]+findSubstrings pat str+ | null pat = [0 .. length str]+ | otherwise = search 0 str+ where+ STRICT2(search)+ search n s+ | null s = []+ | pat `isPrefixOf` s = n : search (n+1) (unsafeTail s)+ | otherwise = search (n+1) (unsafeTail s) +{-# DEPRECATED findSubstrings "findSubstrings is deprecated in favour of breakSubstring." #-}++{-+{- This function uses the Knuth-Morris-Pratt string matching algorithm. -}+ findSubstrings pat@(PS _ _ m) str@(PS _ _ n) = search 0 0 where patc x = pat `unsafeIndex` x@@ -1453,6 +1544,7 @@ 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@@ -1482,8 +1574,7 @@ -- | 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.+-- performed on the result of zipWith. -- zipWith' :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString -> ByteString zipWith' f (PS fp s l) (PS fq t m) = inlinePerformIO $@@ -1505,10 +1596,8 @@ {-# INLINE zipWith' #-} {-# RULES--"FPS specialise zipWith" forall (f :: Word8 -> Word8 -> Word8) p q .+"ByteString 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@@ -1738,7 +1827,8 @@ -- | Read a 'ByteString' directly from the specified 'Handle'. This -- is far more efficient than reading the characters into a 'String'--- and then using 'pack'.+-- and then using 'pack'. First argument is the Handle to read from, +-- and the second is the number of bytes to read. -- hGet :: Handle -> Int -> IO ByteString hGet _ 0 = return empty
Data/ByteString/Char8.hs view
@@ -1,10 +1,11 @@-{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -XMagicHash -XUnboxedTuples #-} -- #prune -- | -- Module : Data.ByteString.Char8--- Copyright : (c) Don Stewart 2006+-- Copyright : (c) Don Stewart 2006-2008 -- License : BSD-style -- -- Maintainer : dons@cse.unsw.edu.au@@ -32,6 +33,11 @@ -- -- > import qualified Data.ByteString.Char8 as B --+-- The Char8 interface to bytestrings provides an instance of IsString+-- for the ByteString type, enabling you to use string literals, and+-- have them implicitly packed to ByteStrings. Use -XOverloadedStrings+-- to enable this.+-- module Data.ByteString.Char8 ( @@ -92,7 +98,6 @@ -- ** 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@@ -130,9 +135,9 @@ isPrefixOf, -- :: ByteString -> ByteString -> Bool isSuffixOf, -- :: ByteString -> ByteString -> Bool isInfixOf, -- :: ByteString -> ByteString -> Bool- isSubstringOf, -- :: ByteString -> ByteString -> Bool -- ** Search for arbitrary substrings+ breakSubstring, -- :: ByteString -> ByteString -> (ByteString,ByteString) findSubstring, -- :: ByteString -> ByteString -> Maybe Int findSubstrings, -- :: ByteString -> ByteString -> [Int] @@ -205,9 +210,6 @@ hPutStr, -- :: Handle -> ByteString -> IO () hPutStrLn, -- :: Handle -> ByteString -> IO () - -- undocumented deprecated things:- join -- :: ByteString -> [ByteString] -> ByteString- ) where import qualified Prelude as P@@ -230,8 +232,8 @@ 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+ ,sort,isPrefixOf,isSuffixOf,isInfixOf+ ,findSubstring,findSubstrings,breakSubstring,copy,group ,getLine, getContents, putStr, putStrLn, interact ,hGetContents, hGet, hPut, hPutStr, hPutStrLn@@ -313,8 +315,8 @@ {-# INLINE [1] pack #-} {-# RULES- "FPS pack/packAddress" forall s .- pack (unpackCString# s) = inlinePerformIO (B.unsafePackAddress s)+"ByteString pack/packAddress" forall s .+ pack (unpackCString# s) = inlinePerformIO (B.unsafePackAddress s) #-} #endif@@ -366,10 +368,6 @@ 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.@@ -443,11 +441,6 @@ 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@@ -538,6 +531,11 @@ {-# INLINE [1] dropWhile #-} #endif +{-# RULES+"ByteString specialise dropWhile isSpace -> dropSpace"+ dropWhile isSpace = dropSpace+ #-}+ -- | 'break' @p@ is equivalent to @'span' ('not' . p)@. break :: (Char -> Bool) -> ByteString -> (ByteString, ByteString) break f = B.break (f . w2c)@@ -545,6 +543,27 @@ {-# INLINE [1] break #-} #endif +{-# RULES+"ByteString specialise break (x==)" forall x.+ break ((==) x) = breakChar x+"ByteString specialise break (==x)" forall x.+ break (==x) = breakChar x+ #-}++-- INTERNAL:++-- | '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 c p = case elemIndex c p of+ Nothing -> (p,empty)+ Just n -> (B.unsafeTake n p, B.unsafeDrop n p)+{-# INLINE breakChar #-}+ -- | '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)@@ -711,13 +730,14 @@ -- predicate. filter :: (Char -> Bool) -> ByteString -> ByteString filter f = B.filter (f . w2c)-{-# INLINE [1] filter #-}+{-# INLINE filter #-} +{- -- | /O(n)/ and /O(n\/c) space/ 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. ----- > filterByte == filter . (==)+-- > filterChar == filter . (==) -- -- filterChar is around 10x faster, and uses much less space, than its -- filter equivalent@@ -727,14 +747,12 @@ {-# INLINE filterChar #-} {-# RULES- "FPS specialise filter (== x)" forall x.- filter ((==) x) = filterChar x- #-}--{-# RULES- "FPS specialise filter (== x)" forall x.- filter (== x) = filterChar x+"ByteString specialise filter (== x)" forall x.+ filter ((==) x) = filterChar x+"ByteString specialise filter (== x)" forall x.+ filter (== x) = filterChar x #-}+-} -- | /O(n)/ The 'find' function takes a predicate and a ByteString, -- and returns the first element in matching the predicate, or 'Nothing'@@ -806,8 +824,8 @@ -- Things that depend on the encoding {-# RULES- "FPS specialise break -> breakSpace"- break isSpace = breakSpace+"ByteString specialise break -> breakSpace"+ break isSpace = breakSpace #-} -- | 'breakSpace' returns the pair of ByteStrings when the argument is@@ -832,11 +850,6 @@ | 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.@@ -1001,6 +1014,9 @@ combine2 b (n:m:ns) = let t = m*b + n in t `seq` (t : combine2 b ns) combine2 _ ns = ns++------------------------------------------------------------------------+-- For non-binary text processing: -- | Read an entire file strictly into a 'ByteString'. This is far more -- efficient than reading the characters into a 'String' and then using
Data/ByteString/Fusion.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-} -- | -- Module : Data.ByteString.Fusion -- License : BSD-style@@ -6,695 +5,17 @@ -- Stability : experimental -- Portability : portable ----- Functional array fusion for ByteStrings.+-- Stream fusion for ByteStrings. ----- Originally based on code from the Data Parallel Haskell project, --- <http://www.cse.unsw.edu.au/~chak/project/dph>+-- See the paper /Stream Fusion: From Lists to Streams to Nothing at All/,+-- Coutts, Leshchinskiy and Stewart, 2007. -- -- #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(..)+ -- A place holder for Stream Fusion ) 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)
Data/ByteString/Internal.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# OPTIONS_GHC -XUnliftedFFITypes -XMagicHash -XUnboxedTuples -XDeriveDataTypeable #-} -- | -- Module : Data.ByteString.Internal -- License : BSD-style@@ -39,7 +40,6 @@ 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@@ -76,8 +76,13 @@ import Data.Generics (Data(..), Typeable(..)) import GHC.Ptr (Ptr(..)) import GHC.Base (realWorld#,unsafeChr)-import GHC.IOBase (IO(IO), unsafePerformIO, RawBuffer)+import GHC.IOBase (IO(IO), RawBuffer)+#if __GLASGOW_HASKELL__ >= 608+import GHC.IOBase (unsafeDupablePerformIO) #else+import GHC.IOBase (unsafePerformIO)+#endif+#else import Data.Char (chr) import System.IO.Unsafe (unsafePerformIO) #endif@@ -199,9 +204,15 @@ -- '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)+unsafeCreate l f = unsafeDupablePerformIO (create l f) {-# INLINE unsafeCreate #-} +#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 608+-- for Hugs +unsafeDupablePerformIO :: IO a -> a+unsafeDupablePerformIO = unsafePerformIO+#endif+ -- | 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@@ -334,12 +345,14 @@ memcpy :: Ptr Word8 -> Ptr Word8 -> CSize -> IO () memcpy p q s = 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)
Data/ByteString/Lazy.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fno-warn-incomplete-patterns #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- #prune @@ -101,7 +102,6 @@ -- ** 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@@ -193,13 +193,6 @@ 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@@ -215,7 +208,6 @@ 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(..)) @@ -593,10 +585,6 @@ 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 @@ -609,7 +597,9 @@ -- -- > 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)+scanl f z = snd . foldl k (z,singleton z)+ where+ k (c,acc) a = let n = f c a in (n, acc `snoc` n) {-# INLINE scanl #-} -- ---------------------------------------------------------------------@@ -905,10 +895,6 @@ intercalate :: ByteString -> [ByteString] -> ByteString intercalate s = concat . (L.intersperse s) -join :: ByteString -> [ByteString] -> ByteString-join = intercalate-{-# DEPRECATED join "use intercalate" #-}- -- --------------------------------------------------------------------- -- Indexing ByteStrings @@ -1024,10 +1010,9 @@ where go Empty = Empty go (Chunk x xs) = chunk (S.filter p x) (go xs)-#if __GLASGOW_HASKELL__-{-# INLINE [1] filter #-}-#endif+{-# 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.@@ -1041,14 +1026,13 @@ {-# INLINE filterByte #-} {-# RULES- "FPS specialise filter (== x)" forall x.- filter ((==) x) = filterByte x- #-}+"ByteString specialise filter (== x)" forall x.+ filter ((==) x) = filterByte x -{-# RULES- "FPS specialise filter (== x)" forall x.- filter (== x) = filterByte x+"ByteString specialise filter (== x)" forall x.+ filter (== x) = filterByte x #-}+-} {- -- | /O(n)/ A first order equivalent of /filter . (\/=)/, for the common
Data/ByteString/Lazy/Char8.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -cpp -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+{-# GHC_OPTIONS -fno-warn-orphans #-} -- #prune @@ -80,7 +81,7 @@ -- ** Accumulating maps mapAccumL, -- :: (acc -> Char -> (acc, Char)) -> acc -> ByteString -> (acc, ByteString)- mapIndexed, -- :: (Int64 -> Char -> Char) -> ByteString -> ByteString+ mapAccumR, -- :: (acc -> Char -> (acc, Char)) -> acc -> ByteString -> (acc, ByteString) -- ** Infinite ByteStrings repeat, -- :: Char -> ByteString@@ -174,13 +175,6 @@ 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@@ -308,10 +302,6 @@ 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.@@ -395,9 +385,12 @@ 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)))+-- | 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 = L.mapAccumR (\acc w -> case f acc (w2c w) of (acc', c) -> (acc', c2w c)) ------------------------------------------------------------------------ -- Generating and unfolding ByteStrings@@ -573,13 +566,14 @@ -- predicate. filter :: (Char -> Bool) -> ByteString -> ByteString filter f = L.filter (f . w2c)-{-# INLINE [1] filter #-}+{-# INLINE filter #-} +{- -- | /O(n)/ and /O(n\/c) space/ 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. ----- > filterByte == filter . (==)+-- > filterChar == filter . (==) -- -- filterChar is around 10x faster, and uses much less space, than its -- filter equivalent@@ -589,14 +583,15 @@ {-# INLINE filterChar #-} {-# RULES- "FPS specialise filter (== x)" forall x.+ "ByteString specialise filter (== x)" forall x. filter ((==) x) = filterChar x #-} {-# RULES- "FPS specialise filter (== x)" forall x.+ "ByteString specialise filter (== x)" forall x. filter (== x) = filterChar x #-}+-} -- | /O(n)/ The 'find' function takes a predicate and a ByteString, -- and returns the first element in matching the predicate, or 'Nothing'
Data/ByteString/Lazy/Internal.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -XDeriveDataTypeable #-} -- | -- Module : Data.ByteString.Lazy.Internal -- License : BSD-style
Data/ByteString/Unsafe.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -XMagicHash #-} -- | -- Module : Data.ByteString.Unsafe -- License : BSD-style@@ -133,7 +134,7 @@ -- 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'+-- is the case with "string"# literals in GHC). Use 'unsafePackAddressLen' -- if you know the length of the string statically. -- -- An example:@@ -144,6 +145,9 @@ -- original Addr# this modification will be reflected in the resulting -- @ByteString@, breaking referential transparency. --+-- Note this also won't work if you Add# has embedded '\0' characters in+-- the string (strlen will fail).+-- unsafePackAddress :: Addr# -> IO ByteString unsafePackAddress addr# = do p <- newForeignPtr_ cstr@@ -239,12 +243,13 @@ -- | /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+-- This funtion is /unsafe/. If the original @CString@ 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.+-- which will result in a /double free/ error, or if you pass it+-- a CString not allocated with 'malloc'. -- unsafePackMallocCString :: CString -> IO ByteString unsafePackMallocCString cstr = do
TODO view
@@ -1,10 +1,8 @@ TODO: * back port streams fusion code.- * check Lazy.groupBy * close bug in Lazy.lines * show instance for LPS- * export chunk sizes * ensure memchr / (== c) rules either always work, or we can back door them * stress testing * strictness testing
bytestring.cabal view
@@ -1,35 +1,35 @@ Name: bytestring-Version: 0.9.0.4+Version: 0.9.1.0 Synopsis: Fast, packed, strict and lazy byte arrays with a list interface Description: . 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.+ are encoded as strict 'Word8' arrays of bytes, and lazy lists of+ strict chunks, held in a 'ForeignPtr', and can be passed between C+ and Haskell with little effort. .+ Test coverage data for this library is available at:+ <http://code.haskell.org/~dons/tests/bytestring/hpc_index.html>+ . License: BSD3 License-file: LICENSE Category: Data-Copyright: Copyright (c) Don Stewart 2005-2007,+Copyright: Copyright (c) Don Stewart 2005-2008, (c) Duncan Coutts 2006-2007, (c) David Roundy 2003-2005. Author: Don Stewart, Duncan Coutts Maintainer: dons@galois.com, duncan@haskell.org Stability: provisional Homepage: http://www.cse.unsw.edu.au/~dons/fps.html-Tested-With: GHC ==6.8.2, GHC ==6.6.1, GHC ==6.4.2+Tested-With: GHC ==6.8.2 Build-Type: Simple Cabal-Version: >= 1.2--flag split-base+extra-source-files: README TODO library- if flag(split-base)- build-depends: base >= 3, array- else- build-depends: base < 3+ build-depends: base exposed-modules: Data.ByteString Data.ByteString.Char8 Data.ByteString.Unsafe@@ -38,18 +38,26 @@ Data.ByteString.Lazy.Char8 Data.ByteString.Lazy.Internal Data.ByteString.Fusion+ extensions: CPP, ForeignFunctionInterface + if impl(ghc)+ extensions: UnliftedFFITypes, MagicHash, UnboxedTuples, DeriveDataTypeable++ ghc-options: -fglasgow-exts+ -Wall -fno-warn-orphans+ -O2 -funbox-strict-fields + -fdicts-cheap -fno-method-sharing+ -fmax-simplifier-iterations10 -fcpr-off+ --+ -- -fglasgow-exts needed for local rewrite rules:+ --+ c-sources: cbits/fpstring.c include-dirs: include includes: fpstring.h install-includes: fpstring.h - ghc-options: -Wall- -fglasgow-exts -O2 -funbox-strict-fields - -fdicts-cheap -fno-method-sharing- -fmax-simplifier-iterations10 -fcpr-off- nhc98-options: -K4M -K3M if impl(ghc <= 6.4.2)- ghc-options: -DSLOW_FOREIGN_PTR+ cc-options: -DSLOW_FOREIGN_PTR
tests/Bench.hs view
@@ -184,8 +184,8 @@ ,101,114,103,32,101,66,111,111,107])) ]) , ("join",- [F ({-# SCC "join" #-} app $ B.join (B.pack [1,2,3]))- ,F ({-# SCC "lazy join" #-} app $ L.join (L.pack [1,2,3]))+ [F ({-# SCC "join" #-} app $ B.intercalate (B.pack [1,2,3]))+ ,F ({-# SCC "lazy join" #-} app $ L.intercalate (L.pack [1,2,3])) ]) -- , ("joinWithByte", -- [F ({-# SCC "joinWithByte" #-} app $ uncurry (B.joinWithByte 32))@@ -286,8 +286,8 @@ , ("zipWith'", [F ({-# SCC "zipWith'" #-} app (uncurry (B.zipWith (+)))) ])- , ("isSubstringOf",- [F ({-# SCC "isSubstringOf" #-} app $ B.isSubstringOf (C.pack "email news"))+ , ("isInfixOf",+ [F ({-# SCC "isSubstringOf" #-} app $ B.isInfixOf (C.pack "email news")) ]) , ("isSuffixOf", [F ({-# SCC "isSuffixOf" #-} app $ B.isSuffixOf (C.pack "new eBooks"))
+ tests/Hash.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE BangPatterns #-}++import qualified Data.HashTable as T+import System.Environment+import Control.Applicative+import Data.List+import Data.Ord+import qualified Data.Map as M+import qualified Data.ByteString.Char8 as S++import qualified Data.ByteString.Internal as S+import qualified Data.ByteString.Unsafe as S+import Foreign+++type Table = T.HashTable S.ByteString Int++newTable :: IO Table+newTable = T.new (==) hash++update :: Table -> S.ByteString -> IO ()+update t w = do+ old <- T.lookup t w+ case old of+ Just c -> do T.update t w $! c + 1; return ()+ _ -> T.insert t w 1++main = do+ [name] <- getArgs+ t <- newTable+ S.words <$> S.readFile name >>= mapM_ (update t)+ xs <- sortBy (flip (comparing snd)) <$> T.toList t+ print (take 20 xs)++------------------------------------------------------------------------+-- a different Ord++hash :: S.ByteString -> Int32+hash ps = go 0 golden+ where+ len = S.length ps++ go :: Int -> Int32 -> Int32+ go !n !acc+ | n == len = fromIntegral acc+ | otherwise = go (n+1)+ ((fromIntegral (ps `S.unsafeIndex` n))+ * 0xdeadbeef + hashInt32 acc)++golden :: Int32+golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32++hashInt32 :: Int32 -> Int32+hashInt32 x = mulHi x golden + x++-- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply+mulHi :: Int32 -> Int32 -> Int32+mulHi a b = fromIntegral (r `shiftR` 32)+ where r :: Int64+ r = fromIntegral a * fromIntegral b++------------------------------------------------------------------------++newtype OrdString = OrdString S.ByteString+ deriving Show++eq a@(S.PS p s l) b@(S.PS p' s' l')+ | l /= l' = False -- short cut on length+ | p == p' && s == s' = True -- short cut for the same string+ | otherwise = compare a b == EQ+ where+ compare (S.PS fp1 off1 len1) (S.PS fp2 off2 len2) = S.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+cmp !p1 !p2 !n len1 len2+ | n == len1 = if n == len2 then return EQ else return LT+ | n == len2 = return GT+ | otherwise = do+ a <- peekByteOff p1 n :: IO Word8+ b <- peekByteOff p2 n+ case a `compare` b of+ EQ -> cmp p1 p2 (n+1) len1 len2+ LT -> return LT+ GT -> return GT
tests/Makefile view
@@ -1,5 +1,6 @@ GHC= ghc-GHCFLAGS= -cpp -O2 -funbox-strict-fields -no-recomp -v0+GHCFLAGS= -cpp -O2 -funbox-strict-fields -v0 -fglasgow-exts -O2 -funbox-strict-fields -fdicts-cheap -fno-method-sharing -fmax-simplifier-iterations10 -fcpr-off+ #PKG= -package fps #GHC= /usr/obj/build/compiler/stage2/ghc-inplace@@ -45,7 +46,7 @@ # interpreted fast. Just a quick check. .PHONY: prop-fast prop-fast::- runhaskell -i../cbits/fpstring.o Properties.hs 10 + runhaskell -i../cbits/fpstring.o Properties.hs 30 # compiled .PHONY: prop-compiled@@ -61,6 +62,18 @@ ${GHC} ${PKG} ${GHCFLAGS} --make Properties.hs -o p -package QuickCheck time ./p +# rules-on+.PHONY: hpc-lite+hpc-lite: + @echo "Compiled, rules on, with hpc" + rm -f p.tix+ ${GHC} ${GHCFLAGS} ../dist/build/cbits/fpstring.o -ddump-simpl-stats -fhpc --make -i.. Properties.hs -o p -O -fno-ignore-asserts -fasm -frewrite-rules+ rm Rules.o Rules.hi+ ${GHC} ${GHCFLAGS} -hide-package bytestring ../dist/build/cbits/fpstring.o -ddump-simpl-stats -i.. Rules.hs -O -fno-ignore-asserts -fasm -frewrite-rules ../Data/ByteString/*.o ../Data/ByteString/*/*.o ../Data/ByteString.o -package QuickCheck QuickCheckUtils.o -c -no-recomp+ ${GHC} ${GHCFLAGS} -package QuickCheck ../dist/build/cbits/fpstring.o Properties.o Rules.o QuickCheckUtils.o ../Data/ByteString/*.o ../Data/ByteString/*/*.o ../Data/ByteString.o -o p+ time ./p 40+ hpc markup p --exclude=Main --exclude=QuickCheckUtils --exclude=Data.ByteString.Fusion+ # # test rewriting is correct and working. #@@ -191,3 +204,4 @@ rm -f *~ *.o *.hi $(BIN) bench */*.o */*.hi */*~ rm -f wc letter_frequency spellcheck linesort fuse inline p u fp lazylines lazybuild lazybuildcons rm -f down-fuse zipwith fusionbench unpack groupby+ rm -rf *.tix *.html .hpc check
tests/Properties.hs view
@@ -1,18 +1,33 @@+{-# LANGUAGE PatternSignatures #-} -- -- Must have rules off, otherwise the fusion rules will replace the rhs -- with the lhs, and we only end up testing lhs == lhs -- +--+-- -fhpc interferes with rewrite rules firing.+--++import Foreign+import Foreign.ForeignPtr+import Foreign.Marshal.Array+import GHC.Ptr import Test.QuickCheck+import Control.Monad+import Control.Concurrent+import Control.Exception+import System.Directory import Data.List import Data.Char import Data.Word import Data.Maybe import Data.Int (Int64)+import Data.Monoid import Text.Printf import Debug.Trace+import Data.String import System.Environment import System.IO@@ -25,23 +40,108 @@ import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.Internal (ByteString(..)) -import qualified Data.ByteString as P-import qualified Data.ByteString.Internal as P-import qualified Data.ByteString.Unsafe as P-import qualified Data.ByteString.Char8 as C+import qualified Data.ByteString as P+import qualified Data.ByteString.Internal as P+import qualified Data.ByteString.Unsafe as P+import qualified Data.ByteString.Char8 as C++import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy.Char8 as D++import qualified Data.ByteString.Lazy.Internal as LP import Data.ByteString.Fusion import Prelude hiding (abs) +import Rules import QuickCheckUtils +f = C.dropWhile isSpace+ --+-- ByteString.Lazy.Char8 <=> ByteString.Char8+--++prop_concatCC = D.concat `eq1` C.concat+prop_nullCC = D.null `eq1` C.null+prop_reverseCC = D.reverse `eq1` C.reverse+prop_transposeCC = D.transpose `eq1` C.transpose+prop_groupCC = D.group `eq1` C.group+prop_initsCC = D.inits `eq1` C.inits+prop_tailsCC = D.tails `eq1` C.tails+prop_allCC = D.all `eq2` C.all+prop_anyCC = D.any `eq2` C.any+prop_appendCC = D.append `eq2` C.append+prop_breakCC = D.break `eq2` C.break+prop_concatMapCC = D.concatMap `eq2` C.concatMap+prop_consCC = D.cons `eq2` C.cons+prop_unconsCC = D.uncons `eq1` C.uncons+prop_countCC = D.count `eq2` C.count+prop_dropCC = D.drop `eq2` C.drop+prop_dropWhileCC = D.dropWhile `eq2` C.dropWhile+prop_filterCC = D.filter `eq2` C.filter+prop_findCC = D.find `eq2` C.find+prop_findIndexCC = D.findIndex `eq2` C.findIndex+prop_findIndicesCC = D.findIndices `eq2` C.findIndices+prop_isPrefixOfCC = D.isPrefixOf `eq2` C.isPrefixOf+prop_mapCC = D.map `eq2` C.map+prop_replicateCC = D.replicate `eq2` C.replicate+prop_snocCC = D.snoc `eq2` C.snoc+prop_spanCC = D.span `eq2` C.span+prop_splitCC = D.split `eq2` C.split+prop_splitAtCC = D.splitAt `eq2` C.splitAt+prop_takeCC = D.take `eq2` C.take+prop_takeWhileCC = D.takeWhile `eq2` C.takeWhile+prop_elemCC = D.elem `eq2` C.elem+prop_notElemCC = D.notElem `eq2` C.notElem+prop_elemIndexCC = D.elemIndex `eq2` C.elemIndex+prop_elemIndicesCC = D.elemIndices `eq2` C.elemIndices+prop_lengthCC = D.length `eq1` (fromIntegral . C.length :: C.ByteString -> Int64)++prop_headCC = D.head `eqnotnull1` C.head+prop_initCC = D.init `eqnotnull1` C.init+prop_lastCC = D.last `eqnotnull1` C.last+prop_maximumCC = D.maximum `eqnotnull1` C.maximum+prop_minimumCC = D.minimum `eqnotnull1` C.minimum+prop_tailCC = D.tail `eqnotnull1` C.tail+prop_foldl1CC = D.foldl1 `eqnotnull2` C.foldl1+prop_foldl1CC' = D.foldl1' `eqnotnull2` C.foldl1'+prop_foldr1CC = D.foldr1 `eqnotnull2` C.foldr1+prop_foldr1CC' = D.foldr1 `eqnotnull2` C.foldr1'+prop_scanlCC = D.scanl `eqnotnull3` C.scanl++prop_intersperseCC = D.intersperse `eq2` C.intersperse++prop_foldlCC = eq3+ (D.foldl :: (X -> Char -> X) -> X -> B -> X)+ (C.foldl :: (X -> Char -> X) -> X -> P -> X)+prop_foldlCC' = eq3+ (D.foldl' :: (X -> Char -> X) -> X -> B -> X)+ (C.foldl' :: (X -> Char -> X) -> X -> P -> X)+prop_foldrCC = eq3+ (D.foldr :: (Char -> X -> X) -> X -> B -> X)+ (C.foldr :: (Char -> X -> X) -> X -> P -> X)+prop_foldrCC' = eq3+ (D.foldr :: (Char -> X -> X) -> X -> B -> X)+ (C.foldr' :: (Char -> X -> X) -> X -> P -> X)+prop_mapAccumLCC = eq3+ (D.mapAccumL :: (X -> Char -> (X,Char)) -> X -> B -> (X, B))+ (C.mapAccumL :: (X -> Char -> (X,Char)) -> X -> P -> (X, P))++--prop_mapIndexedCC = D.mapIndexed `eq2` C.mapIndexed+--prop_mapIndexedPL = L.mapIndexed `eq2` P.mapIndexed++--prop_mapAccumL_mapIndexedBP =+-- P.mapIndexed `eq2`+-- (\k p -> snd $ P.mapAccumL (\i w -> (i+1, k i w)) (0::Int) p)++-- -- ByteString.Lazy <=> ByteString -- prop_concatBP = L.concat `eq1` P.concat prop_nullBP = L.null `eq1` P.null prop_reverseBP = L.reverse `eq1` P.reverse+ prop_transposeBP = L.transpose `eq1` P.transpose prop_groupBP = L.group `eq1` P.group prop_initsBP = L.inits `eq1` P.inits@@ -52,6 +152,9 @@ prop_breakBP = L.break `eq2` P.break prop_concatMapBP = L.concatMap `eq2` P.concatMap prop_consBP = L.cons `eq2` P.cons+prop_consBP' = L.cons' `eq2` P.cons+prop_consLP' = LC.cons' `eq2` P.cons+prop_unconsBP = L.uncons `eq1` P.uncons prop_countBP = L.count `eq2` P.count prop_dropBP = L.drop `eq2` P.drop prop_dropWhileBP = L.dropWhile `eq2` P.dropWhile@@ -72,6 +175,7 @@ prop_notElemBP = L.notElem `eq2` P.notElem prop_elemIndexBP = L.elemIndex `eq2` P.elemIndex prop_elemIndicesBP = L.elemIndices `eq2` P.elemIndices+prop_intersperseBP = L.intersperse `eq2` P.intersperse prop_lengthBP = L.length `eq1` (fromIntegral . P.length :: P.ByteString -> Int64) prop_readIntBP = D.readInt `eq1` C.readInt prop_linesBP = D.lines `eq1` C.lines@@ -91,8 +195,10 @@ prop_foldl1BP = L.foldl1 `eqnotnull2` P.foldl1 prop_foldl1BP' = L.foldl1' `eqnotnull2` P.foldl1' prop_foldr1BP = L.foldr1 `eqnotnull2` P.foldr1+prop_foldr1BP' = L.foldr1 `eqnotnull2` P.foldr1' prop_scanlBP = L.scanl `eqnotnull3` P.scanl + prop_eqBP = eq2 ((==) :: B -> B -> Bool) ((==) :: P -> P -> Bool)@@ -108,6 +214,9 @@ prop_foldrBP = eq3 (L.foldr :: (W -> X -> X) -> X -> B -> X) (P.foldr :: (W -> X -> X) -> X -> P -> X)+prop_foldrBP' = eq3+ (L.foldr :: (W -> X -> X) -> X -> B -> X)+ (P.foldr' :: (W -> X -> X) -> X -> P -> X) prop_mapAccumLBP = eq3 (L.mapAccumL :: (X -> W -> (X,W)) -> X -> B -> (X, B)) (P.mapAccumL :: (X -> W -> (X,W)) -> X -> P -> (X, P))@@ -118,6 +227,69 @@ ((\n f a -> fst $ P.unfoldrN n f a) :: Int -> (X -> Maybe (W,X)) -> X -> P) +prop_unfoldr2BP = eq2+ ((\n a -> P.take (n*100) $+ P.unfoldr (\x -> if x <= (n*100) then Just (fromIntegral x, x + 1) else Nothing) a)+ :: Int -> Int -> P)+ ((\n a -> fst $+ P.unfoldrN (n*100) (\x -> if x <= (n*100) then Just (fromIntegral x, x + 1) else Nothing) a)+ :: Int -> Int -> P)++prop_unfoldr2CP = eq2+ ((\n a -> C.take (n*100) $+ C.unfoldr (\x -> if x <= (n*100) then Just (chr (x `mod` 256), x + 1) else Nothing) a)+ :: Int -> Int -> P)+ ((\n a -> fst $+ C.unfoldrN (n*100) (\x -> if x <= (n*100) then Just (chr (x `mod` 256), x + 1) else Nothing) a)+ :: Int -> Int -> P)+++prop_unfoldrLC = eq3+ ((\n f a -> LC.take (fromIntegral n) $+ LC.unfoldr f a) :: Int -> (X -> Maybe (Char,X)) -> X -> B)+ ((\n f a -> fst $+ C.unfoldrN n f a) :: Int -> (X -> Maybe (Char,X)) -> X -> P)++prop_cycleLC a = not (LC.null a) ==> eq1+ ((\n -> LC.take (fromIntegral n) $+ LC.cycle a+ ) :: Int -> B)++ ((\n -> LC.take (fromIntegral (n::Int)) . LC.concat $+ unfoldr (\x -> Just (x,x) ) a+ ) :: Int -> B)+++prop_iterateLC = eq3+ ((\n f a -> LC.take (fromIntegral n) $+ LC.iterate f a) :: Int -> (Char -> Char) -> Char -> B)+ ((\n f a -> fst $+ C.unfoldrN n (\a -> Just (f a, f a)) a) :: Int -> (Char -> Char) -> Char -> P)++prop_iterateLC_2 = eq3+ ((\n f a -> LC.take (fromIntegral n) $+ LC.iterate f a) :: Int -> (Char -> Char) -> Char -> B)+ ((\n f a -> LC.take (fromIntegral n) $+ LC.unfoldr (\a -> Just (f a, f a)) a) :: Int -> (Char -> Char) -> Char -> B)++prop_iterateL = eq3+ ((\n f a -> L.take (fromIntegral n) $+ L.iterate f a) :: Int -> (W -> W) -> W -> B)+ ((\n f a -> fst $+ P.unfoldrN n (\a -> Just (f a, f a)) a) :: Int -> (W -> W) -> W -> P)++prop_repeatLC = eq2+ ((\n a -> LC.take (fromIntegral n) $+ LC.repeat a) :: Int -> Char -> B)+ ((\n a -> fst $+ C.unfoldrN n (\a -> Just (a, a)) a) :: Int -> Char -> P)++prop_repeatL = eq2+ ((\n a -> L.take (fromIntegral n) $+ L.repeat a) :: Int -> W -> B)+ ((\n a -> fst $+ P.unfoldrN n (\a -> Just (a, a)) a) :: Int -> W -> P)+ -- -- properties comparing ByteString.Lazy `eq1` List --@@ -184,9 +356,19 @@ prop_mapAccumLBL = eq3 (L.mapAccumL :: (X -> W -> (X,W)) -> X -> B -> (X, B)) ( mapAccumL :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W]))+ prop_mapAccumRBL = eq3 (L.mapAccumR :: (X -> W -> (X,W)) -> X -> B -> (X, B)) ( mapAccumR :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W]))++prop_mapAccumRDL = eq3+ (D.mapAccumR :: (X -> Char -> (X,Char)) -> X -> B -> (X, B))+ ( mapAccumR :: (X -> Char -> (X,Char)) -> X -> [Char] -> (X, [Char]))++prop_mapAccumRCC = eq3+ (C.mapAccumR :: (X -> Char -> (X,Char)) -> X -> P -> (X, P))+ ( mapAccumR :: (X -> Char -> (X,Char)) -> X -> [Char] -> (X, [Char]))+ prop_unfoldrBL = eq3 ((\n f a -> L.take (fromIntegral n) $ L.unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> B)@@ -214,9 +396,21 @@ prop_dropPL = P.drop `eq2` (drop :: Int -> [W] -> [W]) prop_dropWhilePL = P.dropWhile `eq2` (dropWhile :: (W -> Bool) -> [W] -> [W]) prop_filterPL = P.filter `eq2` (filter :: (W -> Bool ) -> [W] -> [W])+prop_filterPL_rule= (\x -> P.filter ((==) x)) `eq2` -- test rules+ ((\x -> filter ((==) x)) :: W -> [W] -> [W])++-- under lambda doesn't fire?+prop_filterLC_rule= (f) `eq2` -- test rules+ ((\x -> filter ((==) x)) :: Char -> [Char] -> [Char])+ where+ f x s = LC.filter ((==) x) s++prop_partitionPL = P.partition `eq2` (partition :: (W -> Bool ) -> [W] -> ([W],[W]))+prop_partitionLL = L.partition `eq2` (partition :: (W -> Bool ) -> [W] -> ([W],[W])) prop_findPL = P.find `eq2` (find :: (W -> Bool) -> [W] -> Maybe W) prop_findIndexPL = P.findIndex `eq2` (findIndex :: (W -> Bool) -> [W] -> Maybe Int) prop_isPrefixOfPL = P.isPrefixOf`eq2` (isPrefixOf:: [W] -> [W] -> Bool)+prop_isInfixOfPL = P.isInfixOf`eq2` (isInfixOf:: [W] -> [W] -> Bool) prop_mapPL = P.map `eq2` (map :: (W -> W) -> [W] -> [W]) prop_replicatePL = P.replicate `eq2` (replicate :: Int -> W -> [W]) prop_snocPL = P.snoc `eq2` ((\xs x -> xs ++ [x]) :: [W] -> W -> [W])@@ -231,7 +425,11 @@ prop_findIndicesPL= P.findIndices`eq2` (findIndices:: (W -> Bool) -> [W] -> [Int]) prop_elemIndicesPL= P.elemIndices`eq2` (elemIndices:: W -> [W] -> [Int]) prop_zipPL = P.zip `eq2` (zip :: [W] -> [W] -> [(W,W)])+prop_zipCL = C.zip `eq2` (zip :: [Char] -> [Char] -> [(Char,Char)])+prop_zipLL = L.zip `eq2` (zip :: [W] -> [W] -> [(W,W)]) prop_unzipPL = P.unzip `eq1` (unzip :: [(W,W)] -> ([W],[W]))+prop_unzipLL = L.unzip `eq1` (unzip :: [(W,W)] -> ([W],[W]))+prop_unzipCL = C.unzip `eq1` (unzip :: [(Char,Char)] -> ([Char],[Char])) prop_foldl1PL = P.foldl1 `eqnotnull2` (foldl1 :: (W -> W -> W) -> [W] -> W) prop_foldl1PL' = P.foldl1' `eqnotnull2` (foldl1' :: (W -> W -> W) -> [W] -> W)@@ -247,11 +445,18 @@ prop_minimumPL = P.minimum `eqnotnull1` (minimum :: [W] -> W) prop_tailPL = P.tail `eqnotnull1` (tail :: [W] -> [W]) +prop_scanl1CL = C.scanl1 `eqnotnull2` (scanl1 :: (Char -> Char -> Char) -> [Char] -> [Char])+prop_scanrCL = C.scanr `eqnotnull3` (scanr :: (Char -> Char -> Char) -> Char -> [Char] -> [Char])+prop_scanr1CL = C.scanr1 `eqnotnull2` (scanr1 :: (Char -> Char -> Char) -> [Char] -> [Char])+ -- prop_zipWithPL' = P.zipWith' `eq3` (zipWith :: (W -> W -> W) -> [W] -> [W] -> [W]) prop_zipWithPL = (P.zipWith :: (W -> W -> X) -> P -> P -> [X]) `eq3` (zipWith :: (W -> W -> X) -> [W] -> [W] -> [X]) +prop_zipWithPL_rules = (P.zipWith :: (W -> W -> W) -> P -> P -> [W]) `eq3`+ (zipWith :: (W -> W -> W) -> [W] -> [W] -> [W])+ prop_eqPL = eq2 ((==) :: P -> P -> Bool) ((==) :: [W] -> [W] -> Bool)@@ -310,6 +515,8 @@ prop_compare7 x y = x `compare` y == (L.singleton x `compare` L.singleton y) prop_compare8 xs ys = xs `compare` ys == (L.pack xs `compare` L.pack ys) +prop_compare7LL x y = x `compare` y == (LC.singleton x `compare` LC.singleton y)+ prop_empty1 = L.length L.empty == 0 prop_empty2 = L.unpack L.empty == [] @@ -442,10 +649,23 @@ l1 = fromIntegral (length splits) l2 = L.length (L.filter f xs) +prop_splitWith_D f xs = (l1 == l2 || l1 == l2+1) &&+ sum (map D.length splits) == D.length xs - l2+ where splits = D.splitWith f xs+ l1 = fromIntegral (length splits)+ l2 = D.length (D.filter f xs)++prop_splitWith_C f xs = (l1 == l2 || l1 == l2+1) &&+ sum (map C.length splits) == C.length xs - l2+ where splits = C.splitWith f xs+ l1 = fromIntegral (length splits)+ l2 = C.length (C.filter f xs)+ prop_joinsplit c xs = L.intercalate (pack [c]) (L.split c xs) == id xs prop_group xs = group xs == (map unpack . L.group . pack) xs prop_groupBy f xs = groupBy f xs == (map unpack . L.groupBy f . pack) xs+prop_groupBy_LC f xs = groupBy f xs == (map LC.unpack . LC.groupBy f . LC.pack) xs -- prop_joinjoinByte xs ys c = L.joinWithByte c xs ys == L.join (L.singleton c) [xs,ys] @@ -454,7 +674,18 @@ forAll indices $ \i -> (xs !! i) == L.pack xs `L.index` (fromIntegral i) where indices = choose (0, length xs -1) +prop_index_D xs =+ not (null xs) ==>+ forAll indices $ \i -> (xs !! i) == D.pack xs `D.index` (fromIntegral i)+ where indices = choose (0, length xs -1)++prop_index_C xs =+ not (null xs) ==>+ forAll indices $ \i -> (xs !! i) == C.pack xs `C.index` (fromIntegral i)+ where indices = choose (0, length xs -1)+ prop_elemIndex xs c = (elemIndex c xs) == fmap fromIntegral (L.elemIndex c (pack xs))+prop_elemIndexCL xs c = (elemIndex c xs) == (C.elemIndex c (C.pack xs)) prop_elemIndices xs c = elemIndices c xs == map fromIntegral (L.elemIndices c (pack xs)) @@ -503,7 +734,12 @@ prop_nil1BB = P.length P.empty == 0 prop_nil2BB = P.unpack P.empty == []+prop_nil1BB_monoid = P.length mempty == 0+prop_nil2BB_monoid = P.unpack mempty == [] +prop_nil1LL_monoid = L.length mempty == 0+prop_nil2LL_monoid = L.unpack mempty == []+ prop_tailSBB xs = not (P.null xs) ==> P.tail xs == P.pack (tail (P.unpack xs)) prop_nullBB xs = null (P.unpack xs) == P.null xs@@ -567,7 +803,11 @@ prop_wordsSBB xs = C.words (C.pack xs) == map C.pack (words xs) +prop_wordsLC xs =+ LC.words (LC.pack xs) == map LC.pack (words xs)+ prop_unwordsSBB xss = C.unwords (map C.pack xss) == C.pack (unwords xss)+prop_unwordsSLC xss = LC.unwords (map LC.pack xss) == LC.pack (unwords xss) prop_splitWithBB f xs = (l1 == l2 || l1 == l2+1) && sum (map P.length splits) == P.length xs - l2@@ -577,12 +817,23 @@ prop_joinsplitBB c xs = P.intercalate (P.pack [c]) (P.split c xs) == xs +prop_intercalatePL c x y =++ P.intercalate (P.singleton c) (x : y : []) ==+ -- intercalate (singleton c) (s1 : s2 : [])++ P.pack (intercalate [c] [P.unpack x,P.unpack y])+ -- prop_linessplitBB xs = -- (not . C.null) xs ==> -- C.lines' xs == C.split '\n' xs +-- false:+{- prop_linessplit2BB xs =+ (not . C.null) xs ==> C.lines xs == C.split '\n' xs ++ (if C.last xs == '\n' then [C.empty] else [])+-} prop_splitsplitWithBB c xs = P.split c xs == P.splitWith (== c) xs @@ -593,7 +844,7 @@ prop_packunpackBB' s = (P.pack . P.unpack) s == id s prop_eq1BB xs = xs == (P.unpack . P.pack $ xs)-prop_eq2BB xs = xs == xs+prop_eq2BB xs = xs == (xs :: P.ByteString) prop_eq3BB xs ys = (xs == ys) == (P.unpack xs == P.unpack ys) prop_compare1BB xs = (P.pack xs `compare` P.pack xs) == EQ@@ -634,6 +885,14 @@ prop_append2BB xs ys = (xs ++ ys) == (P.unpack $ P.pack xs `P.append` P.pack ys) prop_append3BB xs ys = P.append xs ys == P.pack (P.unpack xs ++ P.unpack ys) +prop_append1BB_monoid xs = (xs ++ xs) == (P.unpack $ P.pack xs `mappend` P.pack xs)+prop_append2BB_monoid xs ys = (xs ++ ys) == (P.unpack $ P.pack xs `mappend` P.pack ys)+prop_append3BB_monoid xs ys = mappend xs ys == P.pack (P.unpack xs ++ P.unpack ys)++prop_append1LL_monoid xs = (xs ++ xs) == (L.unpack $ L.pack xs `mappend` L.pack xs)+prop_append2LL_monoid xs ys = (xs ++ ys) == (L.unpack $ L.pack xs `mappend` L.pack ys)+prop_append3LL_monoid xs ys = mappend xs ys == L.pack (L.unpack xs ++ L.unpack ys)+ prop_map1BB f xs = P.map f (P.pack xs) == P.pack (map f xs) prop_map2BB f g xs = P.map f (P.map g xs) == P.map (f . g) xs prop_map3BB f xs = map f xs == (P.unpack . P.map f . P.pack) xs@@ -689,6 +948,10 @@ prop_dropWhileBB xs a = (dropWhile (/= a) xs) == (P.unpack . (P.dropWhile (/= a)) . P.pack) xs +prop_dropWhileCC_isSpace xs =+ (dropWhile isSpace xs) ==+ (C.unpack . (C.dropWhile isSpace) . C.pack) xs+ prop_takeBB xs = (take 10 xs) == (P.unpack . (P.take 10) . P.pack) xs prop_dropBB xs = (drop 10 xs) == (P.unpack . (P.drop 10) . P.pack) xs@@ -716,6 +979,14 @@ prop_concat2BB xs = (concat [xs,[]]) == (P.unpack $ P.concat [P.pack xs, P.pack []]) prop_concatBB xss = P.concat (map P.pack xss) == P.pack (concat xss) +prop_concat1BB_monoid xs = (concat [xs,xs]) == (P.unpack $ mconcat [P.pack xs, P.pack xs])+prop_concat2BB_monoid xs = (concat [xs,[]]) == (P.unpack $ mconcat [P.pack xs, P.pack []])+prop_concatBB_monoid xss = mconcat (map P.pack xss) == P.pack (concat xss)++prop_concat1LL_monoid xs = (concat [xs,xs]) == (L.unpack $ mconcat [L.pack xs, L.pack xs])+prop_concat2LL_monoid xs = (concat [xs,[]]) == (L.unpack $ mconcat [L.pack xs, L.pack []])+prop_concatLL_monoid xss = mconcat (map L.pack xss) == L.pack (concat xss)+ prop_concatMapBB xs = C.concatMap C.singleton xs == (C.pack . concatMap (:[]) . C.unpack) xs prop_anyBB xs a = (any (== a) xs) == (P.any (== a) (P.pack xs))@@ -724,6 +995,7 @@ prop_linesBB xs = (lines xs) == ((map C.unpack) . C.lines . C.pack) xs prop_unlinesBB xs = (unlines.lines) xs == (C.unpack. C.unlines . C.lines .C.pack) xs+prop_unlinesLC xs = (unlines.lines) xs == (LC.unpack. LC.unlines . LC.lines .LC.pack) xs prop_wordsBB xs = (words xs) == ((map C.unpack) . C.words . C.pack) xs@@ -735,7 +1007,9 @@ prop_groupBB xs = group xs == (map P.unpack . P.group . P.pack) xs prop_groupByBB xs = groupBy (==) xs == (map P.unpack . P.groupBy (==) . P.pack) xs+prop_groupByCC xs = groupBy (==) xs == (map C.unpack . C.groupBy (==) . C.pack) xs prop_groupBy1BB xs = groupBy (/=) xs == (map P.unpack . P.groupBy (/=) . P.pack) xs+prop_groupBy1CC xs = groupBy (/=) xs == (map C.unpack . C.groupBy (/=) . C.pack) xs prop_joinBB xs ys = (concat . (intersperse ys) . lines) xs == (C.unpack $ C.intercalate (C.pack ys) (C.lines (C.pack xs)))@@ -752,6 +1026,11 @@ Nothing -> Nothing Just i -> Just (length xs -1 -i)) +prop_elemIndexEnd1CC c xs = (C.elemIndexEnd c (C.pack xs)) ==+ (case C.elemIndex c (C.pack (reverse xs)) of+ Nothing -> Nothing+ Just i -> Just (length xs -1 -i))+ prop_elemIndexEnd2BB c xs = (P.elemIndexEnd c (P.pack xs)) == ((-) (length xs - 1) `fmap` P.elemIndex c (P.pack $ reverse xs)) @@ -776,7 +1055,7 @@ prop_intersperseBB c xs = (intersperse c xs) == (P.unpack $ P.intersperse c (P.pack xs)) -prop_transposeBB xs = (transpose xs) == ((map P.unpack) . P.transpose . (map P.pack)) xs+-- prop_transposeBB xs = (transpose xs) == ((map P.unpack) . P.transpose . (map P.pack)) xs prop_maximumBB xs = (not (null xs)) ==> (maximum xs) == (P.maximum ( P.pack xs )) prop_minimumBB xs = (not (null xs)) ==> (minimum xs) == (P.minimum ( P.pack xs ))@@ -794,6 +1073,7 @@ (let (x,y) = C.span (not.isSpace) (C.reverse (C.pack xs)) in (C.reverse y,C.reverse x)) prop_breakEndBB p xs = P.breakEnd (not.p) xs == P.spanEnd p xs+prop_breakEndCC p xs = C.breakEnd (not.p) xs == C.spanEnd p xs {- prop_breakCharBB c xs =@@ -821,8 +1101,10 @@ prop_prefixBB xs ys = isPrefixOf xs ys == (P.pack xs `P.isPrefixOf` P.pack ys) prop_suffixBB xs ys = isSuffixOf xs ys == (P.pack xs `P.isSuffixOf` P.pack ys)+prop_suffixLL xs ys = isSuffixOf xs ys == (L.pack xs `L.isSuffixOf` L.pack ys) prop_copyBB xs = let p = P.pack xs in P.copy p == p+prop_copyLL xs = let p = L.pack xs in L.copy p == p prop_initsBB xs = inits xs == map P.unpack (P.inits (P.pack xs)) @@ -841,6 +1123,35 @@ naive_findSubstrings :: String -> String -> [Int] naive_findSubstrings p s = [x | x <- [0..length s], p `isPrefixOf` drop x s] +prop_findSubstringBB s x l+ = C.findSubstring (C.pack p) (C.pack s) == naive_findSubstring p s+ where+ _ = l :: Int+ _ = x :: Int++ -- we look for some random substring of the test string+ p = take (model l) $ drop (model x) s++ -- naive reference implementation+ naive_findSubstring :: String -> String -> Maybe Int+ naive_findSubstring p s = listToMaybe [x | x <- [0..length s], p `isPrefixOf` drop x s]++-- correspondance between break and breakSubstring+prop_breakSubstringBB c l+ = P.break (== c) l == P.breakSubstring (P.singleton c) l++prop_breakSubstring_isInfixOf s l+ = P.isInfixOf s l == if P.null s then True+ else case P.breakSubstring s l of+ (x,y) | P.null y -> False+ | otherwise -> True++prop_breakSubstring_findSubstring s l+ = P.findSubstring s l == if P.null s then Just 0+ else case P.breakSubstring s l of+ (x,y) | P.null y -> Nothing+ | otherwise -> Just (P.length x)+ prop_replicate1BB n c = P.unpack (P.replicate n c) == replicate n c prop_replicate2BB n c = P.replicate n c == fst (P.unfoldrN n (\u -> Just (u,u)) c) @@ -849,6 +1160,9 @@ prop_readintBB n = (fst . fromJust . C.readInt . C.pack . show) n == (n :: Int) prop_readintLL n = (fst . fromJust . D.readInt . D.pack . show) n == (n :: Int) +prop_readBB x = (read . show) x == (x :: P.ByteString)+prop_readLL x = (read . show) x == (x :: L.ByteString)+ prop_readint2BB s = let s' = filter (\c -> c `notElem` ['0'..'9']) s in C.readInt (C.pack s') == Nothing@@ -870,9 +1184,12 @@ -- prop_joinjoinpathBB xs ys c = C.joinWithChar c xs ys == C.join (C.singleton c) [xs,ys] prop_zipBB xs ys = zip xs ys == P.zip (P.pack xs) (P.pack ys)+prop_zipLC xs ys = zip xs ys == LC.zip (LC.pack xs) (LC.pack ys) prop_zip1BB xs ys = P.zip xs ys == zip (P.unpack xs) (P.unpack ys) prop_zipWithBB xs ys = P.zipWith (,) xs ys == P.zip xs ys+prop_zipWithCC xs ys = C.zipWith (,) xs ys == C.zip xs ys+prop_zipWithLC xs ys = LC.zipWith (,) xs ys == LC.zip xs ys -- prop_zipWith'BB xs ys = P.pack (P.zipWith (+) xs ys) == P.zipWith' (+) xs ys prop_unzipBB x = let (xs,ys) = unzip x in (P.pack xs, P.pack ys) == P.unzip x@@ -882,6 +1199,7 @@ -- And check fusion RULES. -- +{- prop_lazylooploop em1 em2 start1 start2 arr = loopL em2 start2 (loopArr (loopL em1 start1 arr)) == loopSndAcc (loopL (em1 `fuseEFL` em2) (start1 :*: start2) arr)@@ -1075,6 +1393,8 @@ where _ = acc1 :: Int -} +-}+ -- prop_zipwith_spec f p q = -- P.pack (P.zipWith f p q) == P.zipWith' f p q -- where _ = f :: Word8 -> Word8 -> Word8@@ -1088,17 +1408,201 @@ -- prop_span_spec x s = -- P.span ((==) x) s == P.spanByte x s +------------------------------------------------------------------------ +-- Test IsString+prop_isstring x = C.unpack (fromString x :: C.ByteString) == x+prop_isstring_lc x = LC.unpack (fromString x :: LC.ByteString) == x+ ------------------------------------------------------------------------+-- Unsafe functions++-- Test unsafePackAddress+prop_unsafePackAddress x = unsafePerformIO $ do+ let (p,_,_) = P.toForeignPtr (x `P.snoc` 0)+ y <- withForeignPtr p $ \(Ptr addr) ->+ P.unsafePackAddress addr+ return (y == x)++-- Test unsafePackAddressLen+prop_unsafePackAddressLen x = unsafePerformIO $ do+ let i = P.length x+ (p,_,_) = P.toForeignPtr (x `P.snoc` 0)+ y <- withForeignPtr p $ \(Ptr addr) ->+ P.unsafePackAddressLen i addr+ return (y == x)++prop_unsafeUseAsCString x = unsafePerformIO $ do+ let n = P.length x+ y <- P.unsafeUseAsCString x $ \cstr ->+ sequence [ do a <- peekElemOff cstr i+ let b = x `P.index` i+ return (a == fromIntegral b)+ | i <- [0.. n-1] ]+ return (and y)++prop_unsafeUseAsCStringLen x = unsafePerformIO $ do+ let n = P.length x+ y <- P.unsafeUseAsCStringLen x $ \(cstr,_) ->+ sequence [ do a <- peekElemOff cstr i+ let b = x `P.index` i+ return (a == fromIntegral b)+ | i <- [0.. n-1] ]+ return (and y)++prop_internal_invariant x = LP.invariant x++prop_useAsCString x = unsafePerformIO $ do+ let n = P.length x+ y <- P.useAsCString x $ \cstr ->+ sequence [ do a <- peekElemOff cstr i+ let b = x `P.index` i+ return (a == fromIntegral b)+ | i <- [0.. n-1] ]+ return (and y)++prop_packCString x = unsafePerformIO $ do+ y <- P.useAsCString x $ P.unsafePackCString+ return (y == x)++prop_packCString_safe x = unsafePerformIO $ do+ y <- P.useAsCString x $ P.packCString+ return (y == x)++prop_packCStringLen x = unsafePerformIO $ do+ y <- P.useAsCStringLen x $ P.unsafePackCStringLen+ return (y == x && P.length y == P.length x)++prop_packCStringLen_safe x = unsafePerformIO $ do+ y <- P.useAsCStringLen x $ P.packCStringLen+ return (y == x && P.length y == P.length x)++prop_packMallocCString x = unsafePerformIO $ do++ let (fp,_,_) = P.toForeignPtr x+ ptr <- mallocArray0 (P.length x) :: IO (Ptr Word8)+ forM_ [0 .. P.length x] $ \n -> pokeElemOff ptr n 0+ withForeignPtr fp $ \qtr -> copyArray ptr qtr (P.length x)+ y <- P.unsafePackMallocCString (castPtr ptr)++ let !z = y == x+ free ptr `seq` return z++prop_unsafeFinalize x = unsafePerformIO $ do+ x <- P.unsafeFinalize x+ return (x == ())++prop_packCStringFinaliser x = unsafePerformIO $ do+ y <- P.useAsCString x $ \cstr -> P.unsafePackCStringFinalizer (castPtr cstr) (P.length x) (return ())+ return (y == x)++prop_show x = show x == show (C.unpack x)++prop_fromForeignPtr x = (let (a,b,c) = (P.toForeignPtr x)+ in P.fromForeignPtr a b c) == x++------------------------------------------------------------------------+-- IO++prop_read_write_file_P x = unsafePerformIO $ do+ tid <- myThreadId+ let f = "qc-test-"++show tid+ bracket+ (do P.writeFile f x)+ (const $ do removeFile f)+ (const $ do y <- P.readFile f+ return (x==y))++prop_read_write_file_C x = unsafePerformIO $ do+ tid <- myThreadId+ let f = "qc-test-"++show tid+ bracket+ (do C.writeFile f x)+ (const $ do removeFile f)+ (const $ do y <- C.readFile f+ return (x==y))++prop_read_write_file_L x = unsafePerformIO $ do+ tid <- myThreadId+ let f = "qc-test-"++show tid+ bracket+ (do L.writeFile f x)+ (const $ do removeFile f)+ (const $ do y <- L.readFile f+ return (x==y))++prop_read_write_file_D x = unsafePerformIO $ do+ tid <- myThreadId+ let f = "qc-test-"++show tid+ bracket+ (do D.writeFile f x)+ (const $ do removeFile f)+ (const $ do y <- D.readFile f+ return (x==y))++------------------------------------------------------------------------++prop_append_file_P x y = unsafePerformIO $ do+ tid <- myThreadId+ let f = "qc-test-"++show tid+ bracket+ (do P.writeFile f x+ P.appendFile f y)+ (const $ do removeFile f)+ (const $ do z <- P.readFile f+ return (z==(x `P.append` y)))++prop_append_file_C x y = unsafePerformIO $ do+ tid <- myThreadId+ let f = "qc-test-"++show tid+ bracket+ (do C.writeFile f x+ C.appendFile f y)+ (const $ do removeFile f)+ (const $ do z <- C.readFile f+ return (z==(x `C.append` y)))++prop_append_file_L x y = unsafePerformIO $ do+ tid <- myThreadId+ let f = "qc-test-"++show tid+ bracket+ (do L.writeFile f x+ L.appendFile f y)+ (const $ do removeFile f)+ (const $ do z <- L.readFile f+ return (z==(x `L.append` y)))++prop_append_file_D x y = unsafePerformIO $ do+ tid <- myThreadId+ let f = "qc-test-"++show tid+ bracket+ (do D.writeFile f x+ D.appendFile f y)+ (const $ do removeFile f)+ (const $ do z <- D.readFile f+ return (z==(x `D.append` y)))++prop_packAddress = C.pack "this is a test" + ==+ C.pack "this is a test" ++prop_isSpaceWord8 (w :: Word8) = isSpace c == P.isSpaceChar8 c+ where c = chr (fromIntegral w)+ ++------------------------------------------------------------------------ -- The entry point +main :: IO () main = run tests -run :: [(String, Int -> IO ())] -> IO ()+run :: [(String, Int -> IO (Bool,Int))] -> IO () run tests = do x <- getArgs let n = if null x then 100 else read . head $ x- mapM_ (\(s,a) -> printf "%-25s: " s >> a n) tests+ (results, passed) <- liftM unzip $ mapM (\(s,a) -> printf "%-40s: " s >> a n) tests+ printf "Passed %d tests!\n" (sum passed)+ when (not . and $ results) $ fail "Not all tests passed!" -- -- And now a list of all the properties to test.@@ -1106,14 +1610,50 @@ tests = misc_tests ++ bl_tests+ ++ cc_tests ++ bp_tests ++ pl_tests ++ bb_tests ++ ll_tests- ++ fusion_tests+ ++ io_tests+ ++ rules +--+-- 'morally sound' IO+--+io_tests =+ [("readFile.writeFile", mytest prop_read_write_file_P)+ ,("readFile.writeFile", mytest prop_read_write_file_C)+ ,("readFile.writeFile", mytest prop_read_write_file_L)+ ,("readFile.writeFile", mytest prop_read_write_file_D)++ ,("appendFile ", mytest prop_append_file_P)+ ,("appendFile ", mytest prop_append_file_C)+ ,("appendFile ", mytest prop_append_file_L)+ ,("appendFile ", mytest prop_append_file_D)++ ,("packAddress ", mytest prop_packAddress)++ ]+ misc_tests =- [("invariant", mytest prop_invariant)]+ [("invariant", mytest prop_invariant)+ ,("unsafe pack address", mytest prop_unsafePackAddress)+ ,("unsafe pack address len",mytest prop_unsafePackAddressLen)+ ,("unsafeUseAsCString", mytest prop_unsafeUseAsCString)+ ,("unsafeUseAsCStringLen", mytest prop_unsafeUseAsCStringLen)+ ,("useAsCString", mytest prop_useAsCString)+ ,("packCString", mytest prop_packCString)+ ,("packCString safe", mytest prop_packCString_safe)+ ,("packCStringLen", mytest prop_packCStringLen)+ ,("packCStringLen safe", mytest prop_packCStringLen_safe)+ ,("packCStringFinaliser", mytest prop_packCStringFinaliser)+ ,("packMallocString", mytest prop_packMallocCString)+ ,("unsafeFinalise", mytest prop_unsafeFinalize)+ ,("invariant", mytest prop_internal_invariant)+ ,("show", mytest prop_show)+ ,("fromForeignPtr", mytest prop_fromForeignPtr)+ ] ------------------------------------------------------------------------ -- ByteString.Lazy <=> List@@ -1138,7 +1678,16 @@ ,("foldr1", mytest prop_foldr1BL) ,("mapAccumL", mytest prop_mapAccumLBL) ,("mapAccumR", mytest prop_mapAccumRBL)+ ,("mapAccumR", mytest prop_mapAccumRDL)+ ,("mapAccumR", mytest prop_mapAccumRCC) ,("unfoldr", mytest prop_unfoldrBL)+ ,("unfoldr", mytest prop_unfoldrLC)+ ,("unfoldr", mytest prop_cycleLC)+ ,("iterate", mytest prop_iterateLC)+ ,("iterate", mytest prop_iterateLC_2)+ ,("iterate", mytest prop_iterateL)+ ,("repeat", mytest prop_repeatLC)+ ,("repeat", mytest prop_repeatL) ,("head", mytest prop_headBL) ,("init", mytest prop_initBL) ,("isPrefixOf", mytest prop_isPrefixOfBL)@@ -1174,6 +1723,65 @@ ------------------------------------------------------------------------ -- ByteString.Lazy <=> ByteString +cc_tests =+ [("prop_concatCC", mytest prop_concatCC)+ ,("prop_nullCC", mytest prop_nullCC)+ ,("prop_reverseCC", mytest prop_reverseCC)+ ,("prop_transposeCC", mytest prop_transposeCC)+ ,("prop_groupCC", mytest prop_groupCC)+ ,("prop_initsCC", mytest prop_initsCC)+ ,("prop_tailsCC", mytest prop_tailsCC)+ ,("prop_allCC", mytest prop_allCC)+ ,("prop_anyCC", mytest prop_anyCC)+ ,("prop_appendCC", mytest prop_appendCC)+ ,("prop_breakCC", mytest prop_breakCC)+ ,("prop_concatMapCC", mytest prop_concatMapCC)+ ,("prop_consCC", mytest prop_consCC)+ ,("prop_unconsCC", mytest prop_unconsCC)+ ,("prop_countCC", mytest prop_countCC)+ ,("prop_dropCC", mytest prop_dropCC)+ ,("prop_dropWhileCC", mytest prop_dropWhileCC)+ ,("prop_filterCC", mytest prop_filterCC)+ ,("prop_findCC", mytest prop_findCC)+ ,("prop_findIndexCC", mytest prop_findIndexCC)+ ,("prop_findIndicesCC", mytest prop_findIndicesCC)+ ,("prop_isPrefixOfCC", mytest prop_isPrefixOfCC)+ ,("prop_mapCC", mytest prop_mapCC)+ ,("prop_replicateCC", mytest prop_replicateCC)+ ,("prop_snocCC", mytest prop_snocCC)+ ,("prop_spanCC", mytest prop_spanCC)+ ,("prop_splitCC", mytest prop_splitCC)+ ,("prop_splitAtCC", mytest prop_splitAtCC)+ ,("prop_takeCC", mytest prop_takeCC)+ ,("prop_takeWhileCC", mytest prop_takeWhileCC)+ ,("prop_elemCC", mytest prop_elemCC)+ ,("prop_notElemCC", mytest prop_notElemCC)+ ,("prop_elemIndexCC", mytest prop_elemIndexCC)+ ,("prop_elemIndicesCC", mytest prop_elemIndicesCC)+ ,("prop_lengthCC", mytest prop_lengthCC)+ ,("prop_headCC", mytest prop_headCC)+ ,("prop_initCC", mytest prop_initCC)+ ,("prop_lastCC", mytest prop_lastCC)+ ,("prop_maximumCC", mytest prop_maximumCC)+ ,("prop_minimumCC", mytest prop_minimumCC)+ ,("prop_tailCC", mytest prop_tailCC)+ ,("prop_foldl1CC", mytest prop_foldl1CC)+ ,("prop_foldl1CC'", mytest prop_foldl1CC')+ ,("prop_foldr1CC", mytest prop_foldr1CC)+ ,("prop_foldr1CC'", mytest prop_foldr1CC')+ ,("prop_scanlCC", mytest prop_scanlCC)+ ,("prop_intersperseCC", mytest prop_intersperseCC)++ ,("prop_foldlCC", mytest prop_foldlCC)+ ,("prop_foldlCC'", mytest prop_foldlCC')+ ,("prop_foldrCC", mytest prop_foldrCC)+ ,("prop_foldrCC'", mytest prop_foldrCC')+ ,("prop_mapAccumLCC", mytest prop_mapAccumLCC)+-- ,("prop_mapIndexedCC", mytest prop_mapIndexedCC)+-- ,("prop_mapIndexedPL", mytest prop_mapIndexedPL)++ ]+ bp_tests = [("all", mytest prop_allBP) ,("any", mytest prop_anyBP)@@ -1181,6 +1789,9 @@ ,("compare", mytest prop_compareBP) ,("concat", mytest prop_concatBP) ,("cons", mytest prop_consBP)+ ,("cons'", mytest prop_consBP')+ ,("cons'", mytest prop_consLP')+ ,("uncons", mytest prop_unconsBP) ,("eq", mytest prop_eqBP) ,("filter", mytest prop_filterBP) ,("find", mytest prop_findBP)@@ -1191,9 +1802,14 @@ ,("foldl1", mytest prop_foldl1BP) ,("foldl1'", mytest prop_foldl1BP') ,("foldr", mytest prop_foldrBP)+ ,("foldr'", mytest prop_foldrBP') ,("foldr1", mytest prop_foldr1BP)+ ,("foldr1'", mytest prop_foldr1BP') ,("mapAccumL", mytest prop_mapAccumLBP)+-- ,("mapAccumL", mytest prop_mapAccumL_mapIndexedBP) ,("unfoldr", mytest prop_unfoldrBP)+ ,("unfoldr 2", mytest prop_unfoldr2BP)+ ,("unfoldr 2", mytest prop_unfoldr2CP) ,("head", mytest prop_headBP) ,("init", mytest prop_initBP) ,("isPrefixOf", mytest prop_isPrefixOfBP)@@ -1228,6 +1844,7 @@ ,("notElem", mytest prop_notElemBP) ,("elemIndex", mytest prop_elemIndexBP) ,("elemIndices", mytest prop_elemIndicesBP)+ ,("intersperse", mytest prop_intersperseBP) ,("concatMap", mytest prop_concatMapBP) ] @@ -1243,6 +1860,10 @@ ,("cons", mytest prop_consPL) ,("eq", mytest prop_eqPL) ,("filter", mytest prop_filterPL)+ ,("filter rules",mytest prop_filterPL_rule)+ ,("filter rules",mytest prop_filterLC_rule)+ ,("partition", mytest prop_partitionPL)+ ,("partition", mytest prop_partitionLL) ,("find", mytest prop_findPL) ,("findIndex", mytest prop_findIndexPL) ,("findIndices", mytest prop_findIndicesPL)@@ -1257,8 +1878,11 @@ ,("unfoldr", mytest prop_unfoldrPL) ,("scanl", mytest prop_scanlPL) ,("scanl1", mytest prop_scanl1PL)+ ,("scanl1", mytest prop_scanl1CL)+ ,("scanr", mytest prop_scanrCL) ,("scanr", mytest prop_scanrPL) ,("scanr1", mytest prop_scanr1PL)+ ,("scanr1", mytest prop_scanr1CL) ,("head", mytest prop_headPL) ,("init", mytest prop_initPL) ,("last", mytest prop_lastPL)@@ -1266,11 +1890,18 @@ ,("minimum", mytest prop_minimumPL) ,("tail", mytest prop_tailPL) ,("zip", mytest prop_zipPL)+ ,("zip", mytest prop_zipLL)+ ,("zip", mytest prop_zipCL) ,("unzip", mytest prop_unzipPL)+ ,("unzip", mytest prop_unzipLL)+ ,("unzip", mytest prop_unzipCL) ,("zipWith", mytest prop_zipWithPL)+-- ,("zipWith", mytest prop_zipWithCL)+ ,("zipWith rules", mytest prop_zipWithPL_rules) -- ,("zipWith/zipWith'", mytest prop_zipWithPL') ,("isPrefixOf", mytest prop_isPrefixOfPL)+ ,("isInfixOf", mytest prop_isInfixOfPL) ,("length", mytest prop_lengthPL) ,("map", mytest prop_mapPL) ,("null", mytest prop_nullPL)@@ -1290,10 +1921,13 @@ ,("tails", mytest prop_tailsPL) ,("elem", mytest prop_elemPL) ,("notElem", mytest prop_notElemPL)- ,("lines", mytest prop_linesBL)+ ,("lines", mytest prop_linesPL) ,("elemIndex", mytest prop_elemIndexPL)+ ,("elemIndex", mytest prop_elemIndexCL) ,("elemIndices", mytest prop_elemIndicesPL) ,("concatMap", mytest prop_concatMapPL)+ ,("IsString", mytest prop_isstring)+ ,("IsString LC", mytest prop_isstring_lc) ] ------------------------------------------------------------------------@@ -1305,7 +1939,7 @@ , ("pack/unpack", mytest prop_packunpackBB) , ("unpack/pack", mytest prop_packunpackBB') , ("eq 1", mytest prop_eq1BB)- , ("eq 2", mytest prop_eq3BB)+ , ("eq 2", mytest prop_eq2BB) , ("eq 3", mytest prop_eq3BB) , ("compare 1", mytest prop_compare1BB) , ("compare 2", mytest prop_compare2BB)@@ -1314,9 +1948,15 @@ , ("compare 5", mytest prop_compare5BB) , ("compare 6", mytest prop_compare6BB) , ("compare 7", mytest prop_compare7BB)+ , ("compare 7", mytest prop_compare7LL) , ("compare 8", mytest prop_compare8BB) , ("empty 1", mytest prop_nil1BB) , ("empty 2", mytest prop_nil2BB)+ , ("empty 1 monoid", mytest prop_nil1LL_monoid)+ , ("empty 2 monoid", mytest prop_nil2LL_monoid)+ , ("empty 1 monoid", mytest prop_nil1BB_monoid)+ , ("empty 2 monoid", mytest prop_nil2BB_monoid)+ , ("null", mytest prop_nullBB) , ("length 1", mytest prop_lengthBB) , ("length 2", mytest prop_lengthSBB)@@ -1336,13 +1976,17 @@ , ("append 1", mytest prop_append1BB) , ("append 2", mytest prop_append2BB) , ("append 3", mytest prop_append3BB)+ , ("mappend 1", mytest prop_append1BB_monoid)+ , ("mappend 2", mytest prop_append2BB_monoid)+ , ("mappend 3", mytest prop_append3BB_monoid)+ , ("map 1", mytest prop_map1BB) , ("map 2", mytest prop_map2BB) , ("map 3", mytest prop_map3BB) , ("filter1", mytest prop_filter1BB) , ("filter2", mytest prop_filter2BB)- , ("map fusion", mytest prop_mapfusionBB)- , ("filter fusion", mytest prop_filterfusionBB)+-- , ("map fusion", mytest prop_mapfusionBB)+-- , ("filter fusion", mytest prop_filterfusionBB) , ("reverse 1", mytest prop_reverse1BB) , ("reverse 2", mytest prop_reverse2BB) , ("reverse 3", mytest prop_reverse3BB)@@ -1363,21 +2007,35 @@ , ("drop", mytest prop_dropBB) , ("takeWhile", mytest prop_takeWhileBB) , ("dropWhile", mytest prop_dropWhileBB)+ , ("dropWhile", mytest prop_dropWhileCC_isSpace) , ("splitAt", mytest prop_splitAtBB) , ("span", mytest prop_spanBB) , ("break", mytest prop_breakBB) , ("elem", mytest prop_elemBB) , ("notElem", mytest prop_notElemBB)+ , ("concat 1", mytest prop_concat1BB) , ("concat 2", mytest prop_concat2BB) , ("concat 3", mytest prop_concatBB)+ , ("mconcat 1", mytest prop_concat1BB_monoid)+ , ("mconcat 2", mytest prop_concat2BB_monoid)+ , ("mconcat 3", mytest prop_concatBB_monoid)++ , ("mconcat 1", mytest prop_concat1LL_monoid)+ , ("mconcat 2", mytest prop_concat2LL_monoid)+ , ("mconcat 3", mytest prop_concatLL_monoid)+ , ("lines", mytest prop_linesBB) , ("unlines", mytest prop_unlinesBB)+ , ("unlines", mytest prop_unlinesLC) , ("words", mytest prop_wordsBB)+ , ("words", mytest prop_wordsLC) , ("unwords", mytest prop_unwordsBB) , ("group", mytest prop_groupBB) , ("groupBy", mytest prop_groupByBB)+ , ("groupBy", mytest prop_groupByCC) , ("groupBy 1", mytest prop_groupBy1BB)+ , ("groupBy 1", mytest prop_groupBy1CC) , ("join", mytest prop_joinBB) , ("elemIndex 1", mytest prop_elemIndex1BB) , ("elemIndex 2", mytest prop_elemIndex2BB)@@ -1401,7 +2059,9 @@ -- , ("dropSpace", mytest prop_dropSpaceBB) , ("spanEnd", mytest prop_spanEndBB) , ("breakEnd", mytest prop_breakEndBB)+ , ("breakEnd", mytest prop_breakEndCC) , ("elemIndexEnd 1",mytest prop_elemIndexEnd1BB)+ , ("elemIndexEnd 1",mytest prop_elemIndexEnd1CC) , ("elemIndexEnd 2",mytest prop_elemIndexEnd2BB) -- , ("words'", mytest prop_wordsBB') -- , ("lines'", mytest prop_linesBB')@@ -1409,10 +2069,17 @@ , ("unfoldr", mytest prop_unfoldrBB) , ("prefix", mytest prop_prefixBB) , ("suffix", mytest prop_suffixBB)+ , ("suffix", mytest prop_suffixLL) , ("copy", mytest prop_copyBB)+ , ("copy", mytest prop_copyLL) , ("inits", mytest prop_initsBB) , ("tails", mytest prop_tailsBB) , ("findSubstrings ",mytest prop_findSubstringsBB)+ , ("findSubstring ",mytest prop_findSubstringBB)+ , ("breakSubstring 1",mytest prop_breakSubstringBB)+ , ("breakSubstring 2",mytest prop_breakSubstring_findSubstring)+ , ("breakSubstring 3",mytest prop_breakSubstring_isInfixOf)+ , ("replicate1", mytest prop_replicate1BB) , ("replicate2", mytest prop_replicate2BB) , ("replicate3", mytest prop_replicate3BB)@@ -1420,8 +2087,14 @@ , ("readInt 2", mytest prop_readint2BB) , ("readInteger", mytest prop_readintegerBB) , ("readInteger 2", mytest prop_readinteger2BB)+ , ("read", mytest prop_readLL)+ , ("read", mytest prop_readBB) , ("Lazy.readInt", mytest prop_readintLL)+ , ("Lazy.readInt", mytest prop_readintLL) , ("Lazy.readInteger", mytest prop_readintegerLL)+ , ("mconcat 1", mytest prop_append1LL_monoid)+ , ("mconcat 2", mytest prop_append2LL_monoid)+ , ("mconcat 3", mytest prop_append3LL_monoid) -- , ("filterChar1", mytest prop_filterChar1BB) -- , ("filterChar2", mytest prop_filterChar2BB) -- , ("filterChar3", mytest prop_filterChar3BB)@@ -1447,17 +2120,22 @@ , ("unlines ", mytest prop_unlinesSBB) , ("words ", mytest prop_wordsSBB) , ("unwords ", mytest prop_unwordsSBB)+ , ("unwords ", mytest prop_unwordsSLC) -- , ("wordstokens", mytest prop_wordstokensBB) , ("splitWith", mytest prop_splitWithBB) , ("joinsplit", mytest prop_joinsplitBB)+ , ("intercalate", mytest prop_intercalatePL) -- , ("lineIndices", mytest prop_lineIndices1BB) , ("count", mytest prop_countBB)--- , ("linessplit", mytest prop_linessplitBB)+-- , ("linessplit", mytest prop_linessplit2BB) , ("splitsplitWith", mytest prop_splitsplitWithBB) -- , ("joinjoinpath", mytest prop_joinjoinpathBB) , ("zip", mytest prop_zipBB)+ , ("zip", mytest prop_zipLC) , ("zip1", mytest prop_zip1BB) , ("zipWith", mytest prop_zipWithBB)+ , ("zipWith", mytest prop_zipWithCC)+ , ("zipWith", mytest prop_zipWithLC) -- , ("zipWith'", mytest prop_zipWith'BB) , ("unzip", mytest prop_unzipBB) , ("concatMap", mytest prop_concatMapBB)@@ -1469,6 +2147,7 @@ ------------------------------------------------------------------------ -- Fusion rules +{- fusion_tests = -- v1 fusion [ ("lazy loop/loop fusion", mytest prop_lazylooploop)@@ -1512,7 +2191,9 @@ -- ,("zipwith/spec", mytest prop_zipwith_spec) ] +-} + ------------------------------------------------------------------------ -- Extra lazy properties @@ -1586,16 +2267,22 @@ ,("dropWhile", mytest prop_dropWhile) ,("break", mytest prop_break) ,("span", mytest prop_span)+ ,("splitAt", mytest prop_splitAt) ,("break/span", mytest prop_breakspan) -- ,("break/breakByte", mytest prop_breakByte) -- ,("span/spanByte", mytest prop_spanByte) ,("split", mytest prop_split) ,("splitWith", mytest prop_splitWith)+ ,("splitWith", mytest prop_splitWith_D)+ ,("splitWith", mytest prop_splitWith_C) ,("join.split/id", mytest prop_joinsplit) -- ,("join/joinByte", mytest prop_joinjoinByte) ,("group", mytest prop_group) ,("groupBy", mytest prop_groupBy)+ ,("groupBy", mytest prop_groupBy_LC) ,("index", mytest prop_index)+ ,("index", mytest prop_index_D)+ ,("index", mytest prop_index_C) ,("elemIndex", mytest prop_elemIndex) ,("elemIndices", mytest prop_elemIndices) ,("count/elemIndices", mytest prop_count)@@ -1612,4 +2299,5 @@ -- ,("filterNotByte 2", mytest prop_filterNotByte2) ,("isPrefixOf", mytest prop_isPrefixOf) ,("concatMap", mytest prop_concatMap)+ ,("isSpace", mytest prop_isSpaceWord8) ]
tests/QuickCheckUtils.hs view
@@ -9,6 +9,7 @@ import Text.Show.Functions import Control.Monad ( liftM2 )+import Control.Monad.Instances import Data.Char import Data.List import Data.Word@@ -19,24 +20,53 @@ import Data.ByteString.Fusion import qualified Data.ByteString as P import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Lazy.Internal as L (ByteString(..))+import qualified Data.ByteString.Lazy.Internal as L (checkInvariant,ByteString(..)) import qualified Data.ByteString.Char8 as PC import qualified Data.ByteString.Lazy.Char8 as LC +{-++-- HUGS needs: ++instance Functor ((->) r) where+ fmap = (.)++instance (Arbitrary a) => Arbitrary (Maybe a) where+ arbitrary = sized arbMaybe+ where+ arbMaybe 0 = return Nothing+ arbMaybe n = fmap Just (resize (n-1) arbitrary)+ coarbitrary Nothing = variant 0+ coarbitrary (Just x) = variant 1 . coarbitrary x++instance Monad ((->) r) where+ return = const+ f >>= k = \ r -> k (f r) r++instance Functor ((,) a) where+ fmap f (x,y) = (x, f y)++instance Functor (Either a) where+ fmap _ (Left x) = Left x+ fmap f (Right y) = Right (f y)++-}+ -- Enable this to get verbose test output. Including the actual tests. debug = False -mytest :: Testable a => a -> Int -> IO ()+mytest :: Testable a => a -> Int -> IO (Bool, Int) mytest a n = mycheck defaultConfig { configMaxTest=n , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a -mycheck :: Testable a => Config -> a -> IO ()+mycheck :: Testable a => Config -> a -> IO (Bool, Int) mycheck config a = do rnd <- newStdGen mytests config (evaluate a) rnd 0 0 [] +{- mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () mytests config gen rnd0 ntest nfail stamps | ntest == configMaxTest config = do done "OK," ntest stamps@@ -57,7 +87,29 @@ where result = generate (configSize config ntest) rnd2 gen (rnd1,rnd2) = split rnd0+-} +mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO (Bool, Int)+mytests config gen rnd0 ntest nfail stamps+ | ntest == configMaxTest config = done "OK," ntest stamps >> return (True, ntest)+ | nfail == configMaxFail config = done "Arguments exhausted after" ntest stamps >> return (True, ntest)+ | otherwise =+ do putStr (configEvery config ntest (arguments result)) >> hFlush stdout+ case ok result of+ Nothing ->+ mytests config gen rnd1 ntest (nfail+1) stamps+ Just True ->+ mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps)+ Just False ->+ putStr ( "Falsifiable after "+ ++ show ntest+ ++ " tests:\n"+ ++ unlines (arguments result)+ ) >> hFlush stdout >> return (False, ntest)+ where+ result = generate (configSize config ntest) rnd2 gen+ (rnd1,rnd2) = split rnd0+ done :: String -> Int -> [[String]] -> IO () done mesg ntest stamps = do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )@@ -89,9 +141,11 @@ arbitrary = choose ('\0','\255') coarbitrary c = variant (ord c `rem` 4) +{- instance (Arbitrary a, Arbitrary b) => Arbitrary (PairS a b) where arbitrary = liftM2 (:*:) arbitrary arbitrary coarbitrary (a :*: b) = coarbitrary a . coarbitrary b+-} instance Arbitrary Word8 where arbitrary = choose (97, 105)@@ -101,10 +155,12 @@ arbitrary = sized $ \n -> choose (-fromIntegral n,fromIntegral n) coarbitrary n = variant (fromIntegral (if n >= 0 then 2*n else 2*(-n) + 1)) +{- instance Arbitrary a => Arbitrary (MaybeS a) where arbitrary = do a <- arbitrary ; elements [NothingS, JustS a] coarbitrary NothingS = variant 0 coarbitrary _ = variant 1 -- ok?+-} {- instance Arbitrary Char where@@ -130,7 +186,7 @@ (x,g) -> (fromIntegral x, g) instance Arbitrary L.ByteString where- arbitrary = arbitrary >>= return . L.fromChunks . filter (not. P.null) -- maintain the invariant.+ arbitrary = arbitrary >>= return . L.checkInvariant . L.fromChunks . filter (not. P.null) -- maintain the invariant. coarbitrary s = coarbitrary (L.unpack s) instance Arbitrary P.ByteString where@@ -168,14 +224,18 @@ instance Model P [Char] where model = PC.unpack instance Model B [W] where model = L.unpack . checkInvariant instance Model B [Char] where model = LC.unpack . checkInvariant+instance Model Char Word8 where model = fromIntegral . ord -- Types are trivially modeled by themselves instance Model Bool Bool where model = id instance Model Int Int where model = id+instance Model P P where model = id+instance Model B B where model = id instance Model Int64 Int64 where model = id instance Model Int64 Int where model = fromIntegral instance Model Word8 Word8 where model = id instance Model Ordering Ordering where model = id+instance Model Char Char where model = id -- More structured types are modeled recursively, using the NatTrans class from Gofer. class (Functor f, Functor g) => NatTrans f g where@@ -185,6 +245,8 @@ instance NatTrans [] [] where eta = id instance NatTrans Maybe Maybe where eta = id instance NatTrans ((->) X) ((->) X) where eta = id+instance NatTrans ((->) Char) ((->) Char) where eta = id+ instance NatTrans ((->) W) ((->) W) where eta = id -- We have a transformation of pairs, if the pairs are in Model@@ -197,11 +259,7 @@ -- In a form more useful for QC testing (and it's lazy) checkInvariant :: L.ByteString -> L.ByteString-checkInvariant cs0 = check cs0- where check L.Empty = L.Empty- check (L.Chunk c cs)- | P.null c = error ("invariant violation: " ++ show cs0)- | otherwise = L.Chunk c (check cs)+checkInvariant = L.checkInvariant abstr :: L.ByteString -> P.ByteString abstr = P.concat . L.toChunks
+ tests/Rules.hs view
@@ -0,0 +1,32 @@+module Rules where+--+-- Tests to ensure rules are firing.+--++import qualified Data.ByteString.Char8 as C+import qualified Data.ByteString as P+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as D+import Data.List+import Data.Char+import QuickCheckUtils+++prop_break_C x = C.break ((==) x) `eq1` break ((==) x)+prop_break_P x = P.break ((==) x) `eq1` break ((==) x)+prop_intercalate_P c = (\s1 s2 -> P.intercalate (P.singleton c) (s1 : s2 : []))+ `eq2`+ (\s1 s2 -> intercalate [c] (s1 : s2 : []))++prop_break_isSpace_C = C.break isSpace `eq1` break isSpace+prop_dropWhile_isSpace_C = C.dropWhile isSpace `eq1` dropWhile isSpace++rules =+ [("break (==)" , mytest prop_break_C)+ ,("break (==)" , mytest prop_break_P)+ ,("break isSpace" , mytest prop_break_isSpace_C)++ ,("dropWhile isSpace" , mytest prop_dropWhile_isSpace_C)++ ,("intercalate " , mytest prop_intercalate_P)+ ]
+ tests/Words.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE BangPatterns #-}++import System.Environment+import Control.Applicative+import Data.List+import Data.Ord+import qualified Data.Map as M+import qualified Data.ByteString.Char8 as S++import Data.ByteString.Internal+import Data.ByteString.Unsafe+import Foreign++main = do+ f <- head <$> getArgs+ x <- S.readFile f+ let t = foldl' count M.empty (S.words x) :: M.Map S.ByteString Int+ print . take 20 . sortBy (flip (comparing snd)) . M.toList $ t++count counts word = M.insertWith' (+) (word) 1 counts++++++++------------------------------------------------------------------------+-- a different Ord++newtype OrdString = OrdString S.ByteString+ deriving (Eq, Show)++instance Ord OrdString where+ compare (OrdString p) (OrdString q) = compareBytes p q++compareBytes :: ByteString -> ByteString -> Ordering+compareBytes (PS fp1 off1 len1) (PS fp2 off2 len2)+ | len1 == 0 && len2 == 0 = EQ -- short cut for empty strings+ | fp1 == fp2 && off1 == off2 && len1 == len2 = EQ -- short cut for the same string+-- | max len1 len2 > 1 = inlinePerformIO $+ | otherwise = inlinePerformIO $+ withForeignPtr fp1 $ \p1 ->+ withForeignPtr fp2 $ \p2 -> do+ i <- memcmp (p1 `plusPtr` off1) (p2 `plusPtr` off2) (fromIntegral $ min len1 len2)+ return $! case i `compare` 0 of+ EQ -> len1 `compare` len2+ x -> x+++{-+ | otherwise = inlinePerformIO $+ withForeignPtr fp1 $ \p1 ->+ withForeignPtr fp2 $ \p2 ->+ cmp (p1 `plusPtr` off1)+ (p2 `plusPtr` off2) 0 len1 len2+-}++-- XXX todo.+cmp :: Ptr Word8 -> Ptr Word8 -> Int -> Int -> Int-> IO Ordering+cmp p1 p2 n len1 len2+ | n == len1 = if n == len2 then return EQ else return LT+ | n == len2 = return GT+ | otherwise = do+ a <- peekByteOff p1 n :: IO Word8+ b <- peekByteOff p2 n+ case a `compare` b of+ EQ -> cmp p1 p2 (n+1) len1 len2+ LT -> return LT+ GT -> return GT
+ tests/pack.hs view
@@ -0,0 +1,3 @@+import Data.ByteString.Char8++main = print ("abcdef" :: ByteString)
tests/revcomp.hs view
@@ -6,7 +6,9 @@ -- import GHC.Base import Data.Char-import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Unsafe as B+import qualified Data.ByteString.Internal as B main = B.getContents >>= process B.empty [] @@ -16,8 +18,8 @@ | x == '>' = write h b >> process h' [] ps' | x == '\n' = process h b xs | otherwise = process h ((complement . toUpper $ x) : b) xs- where (x,xs) = (B.unsafeHead ps, B.unsafeTail ps)- (h',ps') = B.breakOn '\n' ps+ where (x,xs) = (B.w2c (B.unsafeHead ps), B.unsafeTail ps)+ (h',ps') = B.break (=='\n') ps write h s | B.null h = return ()
+ tests/test-compare.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE BangPatterns #-}++import qualified Data.ByteString.Char8 as S+import Data.ByteString.Internal+import Data.ByteString.Unsafe+import Foreign+import Control.Monad+import System.Environment+import System.CPUTime+import Text.Printf+import Foreign.ForeignPtr++time :: Show t => IO t -> IO t+time a = do+ start <- getCPUTime+ v <- a+ v `seq` return ()+ end <- getCPUTime+ print v+ let diff = (fromIntegral (end - start)) / (10^12)+ printf "Computation time: %0.3f sec\n" (diff :: Double)+ return v++main = do+ [f,g,n,m] <- getArgs+ x <- S.readFile f+ y <- S.readFile g+ forM_ [read n .. read m] $ \i -> do+ print i+ time (-- replicateM_ 100000000 $+ return $ S.take i x `compareBytes` S.take i y+ )+ time (-- replicateM_ 100000000 $+ return $ S.take i x `compareBytesC` S.take i y+ )++------------------------------------------------------------------------++compareBytes :: ByteString -> ByteString -> Ordering+compareBytes (PS fp1 off1 len1) (PS fp2 off2 len2)+-- | len1 == 0 && len2 == 0 = EQ -- short cut for empty strings+-- | fp1 == fp2 && off1 == off2 && len1 == len2 = EQ -- short cut for the same string+ | otherwise = 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+cmp p1 p2 n len1 len2+ | n == len1 = if n == len2 then return EQ else return LT+ | n == len2 = return GT+ | otherwise = do+ a <- peekByteOff p1 n :: IO Word8+ b <- peekByteOff p2 n+ case a `compare` b of+ EQ -> cmp p1 p2 (n+1) len1 len2+ LT -> return LT+ GT -> return GT+ +compareBytesC (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 #-}+