diff --git a/Data/ByteString.hs b/Data/ByteString.hs --- a/Data/ByteString.hs +++ b/Data/ByteString.hs @@ -1,8 +1,8 @@ {-# LANGUAGE CPP #-} --- We cannot actually specify all the language pragmas, see ghc ticket # --- If we could, these are what they would be: -{- LANGUAGE MagicHash, UnboxedTuples, - NamedFieldPuns, BangPatterns, RecordWildCards -} +#if __GLASGOW_HASKELL__ +{-# LANGUAGE MagicHash, UnboxedTuples, + NamedFieldPuns, BangPatterns, RecordWildCards #-} +#endif {-# OPTIONS_HADDOCK prune #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} @@ -12,18 +12,14 @@ -- Module : Data.ByteString -- Copyright : (c) The University of Glasgow 2001, -- (c) David Roundy 2003-2005, --- (c) Simon Marlow 2005 --- (c) Bjorn Bringert 2006 --- (c) Don Stewart 2005-2008 --- --- Array fusion code: --- (c) 2001,2002 Manuel M T Chakravarty & Gabriele Keller --- (c) 2006 Manuel M T Chakravarty & Roman Leshchinskiy --- +-- (c) Simon Marlow 2005, +-- (c) Bjorn Bringert 2006, +-- (c) Don Stewart 2005-2008, +-- (c) Duncan Coutts 2006-2011 -- License : BSD-style -- --- Maintainer : dons@cse.unsw.edu.au --- Stability : experimental +-- Maintainer : dons00@gmail.com, duncan@community.haskell.org +-- Stability : stable -- Portability : portable -- -- A time and space-efficient implementation of byte vectors using @@ -40,7 +36,7 @@ -- Original GHC implementation by Bryan O\'Sullivan. -- Rewritten to use 'Data.Array.Unboxed.UArray' by Simon Marlow. -- Rewritten to support slices and use 'ForeignPtr' by David Roundy. --- Polished and extended by Don Stewart. +-- Rewritten again and extended by Don Stewart and Duncan Coutts. -- module Data.ByteString ( @@ -229,7 +225,7 @@ -- Control.Exception.assert not available in yhc or nhc #ifndef __NHC__ -import Control.Exception (finally, bracket, assert) +import Control.Exception (finally, bracket, assert, throwIO) #else import Control.Exception (bracket, finally) #endif @@ -249,7 +245,7 @@ ,IOMode(..)) import System.IO.Error (mkIOError, illegalOperationErrorType) -import Data.Monoid (Monoid, mempty, mappend, mconcat) +import Data.Monoid (Monoid(..)) #if !defined(__GLASGOW_HASKELL__) import System.IO.Unsafe @@ -274,7 +270,7 @@ import GHC.IO.Handle.Types import GHC.IO.Buffer import GHC.IO.BufferedIO as Buffered -import GHC.IO (stToIO, unsafePerformIO) +import GHC.IO (unsafePerformIO) import Data.Char (ord) import Foreign.Marshal.Utils (copyBytes) #else @@ -283,11 +279,9 @@ import GHC.Handle #endif -import GHC.Prim (Word#, (+#), writeWord8OffAddr#) +import GHC.Prim (Word#) import GHC.Base (build) import GHC.Word hiding (Word8) -import GHC.Ptr (Ptr(..)) -import GHC.ST (ST(..)) #endif @@ -318,67 +312,6 @@ #define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined -- ----------------------------------------------------------------------------- - -instance Eq ByteString where - (==) = eq - -instance Ord ByteString where - compare = compareBytes - -instance Monoid ByteString where - mempty = empty - mappend = append - mconcat = concat - --- | /O(n)/ Equality on the 'ByteString' type. -eq :: ByteString -> ByteString -> Bool -eq a@(PS p s l) b@(PS p' s' l') - | l /= l' = False -- short cut on length - | p == p' && s == s' = True -- short cut for the same string - | otherwise = compareBytes a b == EQ -{-# INLINE eq #-} --- ^ 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 - | 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 - -{- - --- 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 -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 --} - --- ----------------------------------------------------------------------------- -- Introducing and eliminating 'ByteString's -- | /O(1)/ The empty 'ByteString' @@ -416,40 +349,12 @@ -- For applications with large numbers of string literals, pack can be a -- bottleneck. In such cases, consider using packAddress (GHC only). pack :: [Word8] -> ByteString - -#if !defined(__GLASGOW_HASKELL__) - -pack str = unsafeCreate (P.length str) $ \p -> go p str - where - go _ [] = return () - go p (x:xs) = poke p x >> go (p `plusPtr` 1) xs -- less space than pokeElemOff - -#else /* hack away */ - -pack str = unsafeCreate (P.length str) $ \(Ptr p) -> stToIO (go p 0# str) - where - go _ _ [] = return () - go p i (W8# c:cs) = writeByte p i c >> go p (i +# 1#) cs - - writeByte p i c = ST $ \s# -> - case writeWord8OffAddr# p i c s# of s2# -> (# s2#, () #) - -#endif +pack = packBytes -- | /O(n)/ Converts a 'ByteString' to a '[Word8]'. unpack :: ByteString -> [Word8] - #if !defined(__GLASGOW_HASKELL__) - -unpack (PS _ _ 0) = [] -unpack (PS ps s l) = inlinePerformIO $ withForeignPtr ps $ \p -> - go (p `plusPtr` s) (l - 1) [] - where - STRICT3(go) - go p 0 acc = peek p >>= \e -> return (e : acc) - go p n acc = peekByteOff p n >>= \e -> go p (n-1) (e : acc) -{-# INLINE unpack #-} - +unpack = unpackBytes #else unpack ps = build (unpackFoldr ps) @@ -473,18 +378,9 @@ loop (p `plusPtr` off) (len-1) ch {-# INLINE [0] unpackFoldr #-} -unpackList :: ByteString -> [Word8] -unpackList (PS fp off len) = withPtr fp $ \p -> do - let STRICT3(loop) - loop _ (-1) acc = return acc - loop q n acc = do - a <- peekByteOff q n - loop q (n-1) (a : acc) - loop (p `plusPtr` off) (len-1) [] - {-# RULES "ByteString unpack-list" [1] forall p . - unpackFoldr p (:) [] = unpackList p + unpackFoldr p (:) [] = unpackBytes p #-} #endif @@ -505,6 +401,9 @@ ------------------------------------------------------------------------ +infixr 5 `cons` --same as list (:) +infixl 5 `snoc` + -- | /O(n)/ 'cons' is analogous to (:) for lists, but of different -- complexity, as it requires a memcpy. cons :: Word8 -> ByteString -> ByteString @@ -566,9 +465,7 @@ -- | /O(n)/ Append two ByteStrings append :: ByteString -> ByteString -> ByteString -append xs ys | null xs = ys - | null ys = xs - | otherwise = concat [xs,ys] +append = mappend {-# INLINE append #-} -- --------------------------------------------------------------------- @@ -700,15 +597,7 @@ -- | /O(n)/ Concatenate a list of ByteStrings. concat :: [ByteString] -> ByteString -concat [] = empty -concat [ps] = ps -concat xs = unsafeCreate len $ \ptr -> go xs ptr - where len = P.sum . P.map length $ xs - STRICT2(go) - go [] _ = return () - go (PS p s l:ps) ptr = do - withForeignPtr p $ \fp -> memcpy ptr (fp `plusPtr` s) (fromIntegral l) - go ps (ptr `plusPtr` l) +concat = mconcat -- | Map a function over a 'ByteString' and concatenate the results concatMap :: (Word8 -> ByteString) -> ByteString -> ByteString @@ -1735,7 +1624,7 @@ packCStringLen (cstr, len) | len >= 0 = create len $ \p -> memcpy p (castPtr cstr) (fromIntegral len) packCStringLen (_, len) = - moduleError "packCStringLen" ("negative length: " ++ show len) + moduleErrorIO "packCStringLen" ("negative length: " ++ show len) ------------------------------------------------------------------------ @@ -2112,8 +2001,20 @@ {-# NOINLINE errorEmptyList #-} moduleError :: String -> String -> a -moduleError fun msg = error ("Data.ByteString." ++ fun ++ ':':' ':msg) +moduleError fun msg = error (moduleErrorMsg fun msg) {-# NOINLINE moduleError #-} + +moduleErrorIO :: String -> String -> IO a +moduleErrorIO fun msg = +#if MIN_VERSION_base(4,0,0) + throwIO . userError $ moduleErrorMsg fun msg +#else + throwIO . IOException . userError $ moduleErrorMsg fun msg +#endif +{-# NOINLINE moduleErrorIO #-} + +moduleErrorMsg :: String -> String -> String +moduleErrorMsg fun msg = "Data.ByteString." ++ fun ++ ':':' ':msg -- Find from the end of the string using predicate findFromEndUntil :: (Word8 -> Bool) -> ByteString -> Int diff --git a/Data/ByteString/Char8.hs b/Data/ByteString/Char8.hs --- a/Data/ByteString/Char8.hs +++ b/Data/ByteString/Char8.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} --- We cannot actually specify all the language pragmas, see ghc ticket # --- If we could, these are what they would be: -{- LANGUAGE MagicHash, UnboxedTuples -} +#if __GLASGOW_HASKELL__ +{-# LANGUAGE MagicHash, UnboxedTuples #-} +#endif {-# OPTIONS_HADDOCK prune #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} @@ -10,10 +10,11 @@ -- | -- Module : Data.ByteString.Char8 -- Copyright : (c) Don Stewart 2006-2008 +-- (c) Duncan Coutts 2006-2011 -- License : BSD-style -- --- Maintainer : dons@cse.unsw.edu.au --- Stability : experimental +-- Maintainer : dons00@gmail.com, duncan@community.haskell.org +-- Stability : stable -- Portability : portable -- -- Manipulate 'ByteString's using 'Char' operations. All Chars will be @@ -35,12 +36,12 @@ -- This module is intended to be imported @qualified@, to avoid name -- clashes with "Prelude" functions. eg. -- --- > import qualified Data.ByteString.Char8 as B +-- > import qualified Data.ByteString.Char8 as C -- -- 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. +-- have them implicitly packed to ByteStrings. +-- Use @{-\# LANGUAGE OverloadedStrings \#-}@ to enable this. -- module Data.ByteString.Char8 ( @@ -247,8 +248,7 @@ ,useAsCString,useAsCStringLen ) -import Data.ByteString.Internal (ByteString(PS), c2w, w2c, isSpaceWord8 - ,inlinePerformIO) +import Data.ByteString.Internal import Data.Char ( isSpace ) import qualified Data.List as List (intersperse) @@ -261,22 +261,6 @@ #endif import Foreign -#if defined(__GLASGOW_HASKELL__) -import GHC.Base (Char(..),unpackCString#,ord#,int2Word#) -#if __GLASGOW_HASKELL__ >= 611 -import GHC.IO (stToIO) -#else -import GHC.IOBase (stToIO) -#endif -import GHC.Prim (Addr#,writeWord8OffAddr#,plusAddr#) -import GHC.Ptr (Ptr(..)) -import GHC.ST (ST(..)) -#endif - -#if MIN_VERSION_base(3,0,0) -import Data.String (IsString(..)) -#endif - #define STRICT1(f) f a | a `seq` False = undefined #define STRICT2(f) f a b | a `seq` b `seq` False = undefined #define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined @@ -289,34 +273,14 @@ singleton = B.singleton . c2w {-# INLINE singleton #-} -#if MIN_VERSION_base(3,0,0) -instance IsString ByteString where - fromString = pack - {-# INLINE fromString #-} -#endif - -- | /O(n)/ Convert a 'String' into a 'ByteString' -- -- For applications with large numbers of string literals, pack can be a -- bottleneck. pack :: String -> ByteString -#if !defined(__GLASGOW_HASKELL__) - -pack str = B.unsafeCreate (P.length str) $ \p -> go p str - where go _ [] = return () - go p (x:xs) = poke p (c2w x) >> go (p `plusPtr` 1) xs - -#else /* hack away */ - -pack str = B.unsafeCreate (P.length str) $ \(Ptr p) -> stToIO (go p str) - where - go :: Addr# -> [Char] -> ST a () - go _ [] = return () - go p (C# c:cs) = writeByte p (int2Word# (ord# c)) >> go (p `plusAddr#` 1#) cs +pack = packChars - writeByte p c = ST $ \s# -> - case writeWord8OffAddr# p 0# c s# of s2# -> (# s2#, () #) - {-# INLINE writeByte #-} +#if !defined(__GLASGOW_HASKELL__) {-# INLINE [1] pack #-} {-# RULES @@ -328,8 +292,11 @@ -- | /O(n)/ Converts a 'ByteString' to a 'String'. unpack :: ByteString -> [Char] -unpack = P.map w2c . B.unpack +unpack = B.unpackChars {-# INLINE unpack #-} + +infixr 5 `cons` --same as list (:) +infixl 5 `snoc` -- | /O(n)/ 'cons' is analogous to (:) for lists, but of different -- complexity, as it requires a memcpy. diff --git a/Data/ByteString/Fusion.hs b/Data/ByteString/Fusion.hs deleted file mode 100644 --- a/Data/ByteString/Fusion.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Safe #-} -#endif --- | --- Module : Data.ByteString.Fusion --- License : BSD-style --- Maintainer : dons@cse.unsw.edu.au --- Stability : experimental --- Portability : portable --- --- Stream fusion for ByteStrings. --- --- See the paper /Stream Fusion: From Lists to Streams to Nothing at All/, --- Coutts, Leshchinskiy and Stewart, 2007. --- - -module Data.ByteString.Fusion ( - - -- A place holder for Stream Fusion - - ) where - - diff --git a/Data/ByteString/Internal.hs b/Data/ByteString/Internal.hs --- a/Data/ByteString/Internal.hs +++ b/Data/ByteString/Internal.hs @@ -1,16 +1,18 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} --- We cannot actually specify all the language pragmas, see ghc ticket # --- If we could, these are what they would be: -{- LANGUAGE UnliftedFFITypes, MagicHash, - UnboxedTuples, DeriveDataTypeable -} +{-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns #-} +#if __GLASGOW_HASKELL__ +{-# LANGUAGE UnliftedFFITypes, MagicHash, + UnboxedTuples, DeriveDataTypeable #-} +#endif {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.ByteString.Internal +-- Copyright : (c) Don Stewart 2006-2008 +-- (c) Duncan Coutts 2006-2011 -- License : BSD-style --- Maintainer : Don Stewart --- Stability : experimental --- Portability : portable +-- Maintainer : dons00@gmail.com, duncan@community.haskell.org +-- Stability : unstable +-- Portability : non-portable -- -- A module containing semi-public 'ByteString' internals. This exposes the -- 'ByteString' representation and low level construction functions. As such @@ -25,7 +27,13 @@ -- * The @ByteString@ type and representation ByteString(..), -- instances: Eq, Ord, Show, Read, Data, Typeable - -- * Low level introduction and elimination + -- * Conversion with lists: packing and unpacking + packBytes, packUptoLenBytes, unsafePackLenBytes, + packChars, packUptoLenChars, unsafePackLenChars, + unpackBytes, unpackAppendBytesLazy, unpackAppendBytesStrict, + unpackChars, unpackAppendCharsLazy, unpackAppendCharsStrict, + + -- * Low level imperative construction create, -- :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString createAndTrim, -- :: Int -> (Ptr Word8 -> IO Int) -> IO ByteString createAndTrim', -- :: Int -> (Ptr Word8 -> IO (Int, Int, a)) -> IO (ByteString, a) @@ -45,8 +53,8 @@ c_free_finalizer, -- :: FunPtr (Ptr Word8 -> IO ()) memchr, -- :: Ptr Word8 -> Word8 -> CSize -> IO Ptr Word8 - memcmp, -- :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt - memcpy, -- :: Ptr Word8 -> Ptr Word8 -> CSize -> IO () + memcmp, -- :: Ptr Word8 -> Ptr Word8 -> Int -> IO CInt + memcpy, -- :: Ptr Word8 -> Ptr Word8 -> Int -> IO () memset, -- :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8) -- * cbits functions @@ -65,12 +73,26 @@ ) where +import Prelude hiding (concat) +import qualified Data.List as List + import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) import Foreign.Ptr (Ptr, FunPtr, plusPtr) import Foreign.Storable (Storable(..)) +#if MIN_VERSION_base(4,5,0) || __GLASGOW_HASKELL__ >= 703 import Foreign.C.Types (CInt(..), CSize(..), CULong(..)) +#else +import Foreign.C.Types (CInt, CSize, CULong) +#endif import Foreign.C.String (CString) +import Data.Monoid (Monoid(..)) +import Control.DeepSeq (NFData) + +#if MIN_VERSION_base(3,0,0) +import Data.String (IsString(..)) +#endif + #ifndef __NHC__ import Control.Exception (assert) #endif @@ -78,13 +100,19 @@ import Data.Char (ord) import Data.Word (Word8) -#if defined(__GLASGOW_HASKELL__) import Data.Typeable (Typeable) -#if __GLASGOW_HASKELL__ >= 610 -import Data.Data (Data) +#if MIN_VERSION_base(4,1,0) +import Data.Data (Data(..)) +#if MIN_VERSION_base(4,2,0) +import Data.Data (mkNoRepType) #else -import Data.Generics (Data) +import Data.Data (mkNorepType) #endif +#else +import Data.Generics (Data(..), mkNorepType) +#endif + +#ifdef __GLASGOW_HASKELL__ import GHC.Base (realWorld#,unsafeChr) #if __GLASGOW_HASKELL__ >= 611 import GHC.IO (IO(IO)) @@ -154,42 +182,148 @@ {-# UNPACK #-} !Int -- length #if defined(__GLASGOW_HASKELL__) - deriving (Data, Typeable) + deriving (Typeable) #endif +instance Eq ByteString where + (==) = eq + +instance Ord ByteString where + compare = compareBytes + +instance Monoid ByteString where + mempty = PS nullForeignPtr 0 0 + mappend = append + mconcat = concat + +instance NFData ByteString + instance Show ByteString where - showsPrec p ps r = showsPrec p (unpackWith w2c ps) r + showsPrec p ps r = showsPrec p (unpackChars ps) r instance Read ByteString where - readsPrec p str = [ (packWith c2w x, y) | (x, y) <- readsPrec p str ] + readsPrec p str = [ (packChars x, y) | (x, y) <- readsPrec p str ] --- | /O(n)/ Converts a 'ByteString' to a '[a]', using a conversion function. -unpackWith :: (Word8 -> a) -> ByteString -> [a] -unpackWith _ (PS _ _ 0) = [] -unpackWith k (PS ps s l) = inlinePerformIO $ withForeignPtr ps $ \p -> - go (p `plusPtr` s) (l - 1) [] - where - STRICT3(go) - go p 0 acc = peek p >>= \e -> return (k e : acc) - go p n acc = peekByteOff p n >>= \e -> go p (n-1) (k e : acc) -{-# INLINE unpackWith #-} +#if MIN_VERSION_base(3,0,0) +instance IsString ByteString where + fromString = packChars +#endif --- | /O(n)/ Convert a '[a]' into a 'ByteString' using some --- conversion function -packWith :: (a -> Word8) -> [a] -> ByteString -packWith k str = unsafeCreate (length str) $ \p -> go p str - where - STRICT2(go) - go _ [] = return () - go p (x:xs) = poke p (k x) >> go (p `plusPtr` 1) xs -- less space than pokeElemOff -{-# INLINE packWith #-} +instance Data ByteString where + gfoldl f z txt = z packBytes `f` (unpackBytes txt) + toConstr _ = error "Data.ByteString.ByteString.toConstr" + gunfold _ _ = error "Data.ByteString.ByteString.gunfold" +#if MIN_VERSION_base(4,2,0) + dataTypeOf _ = mkNoRepType "Data.ByteString.ByteString" +#else + dataTypeOf _ = mkNorepType "Data.ByteString.ByteString" +#endif ------------------------------------------------------------------------ +-- Packing and unpacking from lists +packBytes :: [Word8] -> ByteString +packBytes ws = unsafePackLenBytes (List.length ws) ws + +packChars :: [Char] -> ByteString +packChars cs = unsafePackLenChars (List.length cs) cs + +unsafePackLenBytes :: Int -> [Word8] -> ByteString +unsafePackLenBytes len xs0 = + unsafeCreate len $ \p -> go p xs0 + where + go !_ [] = return () + go !p (x:xs) = poke p x >> go (p `plusPtr` 1) xs + +unsafePackLenChars :: Int -> [Char] -> ByteString +unsafePackLenChars len cs0 = + unsafeCreate len $ \p -> go p cs0 + where + go !_ [] = return () + go !p (c:cs) = poke p (c2w c) >> go (p `plusPtr` 1) cs + +packUptoLenBytes :: Int -> [Word8] -> (ByteString, [Word8]) +packUptoLenBytes len xs0 = + unsafeDupablePerformIO $ create' len $ \p -> go p len xs0 + where + go !_ !n [] = return (len-n, []) + go !_ !0 xs = return (len, xs) + go !p !n (x:xs) = poke p x >> go (p `plusPtr` 1) (n-1) xs + +packUptoLenChars :: Int -> [Char] -> (ByteString, [Char]) +packUptoLenChars len cs0 = + unsafeDupablePerformIO $ create' len $ \p -> go p len cs0 + where + go !_ !n [] = return (len-n, []) + go !_ !0 cs = return (len, cs) + go !p !n (c:cs) = poke p (c2w c) >> go (p `plusPtr` 1) (n-1) cs + +-- Unpacking bytestrings into lists effeciently is a tradeoff: on the one hand +-- we would like to write a tight loop that just blats the list into memory, on +-- the other hand we want it to be unpacked lazily so we don't end up with a +-- massive list data structure in memory. +-- +-- Our strategy is to combine both: we will unpack lazily in reasonable sized +-- chunks, where each chunk is unpacked strictly. +-- +-- unpackBytes and unpackChars do the lazy loop, while unpackAppendBytes and +-- unpackAppendChars do the chunks strictly. + +unpackBytes :: ByteString -> [Word8] +unpackBytes bs = unpackAppendBytesLazy bs [] + +unpackChars :: ByteString -> [Char] +unpackChars bs = unpackAppendCharsLazy bs [] + +unpackAppendBytesLazy :: ByteString -> [Word8] -> [Word8] +unpackAppendBytesLazy (PS fp off len) xs + | len <= 100 = unpackAppendBytesStrict (PS fp off len) xs + | otherwise = unpackAppendBytesStrict (PS fp off 100) remainder + where + remainder = unpackAppendBytesLazy (PS fp (off+100) (len-100)) xs + + -- Why 100 bytes you ask? Because on a 64bit machine the list we allocate + -- takes just shy of 4k which seems like a reasonable amount. + -- (5 words per list element, 8 bytes per word, 100 elements = 4000 bytes) + +unpackAppendCharsLazy :: ByteString -> [Char] -> [Char] +unpackAppendCharsLazy (PS fp off len) cs + | len <= 100 = unpackAppendCharsStrict (PS fp off len) cs + | otherwise = unpackAppendCharsStrict (PS fp off 100) remainder + where + remainder = unpackAppendCharsLazy (PS fp (off+100) (len-100)) cs + +-- For these unpack functions, since we're unpacking the whole list strictly we +-- build up the result list in an accumulator. This means we have to build up +-- the list starting at the end. So our traversal starts at the end of the +-- buffer and loops down until we hit the sentinal: + +unpackAppendBytesStrict :: ByteString -> [Word8] -> [Word8] +unpackAppendBytesStrict (PS fp off len) xs = + inlinePerformIO $ withForeignPtr fp $ \base -> do + loop (base `plusPtr` (off-1)) (base `plusPtr` (off-1+len)) xs + where + loop !sentinal !p acc + | p == sentinal = return acc + | otherwise = do x <- peek p + loop sentinal (p `plusPtr` (-1)) (x:acc) + +unpackAppendCharsStrict :: ByteString -> [Char] -> [Char] +unpackAppendCharsStrict (PS fp off len) xs = + inlinePerformIO $ withForeignPtr fp $ \base -> + loop (base `plusPtr` (off-1)) (base `plusPtr` (off-1+len)) xs + where + loop !sentinal !p acc + | p == sentinal = return acc + | otherwise = do x <- peek p + loop sentinal (p `plusPtr` (-1)) (w2c x:acc) + +------------------------------------------------------------------------ + -- | The 0 pointer. Used to indicate the empty Bytestring. nullForeignPtr :: ForeignPtr Word8 #ifdef __GLASGOW_HASKELL__ -nullForeignPtr = ForeignPtr nullAddr# undefined --TODO: should ForeignPtrContents be strict? +nullForeignPtr = ForeignPtr nullAddr# (error "nullForeignPtr") --TODO: should ForeignPtrContents be strict? #else nullForeignPtr = unsafePerformIO $ newForeignPtr_ nullPtr {-# NOINLINE nullForeignPtr #-} @@ -238,6 +372,14 @@ return $! PS fp 0 l {-# INLINE create #-} +-- | Create ByteString of up to size @l@ and use action @f@ to fill it's contents which returns its true size. +create' :: Int -> (Ptr Word8 -> IO (Int, a)) -> IO (ByteString, a) +create' l f = do + fp <- mallocByteString l + (l', res) <- withForeignPtr fp $ \p -> f p + assert (l' <= l) $ return (PS fp 0 l', res) +{-# INLINE create' #-} + -- | Given the maximum size needed and a function to make the contents -- of a ByteString, createAndTrim makes the 'ByteString'. The generating -- function is required to return the actual final size (<= the maximum @@ -253,7 +395,7 @@ l' <- f p if assert (l' <= l) $ l' >= l then return $! PS fp 0 l - else create l' $ \p' -> memcpy p' p (fromIntegral l') + else create l' $ \p' -> memcpy p' p l' {-# INLINE createAndTrim #-} createAndTrim' :: Int -> (Ptr Word8 -> IO (Int, Int, a)) -> IO (ByteString, a) @@ -264,7 +406,7 @@ if assert (l' <= l) $ l' >= l then return $! (PS fp 0 l, res) else do ps <- create l' $ \p' -> - memcpy p' (p `plusPtr` off) (fromIntegral l') + memcpy p' (p `plusPtr` off) l' return $! (ps, res) -- | Wrapper of 'mallocForeignPtrBytes' with faster implementation for GHC @@ -279,7 +421,49 @@ {-# INLINE mallocByteString #-} ------------------------------------------------------------------------ +-- Implementations for Eq, Ord and Monoid instances +eq :: ByteString -> ByteString -> Bool +eq a@(PS fp off len) b@(PS fp' off' len') + | len /= len' = False -- short cut on length + | fp == fp' && off == off' = True -- short cut for the same string + | otherwise = compareBytes a b == EQ +{-# INLINE eq #-} +-- ^ still needed + +compareBytes :: ByteString -> ByteString -> Ordering +compareBytes (PS _ _ 0) (PS _ _ 0) = EQ -- short cut for empty strings +compareBytes (PS fp1 off1 len1) (PS fp2 off2 len2) = + inlinePerformIO $ + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> do + i <- memcmp (p1 `plusPtr` off1) (p2 `plusPtr` off2) (min len1 len2) + return $! case i `compare` 0 of + EQ -> len1 `compare` len2 + x -> x + +append :: ByteString -> ByteString -> ByteString +append (PS _ _ 0) b = b +append a (PS _ _ 0) = a +append (PS fp1 off1 len1) (PS fp2 off2 len2) = + unsafeCreate (len1+len2) $ \destptr1 -> do + let destptr2 = destptr1 `plusPtr` len1 + withForeignPtr fp1 $ \p1 -> memcpy destptr1 (p1 `plusPtr` off1) len1 + withForeignPtr fp2 $ \p2 -> memcpy destptr2 (p2 `plusPtr` off2) len2 + +concat :: [ByteString] -> ByteString +concat [] = mempty +concat [bs] = bs +concat bss0 = unsafeCreate totalLen $ \ptr -> go bss0 ptr + where + totalLen = List.sum [ len | (PS _ _ len) <- bss0 ] + go [] !_ = return () + go (PS fp off len:bss) !ptr = do + withForeignPtr fp $ \p -> memcpy ptr (p `plusPtr` off) len + go bss (ptr `plusPtr` len) + +------------------------------------------------------------------------ + -- | Conversion between 'Word8' and 'Char'. Should compile to a no-op. w2c :: Word8 -> Char #if !defined(__GLASGOW_HASKELL__) @@ -353,14 +537,17 @@ memchr :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8) memchr p w s = c_memchr p (fromIntegral w) s -foreign import ccall unsafe "string.h memcmp" memcmp +foreign import ccall unsafe "string.h memcmp" c_memcmp :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt +memcmp :: Ptr Word8 -> Ptr Word8 -> Int -> IO CInt +memcmp p q s = c_memcmp p q (fromIntegral s) + foreign import ccall unsafe "string.h memcpy" c_memcpy :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8) -memcpy :: Ptr Word8 -> Ptr Word8 -> CSize -> IO () -memcpy p q s = c_memcpy p q s >> return () +memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO () +memcpy p q s = c_memcpy p q (fromIntegral s) >> return () {- foreign import ccall unsafe "string.h memmove" c_memmove diff --git a/Data/ByteString/Lazy.hs b/Data/ByteString/Lazy.hs --- a/Data/ByteString/Lazy.hs +++ b/Data/ByteString/Lazy.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, BangPatterns #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} {-# OPTIONS_HADDOCK prune #-} #if __GLASGOW_HASKELL__ >= 701 @@ -8,30 +8,34 @@ -- | -- Module : Data.ByteString.Lazy -- Copyright : (c) Don Stewart 2006 --- (c) Duncan Coutts 2006 +-- (c) Duncan Coutts 2006-2011 -- License : BSD-style -- --- Maintainer : dons@galois.com --- Stability : experimental +-- Maintainer : dons00@gmail.com, duncan@community.haskell.org +-- Stability : stable -- Portability : portable -- -- A time and space-efficient implementation of lazy byte vectors -- using lists of packed 'Word8' arrays, suitable for high performance -- use, both in terms of large data quantities, or high speed --- requirements. Byte vectors are encoded as lazy lists of strict 'Word8' --- arrays of bytes. They provide a means to manipulate large byte vectors --- without requiring the entire vector be resident in memory. +-- requirements. Lazy ByteStrings are encoded as lazy lists of strict chunks +-- of bytes. -- --- Some operations, such as concat, append, reverse and cons, have +-- A key feature of lazy ByteStrings is the means to manipulate large or +-- unbounded streams of data without requiring the entire sequence to be +-- resident in memory. To take advantage of this you have to write your +-- functions in a lazy streaming style, e.g. classic pipeline composition. The +-- default I\/O chunk size is 32k, which should be good in most circumstances. +-- +-- Some operations, such as 'concat', 'append', 'reverse' and 'cons', have -- better complexity than their "Data.ByteString" equivalents, due to --- optimisations resulting from the list spine structure. And for other +-- optimisations resulting from the list spine structure. For other -- operations lazy ByteStrings are usually within a few percent of --- strict ones, but with better heap usage. For data larger than the --- available memory, or if you have tight memory constraints, this --- module will be the only option. The default chunk size is 64k, which --- should be good in most circumstances. For people with large L2 --- caches, you may want to increase this to fit your cache. +-- strict ones. -- +-- The recomended way to assemble lazy ByteStrings from smaller parts +-- is to use the builder monoid from "Data.ByteString.Lazy.Builder". +-- -- This module is intended to be imported @qualified@, to avoid name -- clashes with "Prelude" functions. eg. -- @@ -41,7 +45,7 @@ -- Rewritten to use 'Data.Array.Unboxed.UArray' by Simon Marlow. -- Rewritten to support slices and use 'Foreign.ForeignPtr.ForeignPtr' -- by David Roundy. --- Polished and extended by Don Stewart. +-- Rewritten again and extended by Don Stewart and Duncan Coutts. -- Lazy variant by Duncan Coutts and Don Stewart. -- @@ -55,8 +59,12 @@ singleton, -- :: Word8 -> ByteString pack, -- :: [Word8] -> ByteString unpack, -- :: ByteString -> [Word8] + fromStrict, -- :: Strict.ByteString -> ByteString + toStrict, -- :: ByteString -> Strict.ByteString fromChunks, -- :: [Strict.ByteString] -> ByteString toChunks, -- :: ByteString -> [Strict.ByteString] + foldrChunks, -- :: (S.ByteString -> a -> a) -> a -> ByteString -> a + foldlChunks, -- :: (a -> S.ByteString -> a) -> a -> ByteString -> a -- * Basic interface cons, -- :: Word8 -> ByteString -> ByteString @@ -242,45 +250,6 @@ #define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined -- ----------------------------------------------------------------------------- - -instance Eq ByteString - where (==) = eq - -instance Ord ByteString - where compare = cmp - -instance Monoid ByteString where - mempty = empty - mappend = append - mconcat = concat - -eq :: ByteString -> ByteString -> Bool -eq Empty Empty = True -eq Empty _ = False -eq _ Empty = False -eq (Chunk a as) (Chunk b bs) = - case compare (S.length a) (S.length b) of - LT -> a == (S.take (S.length a) b) && eq as (Chunk (S.drop (S.length a) b) bs) - EQ -> a == b && eq as bs - GT -> (S.take (S.length b) a) == b && eq (Chunk (S.drop (S.length b) a) as) bs - -cmp :: ByteString -> ByteString -> Ordering -cmp Empty Empty = EQ -cmp Empty _ = LT -cmp _ Empty = GT -cmp (Chunk a as) (Chunk b bs) = - case compare (S.length a) (S.length b) of - LT -> case compare a (S.take (S.length a) b) of - EQ -> cmp as (Chunk (S.drop (S.length a) b) bs) - result -> result - EQ -> case compare a b of - EQ -> cmp as bs - result -> result - GT -> case compare (S.take (S.length b) a) b of - EQ -> cmp (Chunk (S.drop (S.length b) a) as) bs - result -> result - --- ----------------------------------------------------------------------------- -- Introducing and eliminating 'ByteString's -- | /O(1)/ The empty 'ByteString' @@ -295,26 +264,44 @@ -- | /O(n)/ Convert a '[Word8]' into a 'ByteString'. pack :: [Word8] -> ByteString -pack ws = L.foldr (Chunk . S.pack) Empty (chunks defaultChunkSize ws) - where - chunks :: Int -> [a] -> [[a]] - chunks _ [] = [] - chunks size xs = case L.splitAt size xs of - (xs', xs'') -> xs' : chunks size xs'' +pack = packBytes -- | /O(n)/ Converts a 'ByteString' to a '[Word8]'. unpack :: ByteString -> [Word8] -unpack cs = L.concatMap S.unpack (toChunks cs) ---TODO: we can do better here by integrating the concat with the unpack +unpack = unpackBytes -- | /O(c)/ Convert a list of strict 'ByteString' into a lazy 'ByteString' fromChunks :: [P.ByteString] -> ByteString fromChunks cs = L.foldr chunk Empty cs --- | /O(n)/ Convert a lazy 'ByteString' into a list of strict 'ByteString' +-- | /O(c)/ Convert a lazy 'ByteString' into a list of strict 'ByteString' toChunks :: ByteString -> [P.ByteString] toChunks cs = foldrChunks (:) [] cs +-- |/O(1)/ Convert a strict 'ByteString' into a lazy 'ByteString'. +fromStrict :: P.ByteString -> ByteString +fromStrict bs | S.null bs = Empty + | otherwise = Chunk bs Empty + +-- |/O(n)/ Convert a lazy 'ByteString' into a strict 'ByteString'. +-- +-- Note that this is an /expensive/ operation that forces the whole lazy +-- ByteString into memory and then copies all the data. If possible, try to +-- avoid converting back and forth between strict and lazy bytestrings. +-- +toStrict :: ByteString -> S.ByteString +toStrict Empty = S.empty +toStrict (Chunk c Empty) = c +toStrict cs0 = S.unsafeCreate totalLen $ \ptr -> go cs0 ptr + where + totalLen = foldlChunks (\a c -> a + S.length c) 0 cs0 + + go Empty !_ = return () + go (Chunk (S.PS fp off len) cs) !destptr = + withForeignPtr fp $ \p -> do + S.memcpy destptr (p `plusPtr` off) len + go cs (destptr `plusPtr` len) + ------------------------------------------------------------------------ {- @@ -346,6 +333,9 @@ length cs = foldlChunks (\n c -> n + fromIntegral (S.length c)) 0 cs {-# INLINE length #-} +infixr 5 `cons`, `cons'` --same as list (:) +infixl 5 `snoc` + -- | /O(1)/ 'cons' is analogous to '(:)' for lists. -- cons :: Word8 -> ByteString -> ByteString @@ -418,7 +408,7 @@ -- | /O(n\/c)/ Append two ByteStrings append :: ByteString -> ByteString -> ByteString -append xs ys = foldrChunks Chunk ys xs +append = mappend {-# INLINE append #-} -- --------------------------------------------------------------------- @@ -515,12 +505,7 @@ -- | /O(n)/ Concatenate a list of ByteStrings. concat :: [ByteString] -> ByteString -concat css0 = to css0 - where - go Empty css = to css - go (Chunk c cs) css = Chunk c (go cs css) - to [] = Empty - to (cs:css) = go cs css +concat = mconcat -- | Map a function over a 'ByteString' and concatenate the results concatMap :: (Word8 -> ByteString) -> ByteString -> ByteString @@ -845,53 +830,40 @@ -- It is a special case of 'groupBy', which allows the programmer to -- supply their own equality test. group :: ByteString -> [ByteString] -group Empty = [] -group (Chunk c0 cs0) = group' [] (S.group c0) cs0 - where - group' :: [P.ByteString] -> [P.ByteString] -> ByteString -> [ByteString] - group' acc@(s':_) ss@(s:_) cs - | S.unsafeHead s' - /= S.unsafeHead s = revNonEmptyChunks acc : group' [] ss cs - group' acc (s:[]) Empty = revNonEmptyChunks (s:acc) : [] - group' acc (s:[]) (Chunk c cs) = group' (s:acc) (S.group c) cs - group' acc (s:ss) cs = revNonEmptyChunks (s:acc) : group' [] ss cs - -{- -TODO: check if something like this might be faster +group = go + where + go Empty = [] + go (Chunk c cs) + | S.length c == 1 = to [c] (S.unsafeHead c) cs + | otherwise = to [S.unsafeTake 1 c] (S.unsafeHead c) (Chunk (S.unsafeTail c) cs) -group :: ByteString -> [ByteString] -group xs - | null xs = [] - | otherwise = ys : group zs - where - (ys, zs) = spanByte (unsafeHead xs) xs --} + to acc !_ Empty = revNonEmptyChunks acc : [] + to acc !w (Chunk c cs) = + case findIndexOrEnd (/= w) c of + 0 -> revNonEmptyChunks acc + : go (Chunk c cs) + n | n == S.length c -> to (S.unsafeTake n c : acc) w cs + | otherwise -> revNonEmptyChunks (S.unsafeTake n c : acc) + : go (Chunk (S.unsafeDrop n c) cs) -- | The 'groupBy' function is the non-overloaded version of 'group'. -- groupBy :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString] -groupBy _ Empty = [] -groupBy k (Chunk c0 cs0) = groupBy' [] 0 (S.groupBy k c0) cs0 +groupBy k = go where - groupBy' :: [P.ByteString] -> Word8 -> [P.ByteString] -> ByteString -> [ByteString] - groupBy' acc@(_:_) c ss@(s:_) cs - | not (c `k` S.unsafeHead s) = revNonEmptyChunks acc : groupBy' [] 0 ss cs - groupBy' acc _ (s:[]) Empty = revNonEmptyChunks (s : acc) : [] - groupBy' acc w (s:[]) (Chunk c cs) = groupBy' (s:acc) w' (S.groupBy k c) cs - where w' | L.null acc = S.unsafeHead s - | otherwise = w - groupBy' acc _ (s:ss) cs = revNonEmptyChunks (s : acc) : groupBy' [] 0 ss cs - -{- -TODO: check if something like this might be faster + go Empty = [] + go (Chunk c cs) + | S.length c == 1 = to [c] (S.unsafeHead c) cs + | otherwise = to [S.unsafeTake 1 c] (S.unsafeHead c) (Chunk (S.unsafeTail c) cs) -groupBy :: (Word8 -> Word8 -> Bool) -> ByteString -> [ByteString] -groupBy k xs - | null xs = [] - | otherwise = take n xs : groupBy k (drop n xs) - where - n = 1 + findIndexOrEnd (not . k (head xs)) (tail xs) --} + to acc !_ Empty = revNonEmptyChunks acc : [] + to acc !w (Chunk c cs) = + case findIndexOrEnd (not . k w) c of + 0 -> revNonEmptyChunks acc + : go (Chunk c cs) + n | n == S.length c -> to (S.unsafeTake n c : acc) w cs + | otherwise -> revNonEmptyChunks (S.unsafeTake n c : acc) + : go (Chunk (S.unsafeDrop n c) cs) -- | /O(n)/ The 'intercalate' function takes a 'ByteString' and a list of -- 'ByteString's and concatenates the list after interspersing the first @@ -1344,9 +1316,11 @@ -- constant strings created when compiled: errorEmptyList :: String -> a errorEmptyList fun = moduleError fun "empty ByteString" +{-# NOINLINE errorEmptyList #-} moduleError :: String -> String -> a moduleError fun msg = error ("Data.ByteString.Lazy." ++ fun ++ ':':' ':msg) +{-# NOINLINE moduleError #-} -- reverse a list of non-empty chunks into a lazy ByteString diff --git a/Data/ByteString/Lazy/Builder.hs b/Data/ByteString/Lazy/Builder.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/Builder.hs @@ -0,0 +1,451 @@ +{-# LANGUAGE CPP, BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{- | Copyright : (c) 2010 Jasper Van der Jeugt + (c) 2010 - 2011 Simon Meier +License : BSD3-style (see LICENSE) +Maintainer : Simon Meier +Portability : GHC + +'Builder's are used to efficiently construct sequences of bytes from + smaller parts. +Typically, + such a construction is part of the implementation of an /encoding/, i.e., + a function for converting Haskell values to sequences of bytes. +Examples of encodings are the generation of the sequence of bytes + representing a HTML document to be sent in a HTTP response by a + web application or the serialization of a Haskell value using + a fixed binary format. + +For an /efficient implementation of an encoding/, + it is important that (a) little time is spent on converting + the Haskell values to the resulting sequence of bytes /and/ + (b) that the representation of the resulting sequence + is such that it can be consumed efficiently. +'Builder's support (a) by providing an /O(1)/ concatentation operation + and efficient implementations of basic encodings for 'Char's, 'Int's, + and other standard Haskell values. +They support (b) by providing their result as a lazy 'L.ByteString', + which is internally just a linked list of pointers to /chunks/ + of consecutive raw memory. +Lazy 'L.ByteString's can be efficiently consumed by functions that + write them to a file or send them over a network socket. +Note that each chunk boundary incurs expensive extra work (e.g., a system call) + that must be amortized over the work spent on consuming the chunk body. +'Builder's therefore take special care to ensure that the + average chunk size is large enough. +The precise meaning of large enough is application dependent. +The current implementation is tuned + for an average chunk size between 4kb and 32kb, + which should suit most applications. + +As a simple example of an encoding implementation, + we show how to efficiently convert the following representation of mixed-data + tables to an UTF-8 encoded Comma-Separated-Values (CSV) table. + +>data Cell = StringC String +> | IntC Int +> deriving( Eq, Ord, Show ) +> +>type Row = [Cell] +>type Table = [Row] + +We use the following imports and abbreviate 'mappend' to simplify reading. + +@ +import qualified "Data.ByteString.Lazy" as L +import "Data.ByteString.Lazy.Builder" +import "Data.ByteString.Lazy.Builder.ASCII" ('intDec') +import Data.Monoid +import Data.Foldable ('foldMap') +import Data.List ('intersperse') + +infixr 4 \<\> +(\<\>) :: 'Monoid' m => m -> m -> m +(\<\>) = 'mappend' +@ + +CSV is a character-based representation of tables. For maximal modularity, +we could first render 'Table's as 'String's and then encode this 'String' +using some Unicode character encoding. However, this sacrifices performance +due to the intermediate 'String' representation being built and thrown away +right afterwards. We get rid of this intermediate 'String' representation by +fixing the character encoding to UTF-8 and using 'Builder's to convert +'Table's directly to UTF-8 encoded CSV tables represented as lazy +'L.ByteString's. + +@ +encodeUtf8CSV :: Table -> L.ByteString +encodeUtf8CSV = 'toLazyByteString' . renderTable + +renderTable :: Table -> Builder +renderTable rs = 'mconcat' [renderRow r \<\> 'charUtf8' \'\\n\' | r <- rs] + +renderRow :: Row -> Builder +renderRow [] = 'mempty' +renderRow (c:cs) = + renderCell c \<\> mconcat [ charUtf8 \',\' \<\> renderCell c\' | c\' <- cs ] + +renderCell :: Cell -> Builder +renderCell (StringC cs) = renderString cs +renderCell (IntC i) = 'intDec' i + +renderString :: String -> Builder +renderString cs = charUtf8 \'\"\' \<\> foldMap escape cs \<\> charUtf8 \'\"\' + where + escape \'\\\\\' = charUtf8 \'\\\\\' \<\> charUtf8 \'\\\\\' + escape \'\\\"\' = charUtf8 \'\\\\\' \<\> charUtf8 \'\\\"\' + escape c = charUtf8 c +@ + +Note that the ASCII encoding is a subset of the UTF-8 encoding, + which is why we can use the optimized function 'intDec' to + encode an 'Int' as a decimal number with UTF-8 encoded digits. +Using 'intDec' is more efficient than @'stringUtf8' . 'show'@, + as it avoids constructing an intermediate 'String'. +Avoiding this intermediate data structure significantly improves + performance because encoding 'Cell's is the core operation + for rendering CSV-tables. +See "Data.ByteString.Lazy.Builder.BasicEncoding" for further + information on how to improve the performance of 'renderString'. + +We demonstrate our UTF-8 CSV encoding function on the following table. + +@ +strings :: [String] +strings = [\"hello\", \"\\\"1\\\"\", \"λ-wörld\"] + +table :: Table +table = [map StringC strings, map IntC [-3..3]] +@ + +The expression @encodeUtf8CSV table@ results in the following lazy +'L.ByteString'. + +>Chunk "\"hello\",\"\\\"1\\\"\",\"\206\187-w\195\182rld\"\n-3,-2,-1,0,1,2,3\n" Empty + +We can clearly see that we are converting to a /binary/ format. The \'λ\' +and \'ö\' characters, which have a Unicode codepoint above 127, are +expanded to their corresponding UTF-8 multi-byte representation. + +We use the @criterion@ library () + to benchmark the efficiency of our encoding function on the following table. + +>import Criterion.Main -- add this import to the ones above +> +>maxiTable :: Table +>maxiTable = take 1000 $ cycle table +> +>main :: IO () +>main = defaultMain +> [ bench "encodeUtf8CSV maxiTable (original)" $ +> whnf (L.length . encodeUtf8CSV) maxiTable +> ] + +On a Core2 Duo 2.20GHz on a 32-bit Linux, + the above code takes 1ms to generate the 22'500 bytes long lazy 'L.ByteString'. +Looking again at the definitions above, + we see that we took care to avoid intermediate data structures, + as otherwise we would sacrifice performance. +For example, + the following (arguably simpler) definition of 'renderRow' is about 20% slower. + +>renderRow :: Row -> Builder +>renderRow = mconcat . intersperse (charUtf8 ',') . map renderCell + +Similarly, using /O(n)/ concatentations like '++' or the equivalent 'S.concat' + operations on strict and lazy 'L.ByteString's should be avoided. +The following definition of 'renderString' is also about 20% slower. + +>renderString :: String -> Builder +>renderString cs = charUtf8 $ "\"" ++ concatMap escape cs ++ "\"" +> where +> escape '\\' = "\\" +> escape '\"' = "\\\"" +> escape c = return c + +Apart from removing intermediate data-structures, + encodings can be optimized further by fine-tuning their execution + parameters using the functions in "Data.ByteString.Lazy.Builder.Extras" and + their \"inner loops\" using the functions in + "Data.ByteString.Lazy.Builder.BasicEncoding". +-} + + +module Data.ByteString.Lazy.Builder + ( + -- * The Builder type + Builder + + -- * Executing Builders + -- | Internally, 'Builder's are buffer-filling functions. They are + -- executed by a /driver/ that provides them with an actual buffer to + -- fill. Once called with a buffer, a 'Builder' fills it and returns a + -- signal to the driver telling it that it is either done, has filled the + -- current buffer, or wants to directly insert a reference to a chunk of + -- memory. In the last two cases, the 'Builder' also returns a + -- continutation 'Builder' that the driver can call to fill the next + -- buffer. Here, we provide the two drivers that satisfy almost all use + -- cases. See "Data.ByteString.Lazy.Builder.Extras", for information + -- about fine-tuning them. + , toLazyByteString + , hPutBuilder + + -- * Creating Builders + + -- ** Binary encodings + , byteString + , lazyByteString + , int8 + , word8 + + -- *** Big-endian + , int16BE + , int32BE + , int64BE + + , word16BE + , word32BE + , word64BE + + , floatBE + , doubleBE + + -- *** Little-endian + , int16LE + , int32LE + , int64LE + + , word16LE + , word32LE + , word64LE + + , floatLE + , doubleLE + + -- ** Character encodings + + -- *** ASCII (Char7) + -- | The ASCII encoding is a 7-bit encoding. The /Char7/ encoding implemented here + -- works by truncating the Unicode codepoint to 7-bits, prefixing it + -- with a leading 0, and encoding the resulting 8-bits as a single byte. + -- For the codepoints 0-127 this corresponds the ASCII encoding. In + -- "Data.ByteString.Lazy.Builder.ASCII", we also provide efficient + -- implementations of ASCII-based encodings of numbers (e.g., decimal and + -- hexadecimal encodings). + , char7 + , string7 + + -- *** ISO/IEC 8859-1 (Char8) + -- | The ISO/IEC 8859-1 encoding is an 8-bit encoding often known as Latin-1. + -- The /Char8/ encoding implemented here works by truncating the Unicode codepoint + -- to 8-bits and encoding them as a single byte. For the codepoints 0-255 this corresponds + -- to the ISO/IEC 8859-1 encoding. Note that you can also use + -- the functions from "Data.ByteString.Lazy.Builder.ASCII", as the ASCII encoding + -- and ISO/IEC 8859-1 are equivalent on the codepoints 0-127. + , char8 + , string8 + + -- *** UTF-8 + -- | The UTF-8 encoding can encode /all/ Unicode codepoints. We recommend + -- using it always for encoding 'Char's and 'String's unless an application + -- really requires another encoding. Note that you can also use the + -- functions from "Data.ByteString.Lazy.Builder.ASCII" for UTF-8 encoding, + -- as the ASCII encoding is equivalent to the UTF-8 encoding on the Unicode + -- codepoints 0-127. + , charUtf8 + , stringUtf8 + + + ) where + +import Data.ByteString.Lazy.Builder.Internal +import qualified Data.ByteString.Lazy.Builder.BasicEncoding as E +import qualified Data.ByteString.Lazy.Internal as L + +import System.IO (Handle) +import Foreign + +-- HADDOCK only imports +import Data.ByteString.Lazy.Builder.ASCII (intDec) +import qualified Data.ByteString as S (concat) +import Data.Monoid +import Data.Foldable (foldMap) +import Data.List (intersperse) + + +-- | Execute a 'Builder' and return the generated chunks as a lazy 'L.ByteString'. +-- The work is performed lazy, i.e., only when a chunk of the lazy 'L.ByteString' +-- is forced. +{-# NOINLINE toLazyByteString #-} -- ensure code is shared +toLazyByteString :: Builder -> L.ByteString +toLazyByteString = toLazyByteStringWith + (safeStrategy L.smallChunkSize L.defaultChunkSize) L.Empty + +{- Not yet stable enough. + See note on 'hPut' in Data.ByteString.Lazy.Builder.Internal +-} + +-- | Output a 'Builder' to a 'Handle'. +-- The 'Builder' is executed directly on the buffer of the 'Handle'. If the +-- buffer is too small (or not present), then it is replaced with a large +-- enough buffer. +-- +-- It is recommended that the 'Handle' is set to binary and +-- 'BlockBuffering' mode. See 'hSetBinaryMode' and 'hSetBuffering'. +-- +-- This function is more efficient than @hPut . 'toLazyByteString'@ because in +-- many cases no buffer allocation has to be done. Moreover, the results of +-- several executions of short 'Builder's are concatenated in the 'Handle's +-- buffer, therefore avoiding unnecessary buffer flushes. +hPutBuilder :: Handle -> Builder -> IO () +hPutBuilder h = hPut h . putBuilder + + +------------------------------------------------------------------------------ +-- Binary encodings +------------------------------------------------------------------------------ + +-- | Encode a single signed byte as-is. +-- +{-# INLINE int8 #-} +int8 :: Int8 -> Builder +int8 = E.encodeWithF E.int8 + +-- | Encode a single unsigned byte as-is. +-- +{-# INLINE word8 #-} +word8 :: Word8 -> Builder +word8 = E.encodeWithF E.word8 + + +------------------------------------------------------------------------------ +-- Binary little-endian encodings +------------------------------------------------------------------------------ + +-- | Encode an 'Int16' in little endian format. +{-# INLINE int16LE #-} +int16LE :: Int16 -> Builder +int16LE = E.encodeWithF E.int16LE + +-- | Encode an 'Int32' in little endian format. +{-# INLINE int32LE #-} +int32LE :: Int32 -> Builder +int32LE = E.encodeWithF E.int32LE + +-- | Encode an 'Int64' in little endian format. +{-# INLINE int64LE #-} +int64LE :: Int64 -> Builder +int64LE = E.encodeWithF E.int64LE + +-- | Encode a 'Word16' in little endian format. +{-# INLINE word16LE #-} +word16LE :: Word16 -> Builder +word16LE = E.encodeWithF E.word16LE + +-- | Encode a 'Word32' in little endian format. +{-# INLINE word32LE #-} +word32LE :: Word32 -> Builder +word32LE = E.encodeWithF E.word32LE + +-- | Encode a 'Word64' in little endian format. +{-# INLINE word64LE #-} +word64LE :: Word64 -> Builder +word64LE = E.encodeWithF E.word64LE + +-- | Encode a 'Float' in little endian format. +{-# INLINE floatLE #-} +floatLE :: Float -> Builder +floatLE = E.encodeWithF E.floatLE + +-- | Encode a 'Double' in little endian format. +{-# INLINE doubleLE #-} +doubleLE :: Double -> Builder +doubleLE = E.encodeWithF E.doubleLE + + +------------------------------------------------------------------------------ +-- Binary big-endian encodings +------------------------------------------------------------------------------ + +-- | Encode an 'Int16' in big endian format. +{-# INLINE int16BE #-} +int16BE :: Int16 -> Builder +int16BE = E.encodeWithF E.int16BE + +-- | Encode an 'Int32' in big endian format. +{-# INLINE int32BE #-} +int32BE :: Int32 -> Builder +int32BE = E.encodeWithF E.int32BE + +-- | Encode an 'Int64' in big endian format. +{-# INLINE int64BE #-} +int64BE :: Int64 -> Builder +int64BE = E.encodeWithF E.int64BE + +-- | Encode a 'Word16' in big endian format. +{-# INLINE word16BE #-} +word16BE :: Word16 -> Builder +word16BE = E.encodeWithF E.word16BE + +-- | Encode a 'Word32' in big endian format. +{-# INLINE word32BE #-} +word32BE :: Word32 -> Builder +word32BE = E.encodeWithF E.word32BE + +-- | Encode a 'Word64' in big endian format. +{-# INLINE word64BE #-} +word64BE :: Word64 -> Builder +word64BE = E.encodeWithF E.word64BE + +-- | Encode a 'Float' in big endian format. +{-# INLINE floatBE #-} +floatBE :: Float -> Builder +floatBE = E.encodeWithF E.floatBE + +-- | Encode a 'Double' in big endian format. +{-# INLINE doubleBE #-} +doubleBE :: Double -> Builder +doubleBE = E.encodeWithF E.doubleBE + +------------------------------------------------------------------------------ +-- ASCII encoding +------------------------------------------------------------------------------ + +-- | Char7 encode a 'Char'. +{-# INLINE char7 #-} +char7 :: Char -> Builder +char7 = E.encodeWithF E.char7 + +-- | Char7 encode a 'String'. +{-# INLINE string7 #-} +string7 :: String -> Builder +string7 = E.encodeListWithF E.char7 + +------------------------------------------------------------------------------ +-- ISO/IEC 8859-1 encoding +------------------------------------------------------------------------------ + +-- | Char8 encode a 'Char'. +{-# INLINE char8 #-} +char8 :: Char -> Builder +char8 = E.encodeWithF E.char8 + +-- | Char8 encode a 'String'. +{-# INLINE string8 #-} +string8 :: String -> Builder +string8 = E.encodeListWithF E.char8 + +------------------------------------------------------------------------------ +-- UTF-8 encoding +------------------------------------------------------------------------------ + +-- | UTF-8 encode a 'Char'. +{-# INLINE charUtf8 #-} +charUtf8 :: Char -> Builder +charUtf8 = E.encodeWithB E.charUtf8 + +-- | UTF-8 encode a 'String'. +{-# INLINE stringUtf8 #-} +stringUtf8 :: String -> Builder +stringUtf8 = E.encodeListWithB E.charUtf8 + diff --git a/Data/ByteString/Lazy/Builder/ASCII.hs b/Data/ByteString/Lazy/Builder/ASCII.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/Builder/ASCII.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE ScopedTypeVariables, CPP, ForeignFunctionInterface #-} +-- | Copyright : (c) 2010 - 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC +-- +-- Constructing 'Builder's using ASCII-based encodings. +-- +module Data.ByteString.Lazy.Builder.ASCII + ( + -- * Decimal numbers + -- | Decimal encoding of numbers using ASCII encoded characters. + int8Dec + , int16Dec + , int32Dec + , int64Dec + , intDec + , integerDec + + , word8Dec + , word16Dec + , word32Dec + , word64Dec + , wordDec + + , floatDec + , doubleDec + + -- * Hexadecimal numbers + + -- | Encoding positive integers as hexadecimal numbers using lower-case + -- ASCII characters. The shortest + -- possible representation is used. For example, + -- + -- >>> toLazyByteString (word16Hex 0x0a10) + -- Chunk "a10" Empty + -- + -- Note that there is no support for using upper-case characters. Please + -- contact the maintainer, if your application cannot work without + -- hexadecimal encodings that use upper-case characters. + -- + , word8Hex + , word16Hex + , word32Hex + , word64Hex + , wordHex + + -- * Fixed-width hexadecimal numbers + -- + , int8HexFixed + , int16HexFixed + , int32HexFixed + , int64HexFixed + , word8HexFixed + , word16HexFixed + , word32HexFixed + , word64HexFixed + + , floatHexFixed + , doubleHexFixed + + , byteStringHexFixed + , lazyByteStringHexFixed + + ) where + +import Data.ByteString as S +import Data.ByteString.Lazy.Internal as L +import Data.ByteString.Lazy.Builder.Internal (Builder) +import qualified Data.ByteString.Lazy.Builder.BasicEncoding as E + +import Foreign + +------------------------------------------------------------------------------ +-- Decimal Encoding +------------------------------------------------------------------------------ + + +-- | Encode a 'String' using 'E.char7'. +{-# INLINE string7 #-} +string7 :: String -> Builder +string7 = E.encodeListWithF E.char7 + +------------------------------------------------------------------------------ +-- Decimal Encoding +------------------------------------------------------------------------------ + +-- Signed integers +------------------ + +-- | Decimal encoding of an 'Int8' using the ASCII digits. +{-# INLINE int8Dec #-} +int8Dec :: Int8 -> Builder +int8Dec = E.encodeWithB E.int8Dec + +-- | Decimal encoding of an 'Int16' using the ASCII digits. +{-# INLINE int16Dec #-} +int16Dec :: Int16 -> Builder +int16Dec = E.encodeWithB E.int16Dec + +-- | Decimal encoding of an 'Int32' using the ASCII digits. +{-# INLINE int32Dec #-} +int32Dec :: Int32 -> Builder +int32Dec = E.encodeWithB E.int32Dec + +-- | Decimal encoding of an 'Int64' using the ASCII digits. +{-# INLINE int64Dec #-} +int64Dec :: Int64 -> Builder +int64Dec = E.encodeWithB E.int64Dec + +-- | Decimal encoding of an 'Int' using the ASCII digits. +{-# INLINE intDec #-} +intDec :: Int -> Builder +intDec = E.encodeWithB E.intDec + +-- | /Currently slow./ Decimal encoding of an 'Integer' using the ASCII digits. +{-# INLINE integerDec #-} +integerDec :: Integer -> Builder +integerDec = string7 . show + + +-- Unsigned integers +-------------------- + +-- | Decimal encoding of a 'Word8' using the ASCII digits. +{-# INLINE word8Dec #-} +word8Dec :: Word8 -> Builder +word8Dec = E.encodeWithB E.word8Dec + +-- | Decimal encoding of a 'Word16' using the ASCII digits. +{-# INLINE word16Dec #-} +word16Dec :: Word16 -> Builder +word16Dec = E.encodeWithB E.word16Dec + +-- | Decimal encoding of a 'Word32' using the ASCII digits. +{-# INLINE word32Dec #-} +word32Dec :: Word32 -> Builder +word32Dec = E.encodeWithB E.word32Dec + +-- | Decimal encoding of a 'Word64' using the ASCII digits. +{-# INLINE word64Dec #-} +word64Dec :: Word64 -> Builder +word64Dec = E.encodeWithB E.word64Dec + +-- | Decimal encoding of a 'Word' using the ASCII digits. +{-# INLINE wordDec #-} +wordDec :: Word -> Builder +wordDec = E.encodeWithB E.wordDec + + +-- Floating point numbers +------------------------- + +-- TODO: Use Bryan O'Sullivan's double-conversion package to speed it up. + +-- | /Currently slow./ Decimal encoding of an IEEE 'Float'. +{-# INLINE floatDec #-} +floatDec :: Float -> Builder +floatDec = string7 . show + +-- | /Currently slow./ Decimal encoding of an IEEE 'Double'. +{-# INLINE doubleDec #-} +doubleDec :: Double -> Builder +doubleDec = string7 . show + + +------------------------------------------------------------------------------ +-- Hexadecimal Encoding +------------------------------------------------------------------------------ + +-- without lead +--------------- + +-- | Shortest hexadecimal encoding of a 'Word8' using lower-case characters. +{-# INLINE word8Hex #-} +word8Hex :: Word8 -> Builder +word8Hex = E.encodeWithB E.word8Hex + +-- | Shortest hexadecimal encoding of a 'Word16' using lower-case characters. +{-# INLINE word16Hex #-} +word16Hex :: Word16 -> Builder +word16Hex = E.encodeWithB E.word16Hex + +-- | Shortest hexadecimal encoding of a 'Word32' using lower-case characters. +{-# INLINE word32Hex #-} +word32Hex :: Word32 -> Builder +word32Hex = E.encodeWithB E.word32Hex + +-- | Shortest hexadecimal encoding of a 'Word64' using lower-case characters. +{-# INLINE word64Hex #-} +word64Hex :: Word64 -> Builder +word64Hex = E.encodeWithB E.word64Hex + +-- | Shortest hexadecimal encoding of a 'Word' using lower-case characters. +{-# INLINE wordHex #-} +wordHex :: Word -> Builder +wordHex = E.encodeWithB E.wordHex + + +-- fixed width; leading zeroes +------------------------------ + +-- | Encode a 'Int8' using 2 nibbles (hexadecimal digits). +{-# INLINE int8HexFixed #-} +int8HexFixed :: Int8 -> Builder +int8HexFixed = E.encodeWithF E.int8HexFixed + +-- | Encode a 'Int16' using 4 nibbles. +{-# INLINE int16HexFixed #-} +int16HexFixed :: Int16 -> Builder +int16HexFixed = E.encodeWithF E.int16HexFixed + +-- | Encode a 'Int32' using 8 nibbles. +{-# INLINE int32HexFixed #-} +int32HexFixed :: Int32 -> Builder +int32HexFixed = E.encodeWithF E.int32HexFixed + +-- | Encode a 'Int64' using 16 nibbles. +{-# INLINE int64HexFixed #-} +int64HexFixed :: Int64 -> Builder +int64HexFixed = E.encodeWithF E.int64HexFixed + +-- | Encode a 'Word8' using 2 nibbles (hexadecimal digits). +{-# INLINE word8HexFixed #-} +word8HexFixed :: Word8 -> Builder +word8HexFixed = E.encodeWithF E.word8HexFixed + +-- | Encode a 'Word16' using 4 nibbles. +{-# INLINE word16HexFixed #-} +word16HexFixed :: Word16 -> Builder +word16HexFixed = E.encodeWithF E.word16HexFixed + +-- | Encode a 'Word32' using 8 nibbles. +{-# INLINE word32HexFixed #-} +word32HexFixed :: Word32 -> Builder +word32HexFixed = E.encodeWithF E.word32HexFixed + +-- | Encode a 'Word64' using 16 nibbles. +{-# INLINE word64HexFixed #-} +word64HexFixed :: Word64 -> Builder +word64HexFixed = E.encodeWithF E.word64HexFixed + +-- | Encode an IEEE 'Float' using 8 nibbles. +{-# INLINE floatHexFixed #-} +floatHexFixed :: Float -> Builder +floatHexFixed = E.encodeWithF E.floatHexFixed + +-- | Encode an IEEE 'Double' using 16 nibbles. +{-# INLINE doubleHexFixed #-} +doubleHexFixed :: Double -> Builder +doubleHexFixed = E.encodeWithF E.doubleHexFixed + +-- | Encode each byte of a 'S.ByteString' using its fixed-width hex encoding. +{-# NOINLINE byteStringHexFixed #-} -- share code +byteStringHexFixed :: S.ByteString -> Builder +byteStringHexFixed = E.encodeByteStringWithF E.word8HexFixed + +-- | Encode each byte of a lazy 'L.ByteString' using its fixed-width hex encoding. +{-# NOINLINE lazyByteStringHexFixed #-} -- share code +lazyByteStringHexFixed :: L.ByteString -> Builder +lazyByteStringHexFixed = E.encodeLazyByteStringWithF E.word8HexFixed diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding.hs b/Data/ByteString/Lazy/Builder/BasicEncoding.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/Builder/BasicEncoding.hs @@ -0,0 +1,804 @@ +{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{- | Copyright : (c) 2010-2011 Simon Meier + (c) 2010 Jasper van der Jeugt +License : BSD3-style (see LICENSE) +Maintainer : Simon Meier +Portability : GHC + +This module provides the types of fixed-size and bounded-size encodings, + which are the basic building blocks for constructing 'Builder's. +These types are used to achieve + application-specific performance improvements of 'Builder's. + +/Fixed(-size) encodings/ are encodings that always result in a sequence of bytes + of a predetermined, fixed length. +An example for a fixed encoding is the big-endian encoding of a 'Word64', + which always results in exactly 8 bytes. +/Bounded(-size) encodings/ are encodings that always result in a sequence + of bytes that is no larger than a predetermined bound. +An example for a bounded encoding is the UTF-8 encoding of a 'Char', + which results always in less or equal to 4 bytes. +Note that every fixed encoding is also a bounded encoding. +In the following, we therefore only refer to fixed encodings, + where it matters that the resulting sequence of bytes is of a + of a predetermined, fixed length. +Otherwise, we just refer to bounded encodings. + +As said, + the goal of bounded encodings is to improve the performance of 'Builder's. +These improvements stem from making the two + most common steps performed by a 'Builder' more efficient. +We explain these two steps in turn. + +The first most common step is the concatentation of two 'Builder's. +Internally, + concatentation corresponds to function composition. +(Note that 'Builder's can be seen as difference-lists + of buffer-filling functions; + cf. . +) +Function composition is a fast /O(1)/ operation. +However, + we can use bounded encodings to + remove some of these function compositions altoghether, + which is obviously more efficient. + +The second most common step performed by a 'Builder' is to fill a buffer + using a bounded encoding, + which works as follows. +The 'Builder' checks whether there is enough space left to + execute the bounded encoding. +If there is, then the 'Builder' executes the bounded encoding + and calls the next 'Builder' with the updated buffer. +Otherwise, + the 'Builder' signals its driver that it requires a new buffer. +This buffer must be at least as large as the bound of the encoding. +We can use bounded encodings to reduce the number of buffer-free + checks by fusing the buffer-free checks of consecutive + 'Builder's. +We can also use bounded encodings to simplify the control flow + for signalling that a buffer is full by + ensuring that we check first that there is enough space left + and only then decide on how to encode a given value. + +Let us illustrate these improvements on the + CSV-table rendering example from "Data.ByteString.Lazy.Builder". +Its \"hot code\" is the rendering of a table's cells, + which we implement as follows using only the functions from the + 'Builder' API. + +@ +import "Data.ByteString.Lazy.Builder" as B +import "Data.ByteString.Lazy.Builder.ASCII" as B + +renderCell :: Cell -> Builder +renderCell (StringC cs) = renderString cs +renderCell (IntC i) = B.intDec i + +renderString :: String -> Builder +renderString cs = B.charUtf8 \'\"\' \<\> foldMap escape cs \<\> B.charUtf8 \'\"\' + where + escape \'\\\\\' = B.charUtf8 \'\\\\\' \<\> B.charUtf8 \'\\\\\' + escape \'\\\"\' = B.charUtf8 \'\\\\\' \<\> B.charUtf8 \'\\\"\' + escape c = B.charUtf8 c +@ + +Efficient encoding of 'Int's as decimal numbers is performed by @intDec@ + from "Data.ByteString.Lazy.Builder.ASCII". +Optimization potential exists for the escaping of 'String's. +The above implementation has two optimization opportunities. +First, + the buffer-free checks of the 'Builder's for escaping doublequotes + and backslashes can be fused. +Second, + the concatenations performed by 'foldMap' can be eliminated. +The following implementation exploits these optimizations. + +@ +import qualified Data.ByteString.Lazy.Builder.BasicEncoding as E +import Data.ByteString.Lazy.Builder.BasicEncoding + ( 'ifB', 'fromF', ('>*<'), ('>$<') ) + +renderString :: String -\> Builder +renderString cs = + B.charUtf8 \'\"\' \<\> E.'encodeListWithB' escape cs \<\> B.charUtf8 \'\"\' + where + escape :: E.'BoundedEncoding' Char + escape = + 'ifB' (== \'\\\\\') (fixed2 (\'\\\\\', \'\\\\\')) $ + 'ifB' (== \'\\\"\') (fixed2 (\'\\\\\', \'\\\"\')) $ + E.'charUtf8' +   + {-\# INLINE fixed2 \#-} + fixed2 x = 'fromF' $ const x '>$<' E.'char7' '>*<' E.'char7' +@ + +The code should be mostly self-explanatory. +The slightly awkward syntax is because the combinators + are written such that the size-bound of the resulting 'BoundedEncoding' + can be computed at compile time. +We also explicitly inline the 'fixed2' encoding, + which encodes a fixed tuple of characters, + to ensure that the bound compuation happens at compile time. +When encoding the following list of 'String's, + the optimized implementation of 'renderString' is two times faster. + +@ +maxiStrings :: [String] +maxiStrings = take 1000 $ cycle [\"hello\", \"\\\"1\\\"\", \"λ-wörld\"] +@ + +Most of the performance gain stems from using 'encodeListWithB', + which encodes a list of values from left-to-right with a + 'BoundedEncoding'. +It exploits the 'Builder' internals to avoid unnecessary function + compositions (i.e., concatentations). +In the future, + we would expect the compiler to perform the optimizations + implemented in 'encodeListWithB'. +However, + it seems that the code is currently to complicated for the + compiler to see through. +Therefore, + we provide the 'BoundedEncoding' escape hatch, + which allows data structures to provide very efficient encoding traversals, + like 'encodeListWithB' for lists. + +Note that 'BoundedEncoding's are a bit verbose, but quite versatile. +Here is an example of a 'BoundedEncoding' for combined HTML escapng and +UTF-8 encoding. +It exploits that the escaped character with the maximal Unicode + codepoint is \'>\'. + +@ +{-\# INLINE charUtf8HtmlEscaped \#-} +charUtf8HtmlEscaped :: E.BoundedEncoding Char +charUtf8HtmlEscaped = + 'ifB' (> \'\>\' ) E.'charUtf8' $ + 'ifB' (== \'\<\' ) (fixed4 (\'&\',(\'l\',(\'t\',\';\')))) $ -- < + 'ifB' (== \'\>\' ) (fixed4 (\'&\',(\'g\',(\'t\',\';\')))) $ -- > + 'ifB' (== \'&\' ) (fixed5 (\'&\',(\'a\',(\'m\',(\'p\',\';\'))))) $ -- & + 'ifB' (== \'\"\' ) (fixed5 (\'&\',(\'\#\',(\'3\',(\'4\',\';\'))))) $ -- &\#34; + 'ifB' (== \'\\\'\') (fixed5 (\'&\',(\'\#\',(\'3\',(\'9\',\';\'))))) $ -- &\#39; + ('fromF' E.'char7') -- fallback for 'Char's smaller than \'\>\' + where + {-\# INLINE fixed4 \#-} + fixed4 x = 'fromF' $ const x '>$<' + E.char7 '>*<' E.char7 '>*<' E.char7 '>*<' E.char7 +   + {-\# INLINE fixed5 \#-} + fixed5 x = 'fromF' $ const x '>$<' + E.char7 '>*<' E.char7 '>*<' E.char7 '>*<' E.char7 '>*<' E.char7 +@ + +This module currently does not expose functions that require the special + properties of fixed-size encodings. +They are useful for prefixing 'Builder's with their size or for + implementing chunked encodings. +We will expose the corresponding functions in future releases of this + library. +-} + + + +{- +-- +-- +-- A /bounded encoding/ is an encoding that never results in a sequence +-- longer than some fixed number of bytes. This number of bytes must be +-- independent of the value being encoded. Typical examples of bounded +-- encodings are the big-endian encoding of a 'Word64', which results always +-- in exactly 8 bytes, or the UTF-8 encoding of a 'Char', which results always +-- in less or equal to 4 bytes. +-- +-- Typically, encodings are implemented efficiently by allocating a buffer (an +-- array of bytes) and repeatedly executing the following two steps: (1) +-- writing to the buffer until it is full and (2) handing over the filled part +-- to the consumer of the encoded value. Step (1) is where bounded encodings +-- are used. We must use a bounded encoding, as we must check that there is +-- enough free space /before/ actually writing to the buffer. +-- +-- In term of expressivity, it would be sufficient to construct all encodings +-- from the single bounded encoding that encodes a 'Word8' as-is. However, +-- this is not sufficient in terms of efficiency. It results in unnecessary +-- buffer-full checks and it complicates the program-flow for writing to the +-- buffer, as buffer-full checks are interleaved with analyzing the value to be +-- encoded (e.g., think about the program-flow for UTF-8 encoding). This has a +-- significant effect on overall encoding performance, as encoding primitive +-- Haskell values such as 'Word8's or 'Char's lies at the heart of every +-- encoding implementation. +-- +-- The bounded 'Encoding's provided by this module remove this performance +-- problem. Intuitively, they consist of a tuple of the bound on the maximal +-- number of bytes written and the actual implementation of the encoding as a +-- function that modifies a mutable buffer. Hence when executing a bounded +-- 'Encoding', the buffer-full check can be done once before the actual writing +-- to the buffer. The provided 'Encoding's also take care to implement the +-- actual writing to the buffer efficiently. Moreover, combinators are +-- provided to construct new bounded encodings from the provided ones. +-- +-- A typical example for using the combinators is a bounded 'Encoding' that +-- combines escaping the ' and \\ characters with UTF-8 encoding. More +-- precisely, the escaping to be done is the one implemented by the following +-- @escape@ function. +-- +-- > escape :: Char -> [Char] +-- > escape '\'' = "\\'" +-- > escape '\\' = "\\\\" +-- > escape c = [c] +-- +-- The bounded 'Encoding' that combines this escaping with UTF-8 encoding is +-- the following. +-- +-- > import Data.ByteString.Lazy.Builder.BasicEncoding.Utf8 (char) +-- > +-- > {-# INLINE escapeChar #-} +-- > escapeUtf8 :: BoundedEncoding Char +-- > escapeUtf8 = +-- > encodeIf ('\'' ==) (char <#> char #. const ('\\','\'')) $ +-- > encodeIf ('\\' ==) (char <#> char #. const ('\\','\\')) $ +-- > char +-- +-- The definition of 'escapeUtf8' is more complicated than 'escape', because +-- the combinators ('encodeIf', 'encodePair', '#.', and 'char') used in +-- 'escapeChar' compute both the bound on the maximal number of bytes written +-- (8 for 'escapeUtf8') as well as the low-level buffer manipulation required +-- to implement the encoding. Bounded 'Encoding's should always be inlined. +-- Otherwise, the compiler cannot compute the bound on the maximal number of +-- bytes written at compile-time. Without inlinining, it would also fail to +-- optimize the constant encoding of the escape characters in the above +-- example. Functions that execute bounded 'Encoding's also perform +-- suboptimally, if the definition of the bounded 'Encoding' is not inlined. +-- Therefore we add an 'INLINE' pragma to 'escapeUtf8'. +-- +-- Currently, the only library that executes bounded 'Encoding's is the +-- 'bytestring' library (). It +-- uses bounded 'Encoding's to implement most of its lazy bytestring builders. +-- Executing a bounded encoding should be done using the corresponding +-- functions in the lazy bytestring builder 'Extras' module. +-- +-- TODO: Merge with explanation/example below +-- +-- Bounded 'E.Encoding's abstract encodings of Haskell values that can be implemented by +-- writing a bounded-size sequence of bytes directly to memory. They are +-- lifted to conversions from Haskell values to 'Builder's by wrapping them +-- with a bound-check. The compiler can implement this bound-check very +-- efficiently (i.e, a single comparison of the difference of two pointers to a +-- constant), because the bound of a 'E.Encoding' is always independent of the +-- value being encoded and, in most cases, a literal constant. +-- +-- 'E.Encoding's are the primary means for defining conversion functions from +-- primitive Haskell values to 'Builder's. Most 'Builder' constructors +-- provided by this library are implemented that way. +-- 'E.Encoding's are also used to construct conversions that exploit the internal +-- representation of data-structures. +-- +-- For example, 'encodeByteStringWith' works directly on the underlying byte +-- array and uses some tricks to reduce the number of variables in its inner +-- loop. Its efficiency is exploited for implementing the @filter@ and @map@ +-- functions in "Data.ByteString.Lazy" as +-- +-- > import qualified Codec.Bounded.Encoding as E +-- > +-- > filter :: (Word8 -> Bool) -> ByteString -> ByteString +-- > filter p = toLazyByteString . encodeLazyByteStringWithB write +-- > where +-- > write = E.encodeIf p E.word8 E.emptyEncoding +-- > +-- > map :: (Word8 -> Word8) -> ByteString -> ByteString +-- > map f = toLazyByteString . encodeLazyByteStringWithB (E.word8 E.#. f) +-- +-- Compared to earlier versions of @filter@ and @map@ on lazy 'L.ByteString's, +-- these versions use a more efficient inner loop and have the additional +-- advantage that they always result in well-chunked 'L.ByteString's; i.e, they +-- also perform automatic defragmentation. +-- +-- We can also use 'E.Encoding's to improve the efficiency of the following +-- 'renderString' function from our UTF-8 CSV table encoding example in +-- "Data.ByteString.Lazy.Builder". +-- +-- > renderString :: String -> Builder +-- > renderString cs = charUtf8 '"' <> foldMap escape cs <> charUtf8 '"' +-- > where +-- > escape '\\' = charUtf8 '\\' <> charUtf8 '\\' +-- > escape '\"' = charUtf8 '\\' <> charUtf8 '\"' +-- > escape c = charUtf8 c +-- +-- The idea is to save on 'mappend's by implementing a 'E.Encoding' that escapes +-- characters and using 'encodeListWith', which implements writing a list of +-- values with a tighter inner loop and no 'mappend'. +-- +-- > import Data.ByteString.Lazy.Builder.Extras -- assume these three +-- > import Codec.Bounded.Encoding -- imports are present +-- > ( BoundedEncoding, encodeIf, (<#>), (#.) ) +-- > import Data.ByteString.Lazy.Builder.BasicEncoding.Utf8 (char) +-- > +-- > renderString :: String -> Builder +-- > renderString cs = +-- > charUtf8 '"' <> encodeListWithB escapedUtf8 cs <> charUtf8 '"' +-- > where +-- > escapedUtf8 :: BoundedEncoding Char +-- > escapedUtf8 = +-- > encodeIf (== '\\') (char <#> char #. const ('\\', '\\')) $ +-- > encodeIf (== '\"') (char <#> char #. const ('\\', '\"')) $ +-- > char +-- +-- This 'Builder' considers a buffer with less than 8 free bytes as full. As +-- all functions are inlined, the compiler is able to optimize the constant +-- 'E.Encoding's as two sequential 'poke's. Compared to the first implementation of +-- 'renderString' this implementation is 1.7x faster. +-- +-} +{- +Internally, 'Builder's are buffer-fill operations that are +given a continuation buffer-fill operation and a buffer-range to be filled. +A 'Builder' first checks if the buffer-range is large enough. If that's +the case, the 'Builder' writes the sequences of bytes to the buffer and +calls its continuation. Otherwise, it returns a signal that it requires a +new buffer together with a continuation to be called on this new buffer. +Ignoring the rare case of a full buffer-range, the execution cost of a +'Builder' consists of three parts: + + 1. The time taken to read the parameters; i.e., the buffer-fill + operation to call after the 'Builder' is done and the buffer-range to + fill. + + 2. The time taken to check for the size of the buffer-range. + + 3. The time taken for the actual encoding. + +We can reduce cost (1) by ensuring that fewer buffer-fill function calls are +required. We can reduce cost (2) by fusing buffer-size checks of sequential +writes. For example, when escaping a 'String' using 'renderString', it would +be sufficient to check before encoding a character that at least 8 bytes are +free. We can reduce cost (3) by implementing better primitive 'Builder's. +For example, 'renderCell' builds an intermediate list containing the decimal +representation of an 'Int'. Implementing a direct decimal encoding of 'Int's +to memory would be more efficient, as it requires fewer buffer-size checks +and less allocation. It is also a planned extension of this library. + +The first two cost reductions are supported for user code through functions +in "Data.ByteString.Lazy.Builder.Extras". There, we continue the above example +and drop the generation time to 0.8ms by implementing 'renderString' more +cleverly. The third reduction requires meddling with the internals of +'Builder's and is not recomended in code outside of this library. However, +patches to this library are very welcome. +-} +module Data.ByteString.Lazy.Builder.BasicEncoding ( + + -- * Fixed-size encodings + FixedEncoding + + -- ** Combinators + -- | The combinators for 'FixedEncoding's are implemented such that the 'size' + -- of the resulting 'FixedEncoding' is computed at compile time. + , emptyF + , pairF + , contramapF + + -- ** Builder construction + -- | In terms of expressivity, the function 'encodeWithF' would be sufficient + -- for constructing 'Builder's from 'FixedEncoding's. The fused variants of + -- this function are provided because they allow for more efficient + -- implementations. Our compilers are just not smart enough yet; and for some + -- of the employed optimizations (see the code of 'encodeByteStringWithF') + -- they will very likely never be. + -- + -- Note that functions marked with \"/Heavy inlining./\" are forced to be + -- inlined because they must be specialized for concrete encodings, + -- but are rather heavy in terms of code size. We recommend to define a + -- top-level function for every concrete instantiation of such a function in + -- order to share its code. A typical example is the function + -- 'byteStringHexFixed' from "Data.ByteString.Lazy.Builder.ASCII", which is + -- implemented as follows. + -- + -- @ + -- byteStringHexFixed :: S.ByteString -> Builder + -- byteStringHexFixed = 'encodeByteStringWithF' 'word8HexFixed' + -- @ + -- + , encodeWithF + , encodeListWithF + , encodeUnfoldrWithF + + , encodeByteStringWithF + , encodeLazyByteStringWithF + + -- * Bounded-size encodings + + , BoundedEncoding + + -- ** Combinators + -- | The combinators for 'BoundedEncoding's are implemented such that the + -- 'sizeBound' of the resulting 'BoundedEncoding' is computed at compile time. + , fromF + , emptyB + , pairB + , eitherB + , ifB + , contramapB + + -- | We provide overloaded operators for some of the above combinators to + -- allow for a more convenient syntax. We do not export their corresponding, + -- as we they are used for overloading only and should not be extended by + -- the user of this library. We plan to use the @contravariant@ library + -- once it is part of the + -- Haskell platform. + , (>*<) + , (>$<) + + -- ** Builder construction + , encodeWithB + , encodeListWithB + , encodeUnfoldrWithB + + , encodeByteStringWithB + , encodeLazyByteStringWithB + + -- * Standard encodings of Haskell values + + , module Data.ByteString.Lazy.Builder.BasicEncoding.Binary + + -- ** Character encodings + , module Data.ByteString.Lazy.Builder.BasicEncoding.ASCII + + -- *** ISO/IEC 8859-1 (Char8) + -- | The ISO/IEC 8859-1 encoding is an 8-bit encoding often known as Latin-1. + -- The /Char8/ encoding implemented here works by truncating the Unicode + -- codepoint to 8-bits and encoding them as a single byte. For the codepoints + -- 0-255 this corresponds to the ISO/IEC 8859-1 encoding. Note that the + -- Char8 encoding is equivalent to the ASCII encoding on the Unicode + -- codepoints 0-127. Hence, functions such as 'intDec' can also be used for + -- encoding 'Int's as a decimal number with Char8 encoded characters. + , char8 + + -- *** UTF-8 + -- | The UTF-8 encoding can encode all Unicode codepoints. + -- It is equivalent to the ASCII encoding on the Unicode codepoints 0-127. + -- Hence, functions such as 'intDec' can also be used for encoding 'Int's as + -- a decimal number with UTF-8 encoded characters. + , charUtf8 + + -- * Testing support + -- | The following four functions are intended for testing use + -- only. They are /not/ efficient. Basic encodings are efficently executed by + -- creating 'Builder's from them using the @encodeXXX@ functions explained at + -- the top of this module. + + , evalF + , evalB + + , showF + , showB + + ) where + +import Data.ByteString.Lazy.Builder.Internal +import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.UncheckedShifts +import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Base16 (lowerTable, encode4_as_8) + +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy.Internal as L + +import Data.Monoid +import Data.List (unfoldr) -- HADDOCK ONLY +import Data.Char (chr, ord) +import Control.Monad ((<=<), unless) + +import Data.ByteString.Lazy.Builder.BasicEncoding.Internal hiding (size, sizeBound) +import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Internal as I (size, sizeBound) +import Data.ByteString.Lazy.Builder.BasicEncoding.Binary +import Data.ByteString.Lazy.Builder.BasicEncoding.ASCII + +#if MIN_VERSION_base(4,4,0) +import Foreign hiding (unsafePerformIO, unsafeForeignPtrToPtr) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import System.IO.Unsafe (unsafePerformIO) +#else +import Foreign +#endif + +------------------------------------------------------------------------------ +-- Creating Builders from bounded encodings +------------------------------------------------------------------------------ + +-- | Encode a value with a 'FixedEncoding'. +{-# INLINE encodeWithF #-} +encodeWithF :: FixedEncoding a -> (a -> Builder) +encodeWithF = encodeWithB . toB + +-- | Encode a list of values from left-to-right with a 'FixedEncoding'. +{-# INLINE encodeListWithF #-} +encodeListWithF :: FixedEncoding a -> ([a] -> Builder) +encodeListWithF = encodeListWithB . toB + +-- | Encode a list of values represented as an 'unfoldr' with a 'FixedEncoding'. +{-# INLINE encodeUnfoldrWithF #-} +encodeUnfoldrWithF :: FixedEncoding b -> (a -> Maybe (b, a)) -> a -> Builder +encodeUnfoldrWithF = encodeUnfoldrWithB . toB + +-- | /Heavy inlining./ Encode all bytes of a strict 'S.ByteString' from +-- left-to-right with a 'FixedEncoding'. This function is quite versatile. For +-- example, we can use it to construct a 'Builder' that maps every byte before +-- copying it to the buffer to be filled. +-- +-- > mapToBuilder :: (Word8 -> Word8) -> S.ByteString -> Builder +-- > mapToBuilder f = encodeByteStringWithF (contramapF f word8) +-- +-- We can also use it to hex-encode a strict 'S.ByteString' as shown by the +-- 'byteStringHexFixed' example above. +{-# INLINE encodeByteStringWithF #-} +encodeByteStringWithF :: FixedEncoding Word8 -> (S.ByteString -> Builder) +encodeByteStringWithF = encodeByteStringWithB . toB + +-- | /Heavy inlining./ Encode all bytes of a lazy 'L.ByteString' from +-- left-to-right with a 'FixedEncoding'. +{-# INLINE encodeLazyByteStringWithF #-} +encodeLazyByteStringWithF :: FixedEncoding Word8 -> (L.ByteString -> Builder) +encodeLazyByteStringWithF = encodeLazyByteStringWithB . toB + +-- IMPLEMENTATION NOTE: Sadly, 'encodeListWith' cannot be used for foldr/build +-- fusion. Its performance relies on hoisting several variables out of the +-- inner loop. That's not possible when writing 'encodeListWith' as a 'foldr'. +-- If we had stream fusion for lists, then we could fuse 'encodeListWith', as +-- 'encodeWithStream' can keep control over the execution. + + +-- | Create a 'Builder' that encodes values with the given 'Encoding'. +-- +-- We rewrite consecutive uses of 'encodeWith' such that the bound-checks are +-- fused. For example, +-- +-- > encodeWithB (word32 c1) `mappend` encodeWithB (word32 c2) +-- +-- is rewritten such that the resulting 'Builder' checks only once, if ther are +-- at 8 free bytes, instead of checking twice, if there are 4 free bytes. This +-- optimization is not observationally equivalent in a strict sense, as it +-- influences the boundaries of the generated chunks. However, for a user of +-- this library it is observationally equivalent, as chunk boundaries of a lazy +-- 'L.ByteString' can only be observed through the internal interface. +-- Morevoer, we expect that all 'Encoding's write much fewer than 4kb (the +-- default short buffer size). Hence, it is safe to ignore the additional +-- memory spilled due to the more agressive buffer wrapping introduced by this +-- optimization. +-- +{-# INLINE[1] encodeWithB #-} +encodeWithB :: BoundedEncoding a -> (a -> Builder) +encodeWithB w = + mkBuilder + where + bound = I.sizeBound w + mkBuilder x = builder step + where + step k (BufferRange op ope) + | op `plusPtr` bound <= ope = do + op' <- runB w x op + let !br' = BufferRange op' ope + k br' + | otherwise = return $ bufferFull bound op (step k) + +{-# RULES + +"append/encodeWithB" forall w1 w2 x1 x2. + append (encodeWithB w1 x1) (encodeWithB w2 x2) + = encodeWithB (pairB w1 w2) (x1, x2) + +"append/encodeWithB/assoc_r" forall w1 w2 x1 x2 b. + append (encodeWithB w1 x1) (append (encodeWithB w2 x2) b) + = append (encodeWithB (pairB w1 w2) (x1, x2)) b + +"append/encodeWithB/assoc_l" forall w1 w2 x1 x2 b. + append (append b (encodeWithB w1 x1)) (encodeWithB w2 x2) + = append b (encodeWithB (pairB w1 w2) (x1, x2)) + #-} + +-- TODO: The same rules for 'putBuilder (..) >> putBuilder (..)' + +-- | Create a 'Builder' that encodes a list of values consecutively using an +-- 'Encoding'. This function is more efficient than the canonical +-- +-- > filter p = +-- > B.toLazyByteString . +-- > E.encodeLazyByteStringWithF (E.ifF p E.word8) E.emptyF) +-- > +-- +-- > mconcat . map (encodeWithB w) +-- +-- or +-- +-- > foldMap (encodeWithB w) +-- +-- because it moves several variables out of the inner loop. +{-# INLINE encodeListWithB #-} +encodeListWithB :: BoundedEncoding a -> [a] -> Builder +encodeListWithB w = + makeBuilder + where + bound = I.sizeBound w + makeBuilder xs0 = builder $ step xs0 + where + step xs1 k !(BufferRange op0 ope0) = go xs1 op0 + where + go [] !op = do + let !br' = BufferRange op ope0 + k br' + + go xs@(x':xs') !op + | op `plusPtr` bound <= ope0 = do + !op' <- runB w x' op + go xs' op' + | otherwise = return $ bufferFull bound op (step xs k) + +-- TODO: Add 'foldMap/encodeWith' its variants +-- TODO: Ensure rewriting 'encodeWithB w . f = encodeWithB (w #. f)' + +-- | Create a 'Builder' that encodes a sequence generated from a seed value +-- using an 'Encoding'. +{-# INLINE encodeUnfoldrWithB #-} +encodeUnfoldrWithB :: BoundedEncoding b -> (a -> Maybe (b, a)) -> a -> Builder +encodeUnfoldrWithB w = + makeBuilder + where + bound = I.sizeBound w + makeBuilder f x0 = builder $ step x0 + where + step x1 !k = fill x1 + where + fill x !(BufferRange pf0 pe0) = go (f x) pf0 + where + go !Nothing !pf = do + let !br' = BufferRange pf pe0 + k br' + go !(Just (y, x')) !pf + | pf `plusPtr` bound <= pe0 = do + !pf' <- runB w y pf + go (f x') pf' + | otherwise = return $ bufferFull bound pf $ + \(BufferRange pfNew peNew) -> do + !pfNew' <- runB w y pfNew + fill x' (BufferRange pfNew' peNew) + +-- | Create a 'Builder' that encodes each 'Word8' of a strict 'S.ByteString' +-- using an 'Encoding'. For example, we can write a 'Builder' that filters +-- a strict 'S.ByteString' as follows. +-- +-- > import Codec.Bounded.Encoding as E (encodeIf, word8, encodeNothing) +-- +-- > filterBS p = E.encodeIf p E.word8 E.encodeNothing +-- +{-# INLINE encodeByteStringWithB #-} +encodeByteStringWithB :: BoundedEncoding Word8 -> S.ByteString -> Builder +encodeByteStringWithB w = + \bs -> builder $ step bs + where + bound = I.sizeBound w + step (S.PS ifp ioff isize) !k = + goBS (unsafeForeignPtrToPtr ifp `plusPtr` ioff) + where + !ipe = unsafeForeignPtrToPtr ifp `plusPtr` (ioff + isize) + goBS !ip0 !br@(BufferRange op0 ope) + | ip0 >= ipe = do + touchForeignPtr ifp -- input buffer consumed + k br + + | op0 `plusPtr` bound < ope = + goPartial (ip0 `plusPtr` min outRemaining inpRemaining) + + | otherwise = return $ bufferFull bound op0 (goBS ip0) + where + outRemaining = (ope `minusPtr` op0) `div` bound + inpRemaining = ipe `minusPtr` ip0 + + goPartial !ipeTmp = go ip0 op0 + where + go !ip !op + | ip < ipeTmp = do + x <- peek ip + op' <- runB w x op + go (ip `plusPtr` 1) op' + | otherwise = + goBS ip (BufferRange op ope) + +-- | Chunk-wise application of 'encodeByteStringWith'. +{-# INLINE encodeLazyByteStringWithB #-} +encodeLazyByteStringWithB :: BoundedEncoding Word8 -> L.ByteString -> Builder +encodeLazyByteStringWithB w = + L.foldrChunks (\x b -> encodeByteStringWithB w x `mappend` b) mempty + + +------------------------------------------------------------------------------ +-- Char8 encoding +------------------------------------------------------------------------------ + +-- | Char8 encode a 'Char'. +{-# INLINE char8 #-} +char8 :: FixedEncoding Char +char8 = (fromIntegral . ord) >$< word8 + + +------------------------------------------------------------------------------ +-- UTF-8 encoding +------------------------------------------------------------------------------ + +-- | UTF-8 encode a 'Char'. +{-# INLINE charUtf8 #-} +charUtf8 :: BoundedEncoding Char +charUtf8 = boundedEncoding 4 (encodeCharUtf8 f1 f2 f3 f4) + where + pokeN n io op = io op >> return (op `plusPtr` n) + + f1 x1 = pokeN 1 $ \op -> do pokeByteOff op 0 x1 + + f2 x1 x2 = pokeN 2 $ \op -> do pokeByteOff op 0 x1 + pokeByteOff op 1 x2 + + f3 x1 x2 x3 = pokeN 3 $ \op -> do pokeByteOff op 0 x1 + pokeByteOff op 1 x2 + pokeByteOff op 2 x3 + + f4 x1 x2 x3 x4 = pokeN 4 $ \op -> do pokeByteOff op 0 x1 + pokeByteOff op 1 x2 + pokeByteOff op 2 x3 + pokeByteOff op 3 x4 + +-- | Encode a Unicode character to another datatype, using UTF-8. This function +-- acts as an abstract way of encoding characters, as it is unaware of what +-- needs to happen with the resulting bytes: you have to specify functions to +-- deal with those. +-- +{-# INLINE encodeCharUtf8 #-} +encodeCharUtf8 :: (Word8 -> a) -- ^ 1-byte UTF-8 + -> (Word8 -> Word8 -> a) -- ^ 2-byte UTF-8 + -> (Word8 -> Word8 -> Word8 -> a) -- ^ 3-byte UTF-8 + -> (Word8 -> Word8 -> Word8 -> Word8 -> a) -- ^ 4-byte UTF-8 + -> Char -- ^ Input 'Char' + -> a -- ^ Result +encodeCharUtf8 f1 f2 f3 f4 c = case ord c of + x | x <= 0x7F -> f1 $ fromIntegral x + | x <= 0x07FF -> + let x1 = fromIntegral $ (x `shiftR` 6) + 0xC0 + x2 = fromIntegral $ (x .&. 0x3F) + 0x80 + in f2 x1 x2 + | x <= 0xFFFF -> + let x1 = fromIntegral $ (x `shiftR` 12) + 0xE0 + x2 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80 + x3 = fromIntegral $ (x .&. 0x3F) + 0x80 + in f3 x1 x2 x3 + | otherwise -> + let x1 = fromIntegral $ (x `shiftR` 18) + 0xF0 + x2 = fromIntegral $ ((x `shiftR` 12) .&. 0x3F) + 0x80 + x3 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80 + x4 = fromIntegral $ (x .&. 0x3F) + 0x80 + in f4 x1 x2 x3 x4 + + +------------------------------------------------------------------------------ +-- Testing encodings +------------------------------------------------------------------------------ + +-- | /For testing use only./ Evaluate a 'FixedEncoding' on a given value. +evalF :: FixedEncoding a -> a -> [Word8] +evalF fe = S.unpack . S.unsafeCreate (I.size fe) . runF fe + +-- | /For testing use only./ Evaluate a 'BoundedEncoding' on a given value. +evalB :: BoundedEncoding a -> a -> [Word8] +evalB be x = S.unpack $ unsafePerformIO $ + S.createAndTrim (I.sizeBound be) $ \op -> do + op' <- runB be x op + return (op' `minusPtr` op) + +-- | /For testing use only./ Show the result of a 'FixedEncoding' of a given +-- value as a 'String' by interpreting the resulting bytes as Unicode +-- codepoints. +showF :: FixedEncoding a -> a -> String +showF fe = map (chr . fromIntegral) . evalF fe + +-- | /For testing use only./ Show the result of a 'BoundedEncoding' of a given +-- value as a 'String' by interpreting the resulting bytes as Unicode +-- codepoints. +showB :: BoundedEncoding a -> a -> String +showB be = map (chr . fromIntegral) . evalB be + + diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/ASCII.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/ASCII.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/Builder/BasicEncoding/ASCII.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE ScopedTypeVariables, CPP, ForeignFunctionInterface #-} +-- | Copyright : (c) 2010 Jasper Van der Jeugt +-- (c) 2010 - 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC +-- +-- Encodings using ASCII encoded Unicode characters. +-- +module Data.ByteString.Lazy.Builder.BasicEncoding.ASCII + ( + + -- *** ASCII + char7 + + -- **** Decimal numbers + -- | Decimal encoding of numbers using ASCII encoded characters. + , int8Dec + , int16Dec + , int32Dec + , int64Dec + , intDec + + , word8Dec + , word16Dec + , word32Dec + , word64Dec + , wordDec + + {- + -- These are the functions currently provided by Bryan O'Sullivans + -- double-conversion library. + -- + -- , float + -- , floatWith + -- , double + -- , doubleWith + -} + + -- **** Hexadecimal numbers + + -- | Encoding positive integers as hexadecimal numbers using lower-case + -- ASCII characters. The shortest possible representation is used. For + -- example, + -- + -- > showB word16Hex 0x0a10 = "a10" + -- + -- Note that there is no support for using upper-case characters. Please + -- contact the maintainer if your application cannot work without + -- hexadecimal encodings that use upper-case characters. + -- + , word8Hex + , word16Hex + , word32Hex + , word64Hex + , wordHex + + -- **** Fixed-width hexadecimal numbers + -- + -- | Encoding the bytes of fixed-width types as hexadecimal + -- numbers using lower-case ASCII characters. For example, + -- + -- > showF word16HexFixed 0x0a10 = "0a10" + -- + , int8HexFixed + , int16HexFixed + , int32HexFixed + , int64HexFixed + , word8HexFixed + , word16HexFixed + , word32HexFixed + , word64HexFixed + , floatHexFixed + , doubleHexFixed + + ) where + +import Data.ByteString.Lazy.Builder.BasicEncoding.Binary +import Data.ByteString.Lazy.Builder.BasicEncoding.Internal +import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Floating +import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Base16 +import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.UncheckedShifts + +import Data.Char (ord) + +import Foreign +import Foreign.C.Types + +-- | Encode the least 7-bits of a 'Char' using the ASCII encoding. +{-# INLINE char7 #-} +char7 :: FixedEncoding Char +char7 = (\c -> fromIntegral $ ord c .&. 0x7f) >$< word8 + + +------------------------------------------------------------------------------ +-- Decimal Encoding +------------------------------------------------------------------------------ + +-- Signed integers +------------------ + +foreign import ccall unsafe "static _hs_bytestring_int_dec" c_int_dec + :: CInt -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_long_long_int_dec" c_long_long_int_dec + :: CLLong -> Ptr Word8 -> IO (Ptr Word8) + +{-# INLINE encodeIntDecimal #-} +encodeIntDecimal :: Integral a => Int -> BoundedEncoding a +encodeIntDecimal bound = boundedEncoding bound $ c_int_dec . fromIntegral + +-- | Decimal encoding of an 'Int8'. +{-# INLINE int8Dec #-} +int8Dec :: BoundedEncoding Int8 +int8Dec = encodeIntDecimal 4 + +-- | Decimal encoding of an 'Int16'. +{-# INLINE int16Dec #-} +int16Dec :: BoundedEncoding Int16 +int16Dec = encodeIntDecimal 6 + + +-- | Decimal encoding of an 'Int32'. +{-# INLINE int32Dec #-} +int32Dec :: BoundedEncoding Int32 +int32Dec = encodeIntDecimal 11 + +-- | Decimal encoding of an 'Int64'. +{-# INLINE int64Dec #-} +int64Dec :: BoundedEncoding Int64 +int64Dec = boundedEncoding 20 $ c_long_long_int_dec . fromIntegral + +-- | Decimal encoding of an 'Int'. +{-# INLINE intDec #-} +intDec :: BoundedEncoding Int +intDec = caseWordSize_32_64 + (fromIntegral >$< int32Dec) + (fromIntegral >$< int64Dec) + + +-- Unsigned integers +-------------------- + +foreign import ccall unsafe "static _hs_bytestring_uint_dec" c_uint_dec + :: CUInt -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_long_long_uint_dec" c_long_long_uint_dec + :: CULLong -> Ptr Word8 -> IO (Ptr Word8) + +{-# INLINE encodeWordDecimal #-} +encodeWordDecimal :: Integral a => Int -> BoundedEncoding a +encodeWordDecimal bound = boundedEncoding bound $ c_uint_dec . fromIntegral + +-- | Decimal encoding of a 'Word8'. +{-# INLINE word8Dec #-} +word8Dec :: BoundedEncoding Word8 +word8Dec = encodeWordDecimal 3 + +-- | Decimal encoding of a 'Word16'. +{-# INLINE word16Dec #-} +word16Dec :: BoundedEncoding Word16 +word16Dec = encodeWordDecimal 5 + +-- | Decimal encoding of a 'Word32'. +{-# INLINE word32Dec #-} +word32Dec :: BoundedEncoding Word32 +word32Dec = encodeWordDecimal 10 + +-- | Decimal encoding of a 'Word64'. +{-# INLINE word64Dec #-} +word64Dec :: BoundedEncoding Word64 +word64Dec = boundedEncoding 20 $ c_long_long_uint_dec . fromIntegral + +-- | Decimal encoding of a 'Word'. +{-# INLINE wordDec #-} +wordDec :: BoundedEncoding Word +wordDec = caseWordSize_32_64 + (fromIntegral >$< word32Dec) + (fromIntegral >$< word64Dec) + +------------------------------------------------------------------------------ +-- Hexadecimal Encoding +------------------------------------------------------------------------------ + +-- without lead +--------------- + +foreign import ccall unsafe "static _hs_bytestring_uint_hex" c_uint_hex + :: CUInt -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static _hs_bytestring_long_long_uint_hex" c_long_long_uint_hex + :: CULLong -> Ptr Word8 -> IO (Ptr Word8) + +{-# INLINE encodeWordHex #-} +encodeWordHex :: forall a. (Storable a, Integral a) => BoundedEncoding a +encodeWordHex = + boundedEncoding (2 * sizeOf (undefined :: a)) $ c_uint_hex . fromIntegral + +-- | Hexadecimal encoding of a 'Word8'. +{-# INLINE word8Hex #-} +word8Hex :: BoundedEncoding Word8 +word8Hex = encodeWordHex + +-- | Hexadecimal encoding of a 'Word16'. +{-# INLINE word16Hex #-} +word16Hex :: BoundedEncoding Word16 +word16Hex = encodeWordHex + +-- | Hexadecimal encoding of a 'Word32'. +{-# INLINE word32Hex #-} +word32Hex :: BoundedEncoding Word32 +word32Hex = encodeWordHex + +-- | Hexadecimal encoding of a 'Word64'. +{-# INLINE word64Hex #-} +word64Hex :: BoundedEncoding Word64 +word64Hex = boundedEncoding 16 $ c_long_long_uint_hex . fromIntegral + +-- | Hexadecimal encoding of a 'Word'. +{-# INLINE wordHex #-} +wordHex :: BoundedEncoding Word +wordHex = caseWordSize_32_64 + (fromIntegral >$< word32Hex) + (fromIntegral >$< word64Hex) + + +-- fixed width; leading zeroes +------------------------------ + +-- | Encode a 'Word8' using 2 nibbles (hexadecimal digits). +{-# INLINE word8HexFixed #-} +word8HexFixed :: FixedEncoding Word8 +word8HexFixed = fixedEncoding 2 $ + \x op -> poke (castPtr op) =<< encode8_as_16h lowerTable x + +-- | Encode a 'Word16' using 4 nibbles. +{-# INLINE word16HexFixed #-} +word16HexFixed :: FixedEncoding Word16 +word16HexFixed = + (\x -> (fromIntegral $ x `shiftr_w16` 8, fromIntegral x)) + >$< pairF word8HexFixed word8HexFixed + +-- | Encode a 'Word32' using 8 nibbles. +{-# INLINE word32HexFixed #-} +word32HexFixed :: FixedEncoding Word32 +word32HexFixed = + (\x -> (fromIntegral $ x `shiftr_w32` 16, fromIntegral x)) + >$< pairF word16HexFixed word16HexFixed +-- | Encode a 'Word64' using 16 nibbles. +{-# INLINE word64HexFixed #-} +word64HexFixed :: FixedEncoding Word64 +word64HexFixed = + (\x -> (fromIntegral $ x `shiftr_w64` 32, fromIntegral x)) + >$< pairF word32HexFixed word32HexFixed + +-- | Encode a 'Int8' using 2 nibbles (hexadecimal digits). +{-# INLINE int8HexFixed #-} +int8HexFixed :: FixedEncoding Int8 +int8HexFixed = fromIntegral >$< word8HexFixed + +-- | Encode a 'Int16' using 4 nibbles. +{-# INLINE int16HexFixed #-} +int16HexFixed :: FixedEncoding Int16 +int16HexFixed = fromIntegral >$< word16HexFixed + +-- | Encode a 'Int32' using 8 nibbles. +{-# INLINE int32HexFixed #-} +int32HexFixed :: FixedEncoding Int32 +int32HexFixed = fromIntegral >$< word32HexFixed + +-- | Encode a 'Int64' using 16 nibbles. +{-# INLINE int64HexFixed #-} +int64HexFixed :: FixedEncoding Int64 +int64HexFixed = fromIntegral >$< word64HexFixed + +-- | Encode an IEEE 'Float' using 8 nibbles. +{-# INLINE floatHexFixed #-} +floatHexFixed :: FixedEncoding Float +floatHexFixed = encodeFloatViaWord32F word32HexFixed + +-- | Encode an IEEE 'Double' using 16 nibbles. +{-# INLINE doubleHexFixed #-} +doubleHexFixed :: FixedEncoding Double +doubleHexFixed = encodeDoubleViaWord64F word64HexFixed + + diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/Binary.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/Binary.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/Builder/BasicEncoding/Binary.hs @@ -0,0 +1,336 @@ +{-# LANGUAGE CPP, BangPatterns #-} +-- | Copyright : (c) 2010-2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC +-- +module Data.ByteString.Lazy.Builder.BasicEncoding.Binary ( + + -- ** Binary encodings + int8 + , word8 + + -- *** Big-endian + , int16BE + , int32BE + , int64BE + + , word16BE + , word32BE + , word64BE + + , floatBE + , doubleBE + + -- *** Little-endian + , int16LE + , int32LE + , int64LE + + , word16LE + , word32LE + , word64LE + + , floatLE + , doubleLE + + -- *** Non-portable, host-dependent + , intHost + , int16Host + , int32Host + , int64Host + + , wordHost + , word16Host + , word32Host + , word64Host + + , floatHost + , doubleHost + + ) where + +import Data.ByteString.Lazy.Builder.BasicEncoding.Internal +import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.UncheckedShifts +import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Floating + +import Foreign + +#include "MachDeps.h" + +------------------------------------------------------------------------------ +-- Binary encoding +------------------------------------------------------------------------------ + +-- Word encodings +----------------- + +-- | Encoding single unsigned bytes as-is. +-- +{-# INLINE word8 #-} +word8 :: FixedEncoding Word8 +word8 = storableToF + +-- +-- We rely on the fromIntegral to do the right masking for us. +-- The inlining here is critical, and can be worth 4x performance +-- + +-- | Encoding 'Word16's in big endian format. +{-# INLINE word16BE #-} +word16BE :: FixedEncoding Word16 +#ifdef WORD_BIGENDIAN +word16BE = word16Host +#else +word16BE = fixedEncoding 2 $ \w p -> do + poke p (fromIntegral (shiftr_w16 w 8) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (w) :: Word8) +#endif + +-- | Encoding 'Word16's in little endian format. +{-# INLINE word16LE #-} +word16LE :: FixedEncoding Word16 +#ifdef WORD_BIGENDIAN +word16LE = fixedEncoding 2 $ \w p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8) +#else +word16LE = word16Host +#endif + +-- | Encoding 'Word32's in big endian format. +{-# INLINE word32BE #-} +word32BE :: FixedEncoding Word32 +#ifdef WORD_BIGENDIAN +word32BE = word32Host +#else +word32BE = fixedEncoding 4 $ \w p -> do + poke p (fromIntegral (shiftr_w32 w 24) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (w) :: Word8) +#endif + +-- | Encoding 'Word32's in little endian format. +{-# INLINE word32LE #-} +word32LE :: FixedEncoding Word32 +#ifdef WORD_BIGENDIAN +word32LE = fixedEncoding 4 $ \w p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 w 24) :: Word8) +#else +word32LE = word32Host +#endif + +-- on a little endian machine: +-- word32LE w32 = fixedEncoding 4 (\w p -> poke (castPtr p) w32) + +-- | Encoding 'Word64's in big endian format. +{-# INLINE word64BE #-} +word64BE :: FixedEncoding Word64 +#ifdef WORD_BIGENDIAN +word64BE = word64Host +#else +#if WORD_SIZE_IN_BITS < 64 +-- +-- To avoid expensive 64 bit shifts on 32 bit machines, we cast to +-- Word32, and write that +-- +word64BE = + fixedEncoding 8 $ \w p -> do + let a = fromIntegral (shiftr_w64 w 32) :: Word32 + b = fromIntegral w :: Word32 + poke p (fromIntegral (shiftr_w32 a 24) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 8) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (a) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 8) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (b) :: Word8) +#else +word64BE = fixedEncoding 8 $ \w p -> do + poke p (fromIntegral (shiftr_w64 w 56) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 32) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 24) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 16) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 8) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (w) :: Word8) +#endif +#endif + +-- | Encoding 'Word64's in little endian format. +{-# INLINE word64LE #-} +word64LE :: FixedEncoding Word64 +#ifdef WORD_BIGENDIAN +#if WORD_SIZE_IN_BITS < 64 +word64LE = + fixedEncoding 8 $ \w p -> do + let b = fromIntegral (shiftr_w64 w 32) :: Word32 + a = fromIntegral w :: Word32 + poke (p) (fromIntegral (a) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 a 24) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (b) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 8) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8) +#else +word64LE = fixedEncoding 8 $ \w p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 24) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 32) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 40) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 48) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (shiftr_w64 w 56) :: Word8) +#endif +#else +word64LE = word64Host +#endif + + +-- | Encode a single native machine 'Word'. The 'Word's is encoded in host order, +-- host endian form, for the machine you are on. On a 64 bit machine the 'Word' +-- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way +-- are not portable to different endian or word sized machines, without +-- conversion. +-- +{-# INLINE wordHost #-} +wordHost :: FixedEncoding Word +wordHost = storableToF + +-- | Encoding 'Word16's in native host order and host endianness. +{-# INLINE word16Host #-} +word16Host :: FixedEncoding Word16 +word16Host = storableToF + +-- | Encoding 'Word32's in native host order and host endianness. +{-# INLINE word32Host #-} +word32Host :: FixedEncoding Word32 +word32Host = storableToF + +-- | Encoding 'Word64's in native host order and host endianness. +{-# INLINE word64Host #-} +word64Host :: FixedEncoding Word64 +word64Host = storableToF + + +------------------------------------------------------------------------------ +-- Int encodings +------------------------------------------------------------------------------ +-- +-- We rely on 'fromIntegral' to do a loss-less conversion to the corresponding +-- 'Word' type +-- +------------------------------------------------------------------------------ + +-- | Encoding single signed bytes as-is. +-- +{-# INLINE int8 #-} +int8 :: FixedEncoding Int8 +int8 = fromIntegral >$< word8 + +-- | Encoding 'Int16's in big endian format. +{-# INLINE int16BE #-} +int16BE :: FixedEncoding Int16 +int16BE = fromIntegral >$< word16BE + +-- | Encoding 'Int16's in little endian format. +{-# INLINE int16LE #-} +int16LE :: FixedEncoding Int16 +int16LE = fromIntegral >$< word16LE + +-- | Encoding 'Int32's in big endian format. +{-# INLINE int32BE #-} +int32BE :: FixedEncoding Int32 +int32BE = fromIntegral >$< word32BE + +-- | Encoding 'Int32's in little endian format. +{-# INLINE int32LE #-} +int32LE :: FixedEncoding Int32 +int32LE = fromIntegral >$< word32LE + +-- | Encoding 'Int64's in big endian format. +{-# INLINE int64BE #-} +int64BE :: FixedEncoding Int64 +int64BE = fromIntegral >$< word64BE + +-- | Encoding 'Int64's in little endian format. +{-# INLINE int64LE #-} +int64LE :: FixedEncoding Int64 +int64LE = fromIntegral >$< word64LE + + +-- TODO: Ensure that they are safe on architectures where an unaligned write is +-- an error. + +-- | Encode a single native machine 'Int'. The 'Int's is encoded in host order, +-- host endian form, for the machine you are on. On a 64 bit machine the 'Int' +-- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way +-- are not portable to different endian or integer sized machines, without +-- conversion. +-- +{-# INLINE intHost #-} +intHost :: FixedEncoding Int +intHost = storableToF + +-- | Encoding 'Int16's in native host order and host endianness. +{-# INLINE int16Host #-} +int16Host :: FixedEncoding Int16 +int16Host = storableToF + +-- | Encoding 'Int32's in native host order and host endianness. +{-# INLINE int32Host #-} +int32Host :: FixedEncoding Int32 +int32Host = storableToF + +-- | Encoding 'Int64's in native host order and host endianness. +{-# INLINE int64Host #-} +int64Host :: FixedEncoding Int64 +int64Host = storableToF + +-- IEEE Floating Point Numbers +------------------------------ + +-- | Encode a 'Float' in big endian format. +{-# INLINE floatBE #-} +floatBE :: FixedEncoding Float +floatBE = encodeFloatViaWord32F word32BE + +-- | Encode a 'Float' in little endian format. +{-# INLINE floatLE #-} +floatLE :: FixedEncoding Float +floatLE = encodeFloatViaWord32F word32LE + +-- | Encode a 'Double' in big endian format. +{-# INLINE doubleBE #-} +doubleBE :: FixedEncoding Double +doubleBE = encodeDoubleViaWord64F word64BE + +-- | Encode a 'Double' in little endian format. +{-# INLINE doubleLE #-} +doubleLE :: FixedEncoding Double +doubleLE = encodeDoubleViaWord64F word64LE + + +-- | Encode a 'Float' in native host order and host endianness. Values written +-- this way are not portable to different endian machines, without conversion. +-- +{-# INLINE floatHost #-} +floatHost :: FixedEncoding Float +floatHost = storableToF + +-- | Encode a 'Double' in native host order and host endianness. +{-# INLINE doubleHost #-} +doubleHost :: FixedEncoding Double +doubleHost = storableToF + + diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/Extras.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/Extras.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/Builder/BasicEncoding/Extras.hs @@ -0,0 +1,890 @@ +{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_HADDOCK hide #-} +{- | Copyright : (c) 2010-2011 Simon Meier +License : BSD3-style (see LICENSE) + +Maintainer : Simon Meier +Stability : experimental +Portability : GHC + +An /encoding/ is a conversion function of Haskell values to sequences of bytes. +A /fixed(-size) encoding/ is an encoding that always results in sequence of bytes + of a pre-determined, fixed length. +An example for a fixed encoding is the big-endian encoding of a 'Word64', + which always results in exactly 8 bytes. +A /bounded(-size) encoding/ is an encoding that always results in sequence + of bytes that is no larger than a pre-determined bound. +An example for a bounded encoding is the UTF-8 encoding of a 'Char', + which results always in less or equal to 4 bytes. +Note that every fixed encoding is also a bounded encoding. +We explicitly identify fixed encodings because they allow some optimizations + that are impossible with bounded encodings. +In the following, + we first motivate the use of bounded encodings + and then give examples of optimizations + that are only possible with fixed encodings. + +Typicall, encodings are implemented efficiently by allocating a buffer + (a mutable array of bytes) + and repeatedly executing the following two steps: + (1) writing to the buffer until it is full and + (2) handing over the filled part to the consumer of the encoded value. +Step (1) is where bounded encodings are used. +We must use a bounded encoding, + as we must check that there is enough free space + /before/ actually writing to the buffer. + +In term of expressivity, + it would be sufficient to construct all encodings + from the single fixed encoding that encodes a 'Word8' as-is. +However, + this is not sufficient in terms of efficiency. +It results in unnecessary buffer-full checks and + it complicates the program-flow for writing to the buffer, + as buffer-full checks are interleaved with analyzing the value to be + encoded (e.g., think about the program-flow for UTF-8 encoding). +This has a significant effect on overall encoding performance, + as encoding primitive Haskell values such as 'Word8's or 'Char's + lies at the heart of every encoding implementation. + +The 'BoundedEncoding's provided by this module remove this performance problem. +Intuitively, + they consist of a tuple of the bound on the maximal number of bytes written + and the actual implementation of the encoding as + a function that modifies a mutable buffer. +Hence when executing a 'BoundedEncoding', + the buffer-full check can be done once before the actual writing to the buffer. +The provided 'BoundedEncoding's also take care to implement the + actual writing to the buffer efficiently. +Moreover, combinators are provided to construct new bounded encodings + from the provided ones. + + + +The result of an encoding can be consumed efficiently, + if it is represented as a sequence of large enough + /chunks/ of consecutive memory (i.e., C @char@ arrays). +The precise meaning of /large enough/ is application dependent. +Typically, an average chunk size between 4kb and 32kb is suitable + for writing the result to disk or sending it over the network. +We desire large enough chunk sizes because each chunk boundary + incurs extra work that we must be able to amortize. + + +The need for fixed-size encodings arises when considering + the efficient implementation of encodings that require the encoding of a + value to be prefixed with the size of the resulting sequence of bytes. +An efficient implementation avoids unnecessary buffer +We can implement this efficiently as follows. +We first reserve the space for the encoding of the size. +Then, we encode the value. +Finally, we encode the size of the resulting sequence of bytes into + the reserved space. +For this to work + +This works only if the encoding resulting size fits + +by first, reserving the space for the encoding + of the size, then performing the + +For efficiency, + we want to avoid unnecessary copying. + + +For example, the HTTP/1.0 requires the size of the body to be given in + the Content-Length field. + +chunked-transfer encoding requires each chunk to + be prefixed with the hexadecimal encoding of the chunk size. + + +-} + +{- +-- +-- +-- A /bounded encoding/ is an encoding that never results in a sequence +-- longer than some fixed number of bytes. This number of bytes must be +-- independent of the value being encoded. Typical examples of bounded +-- encodings are the big-endian encoding of a 'Word64', which results always +-- in exactly 8 bytes, or the UTF-8 encoding of a 'Char', which results always +-- in less or equal to 4 bytes. +-- +-- Typically, encodings are implemented efficiently by allocating a buffer (an +-- array of bytes) and repeatedly executing the following two steps: (1) +-- writing to the buffer until it is full and (2) handing over the filled part +-- to the consumer of the encoded value. Step (1) is where bounded encodings +-- are used. We must use a bounded encoding, as we must check that there is +-- enough free space /before/ actually writing to the buffer. +-- +-- In term of expressivity, it would be sufficient to construct all encodings +-- from the single bounded encoding that encodes a 'Word8' as-is. However, +-- this is not sufficient in terms of efficiency. It results in unnecessary +-- buffer-full checks and it complicates the program-flow for writing to the +-- buffer, as buffer-full checks are interleaved with analyzing the value to be +-- encoded (e.g., think about the program-flow for UTF-8 encoding). This has a +-- significant effect on overall encoding performance, as encoding primitive +-- Haskell values such as 'Word8's or 'Char's lies at the heart of every +-- encoding implementation. +-- +-- The bounded 'Encoding's provided by this module remove this performance +-- problem. Intuitively, they consist of a tuple of the bound on the maximal +-- number of bytes written and the actual implementation of the encoding as a +-- function that modifies a mutable buffer. Hence when executing a bounded +-- 'Encoding', the buffer-full check can be done once before the actual writing +-- to the buffer. The provided 'Encoding's also take care to implement the +-- actual writing to the buffer efficiently. Moreover, combinators are +-- provided to construct new bounded encodings from the provided ones. +-- +-- A typical example for using the combinators is a bounded 'Encoding' that +-- combines escaping the ' and \\ characters with UTF-8 encoding. More +-- precisely, the escaping to be done is the one implemented by the following +-- @escape@ function. +-- +-- > escape :: Char -> [Char] +-- > escape '\'' = "\\'" +-- > escape '\\' = "\\\\" +-- > escape c = [c] +-- +-- The bounded 'Encoding' that combines this escaping with UTF-8 encoding is +-- the following. +-- +-- > import Data.ByteString.Lazy.Builder.BasicEncoding.Utf8 (char) +-- > +-- > {-# INLINE escapeChar #-} +-- > escapeUtf8 :: BoundedEncoding Char +-- > escapeUtf8 = +-- > encodeIf ('\'' ==) (char <#> char #. const ('\\','\'')) $ +-- > encodeIf ('\\' ==) (char <#> char #. const ('\\','\\')) $ +-- > char +-- +-- The definition of 'escapeUtf8' is more complicated than 'escape', because +-- the combinators ('encodeIf', 'encodePair', '#.', and 'char') used in +-- 'escapeChar' compute both the bound on the maximal number of bytes written +-- (8 for 'escapeUtf8') as well as the low-level buffer manipulation required +-- to implement the encoding. Bounded 'Encoding's should always be inlined. +-- Otherwise, the compiler cannot compute the bound on the maximal number of +-- bytes written at compile-time. Without inlinining, it would also fail to +-- optimize the constant encoding of the escape characters in the above +-- example. Functions that execute bounded 'Encoding's also perform +-- suboptimally, if the definition of the bounded 'Encoding' is not inlined. +-- Therefore we add an 'INLINE' pragma to 'escapeUtf8'. +-- +-- Currently, the only library that executes bounded 'Encoding's is the +-- 'bytestring' library (). It +-- uses bounded 'Encoding's to implement most of its lazy bytestring builders. +-- Executing a bounded encoding should be done using the corresponding +-- functions in the lazy bytestring builder 'Extras' module. +-- +-- TODO: Merge with explanation/example below +-- +-- Bounded 'E.Encoding's abstract encodings of Haskell values that can be implemented by +-- writing a bounded-size sequence of bytes directly to memory. They are +-- lifted to conversions from Haskell values to 'Builder's by wrapping them +-- with a bound-check. The compiler can implement this bound-check very +-- efficiently (i.e, a single comparison of the difference of two pointers to a +-- constant), because the bound of a 'E.Encoding' is always independent of the +-- value being encoded and, in most cases, a literal constant. +-- +-- 'E.Encoding's are the primary means for defining conversion functions from +-- primitive Haskell values to 'Builder's. Most 'Builder' constructors +-- provided by this library are implemented that way. +-- 'E.Encoding's are also used to construct conversions that exploit the internal +-- representation of data-structures. +-- +-- For example, 'encodeByteStringWith' works directly on the underlying byte +-- array and uses some tricks to reduce the number of variables in its inner +-- loop. Its efficiency is exploited for implementing the @filter@ and @map@ +-- functions in "Data.ByteString.Lazy" as +-- +-- > import qualified Codec.Bounded.Encoding as E +-- > +-- > filter :: (Word8 -> Bool) -> ByteString -> ByteString +-- > filter p = toLazyByteString . encodeLazyByteStringWithB write +-- > where +-- > write = E.encodeIf p E.word8 E.emptyEncoding +-- > +-- > map :: (Word8 -> Word8) -> ByteString -> ByteString +-- > map f = toLazyByteString . encodeLazyByteStringWithB (E.word8 E.#. f) +-- +-- Compared to earlier versions of @filter@ and @map@ on lazy 'L.ByteString's, +-- these versions use a more efficient inner loop and have the additional +-- advantage that they always result in well-chunked 'L.ByteString's; i.e, they +-- also perform automatic defragmentation. +-- +-- We can also use 'E.Encoding's to improve the efficiency of the following +-- 'renderString' function from our UTF-8 CSV table encoding example in +-- "Data.ByteString.Lazy.Builder". +-- +-- > renderString :: String -> Builder +-- > renderString cs = charUtf8 '"' <> foldMap escape cs <> charUtf8 '"' +-- > where +-- > escape '\\' = charUtf8 '\\' <> charUtf8 '\\' +-- > escape '\"' = charUtf8 '\\' <> charUtf8 '\"' +-- > escape c = charUtf8 c +-- +-- The idea is to save on 'mappend's by implementing a 'E.Encoding' that escapes +-- characters and using 'encodeListWith', which implements writing a list of +-- values with a tighter inner loop and no 'mappend'. +-- +-- > import Data.ByteString.Lazy.Builder.Extras -- assume these three +-- > import Codec.Bounded.Encoding -- imports are present +-- > ( BoundedEncoding, encodeIf, (<#>), (#.) ) +-- > import Data.ByteString.Lazy.Builder.BasicEncoding.Utf8 (char) +-- > +-- > renderString :: String -> Builder +-- > renderString cs = +-- > charUtf8 '"' <> encodeListWithB escapedUtf8 cs <> charUtf8 '"' +-- > where +-- > escapedUtf8 :: BoundedEncoding Char +-- > escapedUtf8 = +-- > encodeIf (== '\\') (char <#> char #. const ('\\', '\\')) $ +-- > encodeIf (== '\"') (char <#> char #. const ('\\', '\"')) $ +-- > char +-- +-- This 'Builder' considers a buffer with less than 8 free bytes as full. As +-- all functions are inlined, the compiler is able to optimize the constant +-- 'E.Encoding's as two sequential 'poke's. Compared to the first implementation of +-- 'renderString' this implementation is 1.7x faster. +-- +-} +{- +Internally, 'Builder's are buffer-fill operations that are +given a continuation buffer-fill operation and a buffer-range to be filled. +A 'Builder' first checks if the buffer-range is large enough. If that's +the case, the 'Builder' writes the sequences of bytes to the buffer and +calls its continuation. Otherwise, it returns a signal that it requires a +new buffer together with a continuation to be called on this new buffer. +Ignoring the rare case of a full buffer-range, the execution cost of a +'Builder' consists of three parts: + + 1. The time taken to read the parameters; i.e., the buffer-fill + operation to call after the 'Builder' is done and the buffer-range to + fill. + + 2. The time taken to check for the size of the buffer-range. + + 3. The time taken for the actual encoding. + +We can reduce cost (1) by ensuring that fewer buffer-fill function calls are +required. We can reduce cost (2) by fusing buffer-size checks of sequential +writes. For example, when escaping a 'String' using 'renderString', it would +be sufficient to check before encoding a character that at least 8 bytes are +free. We can reduce cost (3) by implementing better primitive 'Builder's. +For example, 'renderCell' builds an intermediate list containing the decimal +representation of an 'Int'. Implementing a direct decimal encoding of 'Int's +to memory would be more efficient, as it requires fewer buffer-size checks +and less allocation. It is also a planned extension of this library. + +The first two cost reductions are supported for user code through functions +in "Data.ByteString.Lazy.Builder.Extras". There, we continue the above example +and drop the generation time to 0.8ms by implementing 'renderString' more +cleverly. The third reduction requires meddling with the internals of +'Builder's and is not recomended in code outside of this library. However, +patches to this library are very welcome. +-} +module Data.ByteString.Lazy.Builder.BasicEncoding.Extras ( + + -- * Base-128, variable-length binary encodings + {- | +There are many options for implementing a base-128 (i.e, 7-bit), +variable-length encoding. The encoding implemented here is the one used by +Google's protocol buffer library +. This +encoding can be implemented efficiently and provides the desired property that +small positive integers result in short sequences of bytes. It is intended to +be used for the new default binary serialization format of the differently +sized 'Word' types. It works as follows. + +The most-significant bit (MSB) of each output byte indicates whether +there is a following byte (MSB set to 1) or it is the last byte (MSB set to 0). +The remaining 7-bits are used to encode the input starting with the least +significant 7-bit group of the input (i.e., a little-endian ordering of the +7-bit groups is used). + +For example, the value @1 :: Int@ is encoded as @[0x01]@. The value +@128 :: Int@, whose binary representation is @1000 0000@, is encoded as +@[0x80, 0x01]@; i.e., the first byte has its MSB set and the least significant +7-bit group is @000 0000@, the second byte has its MSB not set (it is the last +byte) and its 7-bit group is @000 0001@. +-} + word8Var + , word16Var + , word32Var + , word64Var + , wordVar + +{- | +The following encodings work by casting the signed integer to the equally sized +unsigned integer. This works well for positive integers, but for negative +integers it always results in the longest possible sequence of bytes, +as their MSB is (by definition) always set. +-} + + , int8Var + , int16Var + , int32Var + , int64Var + , intVar + +{- | +Positive and negative integers of small magnitude can be encoded compactly + using the so-called ZigZag encoding + (). +The /ZigZag encoding/ uses + even numbers to encode the postive integers and + odd numbers to encode the negative integers. +For example, + @0@ is encoded as @0@, @-1@ as @1@, @1@ as @2@, @-2@ as @3@, @2@ as @4@, and + so on. +Its efficient implementation uses some bit-level magic. +For example + +@ +zigZag32 :: 'Int32' -> 'Word32' +zigZag32 n = fromIntegral ((n \`shiftL\` 1) \`xor\` (n \`shiftR\` 31)) +@ + +Note that the 'shiftR' is an arithmetic shift that performs sign extension. +The ZigZag encoding essentially swaps the LSB with the MSB and additionally +inverts all bits if the MSB is set. + +The following encodings implement the combintion of ZigZag encoding + together with the above base-128, variable length encodings. +They are intended to become the the new default binary serialization format of + the differently sized 'Int' types. +-} + , int8VarSigned + , int16VarSigned + , int32VarSigned + , int64VarSigned + , intVarSigned + + + -- * Chunked / size-prefixed encodings +{- | +Some encodings like ASN.1 BER +or Google's protocol buffers require +encoded data to be prefixed with its length. The simple method to achieve this +is to encode the data first into a separate buffer, compute the length of the +encoded data, write it to the current output buffer, and append the separate +buffers. The drawback of this method is that it requires a ... +-} + , size + , sizeBound + -- , withSizeFB + -- , withSizeBB + , encodeWithSize + + , encodeChunked + + , wordVarFixedBound + , wordHexFixedBound + , wordDecFixedBound + + , word64VarFixedBound + , word64HexFixedBound + , word64DecFixedBound + + ) where + +import Data.ByteString.Lazy.Builder.Internal +import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.UncheckedShifts +import Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Base16 (lowerTable, encode4_as_8) + +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy.Internal as L + +import Data.Monoid +import Data.List (unfoldr) -- HADDOCK ONLY +import Data.Char (chr, ord) +import Control.Monad ((<=<), unless) + +import Data.ByteString.Lazy.Builder.BasicEncoding.Internal hiding (size, sizeBound) +import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Internal as I (size, sizeBound) +import Data.ByteString.Lazy.Builder.BasicEncoding.Binary +import Data.ByteString.Lazy.Builder.BasicEncoding.ASCII +import Data.ByteString.Lazy.Builder.BasicEncoding + +import Foreign + +------------------------------------------------------------------------------ +-- Adapting 'size' for the public interface. +------------------------------------------------------------------------------ + +-- | The size of the sequence of bytes generated by this 'FixedEncoding'. +size :: FixedEncoding a -> Word +size = fromIntegral . I.size + +-- | The bound on the size of the sequence of bytes generated by this +-- 'BoundedEncoding'. +sizeBound :: BoundedEncoding a -> Word +sizeBound = fromIntegral . I.sizeBound + + +------------------------------------------------------------------------------ +-- Base-128 Variable-Length Encodings +------------------------------------------------------------------------------ + +{-# INLINE encodeBase128 #-} +encodeBase128 + :: forall a b. (Integral a, Bits a, Storable b, Integral b, Num b) + => (a -> Int -> a) -> BoundedEncoding b +encodeBase128 shiftr = + -- We add 6 because we require the result of (`div` 7) to be rounded up. + boundedEncoding ((8 * sizeOf (undefined :: b) + 6) `div` 7) (io . fromIntegral) + where + io !x !op + | x' == 0 = do poke8 (x .&. 0x7f) + return $! op `plusPtr` 1 + | otherwise = do poke8 ((x .&. 0x7f) .|. 0x80) + io x' (op `plusPtr` 1) + where + x' = x `shiftr` 7 + poke8 = poke op . fromIntegral + +-- | Base-128, variable length encoding of a 'Word8'. +{-# INLINE word8Var #-} +word8Var :: BoundedEncoding Word8 +word8Var = encodeBase128 shiftr_w + +-- | Base-128, variable length encoding of a 'Word16'. +{-# INLINE word16Var #-} +word16Var :: BoundedEncoding Word16 +word16Var = encodeBase128 shiftr_w + +-- | Base-128, variable length encoding of a 'Word32'. +{-# INLINE word32Var #-} +word32Var :: BoundedEncoding Word32 +word32Var = encodeBase128 shiftr_w32 + +-- | Base-128, variable length encoding of a 'Word64'. +{-# INLINE word64Var #-} +word64Var :: BoundedEncoding Word64 +word64Var = encodeBase128 shiftr_w64 + +-- | Base-128, variable length encoding of a 'Word'. +{-# INLINE wordVar #-} +wordVar :: BoundedEncoding Word +wordVar = encodeBase128 shiftr_w + + +-- | Base-128, variable length encoding of an 'Int8'. +-- Use 'int8VarSigned' for encoding negative numbers. +{-# INLINE int8Var #-} +int8Var :: BoundedEncoding Int8 +int8Var = fromIntegral >$< word8Var + +-- | Base-128, variable length encoding of an 'Int16'. +-- Use 'int16VarSigned' for encoding negative numbers. +{-# INLINE int16Var #-} +int16Var :: BoundedEncoding Int16 +int16Var = fromIntegral >$< word16Var + +-- | Base-128, variable length encoding of an 'Int32'. +-- Use 'int32VarSigned' for encoding negative numbers. +{-# INLINE int32Var #-} +int32Var :: BoundedEncoding Int32 +int32Var = fromIntegral >$< word32Var + +-- | Base-128, variable length encoding of an 'Int64'. +-- Use 'int64VarSigned' for encoding negative numbers. +{-# INLINE int64Var #-} +int64Var :: BoundedEncoding Int64 +int64Var = fromIntegral >$< word64Var + +-- | Base-128, variable length encoding of an 'Int'. +-- Use 'intVarSigned' for encoding negative numbers. +{-# INLINE intVar #-} +intVar :: BoundedEncoding Int +intVar = fromIntegral >$< wordVar + +{-# INLINE zigZag #-} +zigZag :: (Storable a, Bits a) => a -> a +zigZag x = (x `shiftL` 1) `xor` (x `shiftR` (8 * sizeOf x - 1)) + +-- | Base-128, variable length, ZigZag encoding of an 'Int'. +{-# INLINE int8VarSigned #-} +int8VarSigned :: BoundedEncoding Int8 +int8VarSigned = zigZag >$< int8Var + +-- | Base-128, variable length, ZigZag encoding of an 'Int16'. +{-# INLINE int16VarSigned #-} +int16VarSigned :: BoundedEncoding Int16 +int16VarSigned = zigZag >$< int16Var + +-- | Base-128, variable length, ZigZag encoding of an 'Int32'. +{-# INLINE int32VarSigned #-} +int32VarSigned :: BoundedEncoding Int32 +int32VarSigned = zigZag >$< int32Var + +-- | Base-128, variable length, ZigZag encoding of an 'Int64'. +{-# INLINE int64VarSigned #-} +int64VarSigned :: BoundedEncoding Int64 +int64VarSigned = zigZag >$< int64Var + +-- | Base-128, variable length, ZigZag encoding of an 'Int'. +{-# INLINE intVarSigned #-} +intVarSigned :: BoundedEncoding Int +intVarSigned = zigZag >$< intVar + + + +------------------------------------------------------------------------------ +-- Chunked Encoding Transformer +------------------------------------------------------------------------------ + +-- | /Heavy inlining./ +{-# INLINE encodeChunked #-} +encodeChunked + :: Word -- ^ Minimal free-size + -> (Word64 -> FixedEncoding Word64) + -- ^ Given a sizeBound on the maximal encodable size this function must return + -- a fixed-size encoding for encoding all smaller size. + -> (BoundedEncoding Word64) + -- ^ An encoding for terminating a chunk of the given size. + -> Builder + -- ^ Inner Builder to transform + -> Builder + -- ^ 'Put' with chunked encoding. +encodeChunked minFree mkBeforeFE afterBE = + fromPut . putChunked minFree mkBeforeFE afterBE . putBuilder + +-- | /Heavy inlining./ +{-# INLINE putChunked #-} +putChunked + :: Word -- ^ Minimal free-size + -> (Word64 -> FixedEncoding Word64) + -- ^ Given a sizeBound on the maximal encodable size this function must return + -- a fixed-size encoding for encoding all smaller size. + -> (BoundedEncoding Word64) + -- ^ Encoding a directly inserted chunk. + -> Put a + -- ^ Inner Put to transform + -> Put a + -- ^ 'Put' with chunked encoding. +putChunked minFree0 mkBeforeFE afterBE p = + put encodingStep + where + minFree, reservedAfter, maxReserved, minBufferSize :: Int + minFree = fromIntegral $ max 1 minFree0 -- sanitize and convert to Int + + -- reserved space must be computed for maximum buffer size to cover for all + -- sizes of the actually returned buffer. + reservedAfter = I.sizeBound afterBE + maxReserved = I.size (mkBeforeFE maxBound) + reservedAfter + minBufferSize = minFree + maxReserved + + encodingStep k = + fill (runPut p) + where + fill innerStep !(BufferRange op ope) + | outRemaining < minBufferSize = + return $! bufferFull minBufferSize op (fill innerStep) + | otherwise = do + fillWithBuildStep innerStep doneH fullH insertChunksH brInner + where + outRemaining = ope `minusPtr` op + beforeFE = mkBeforeFE $ fromIntegral outRemaining + reservedBefore = I.size beforeFE + + opInner = op `plusPtr` reservedBefore + opeInner = ope `plusPtr` (-reservedAfter) + brInner = BufferRange opInner opeInner + + wrapChunk :: Ptr Word8 -> IO (Ptr Word8) + wrapChunk !opInner' + | innerSize == 0 = return op -- no data written => no chunk to wrap + | otherwise = do + runF beforeFE innerSize op + runB afterBE innerSize opInner' + where + innerSize = fromIntegral $ opInner' `minusPtr` opInner + + doneH opInner' x = do + op' <- wrapChunk opInner' + let !br' = BufferRange op' ope + k x br' + + fullH opInner' minSize nextInnerStep = do + op' <- wrapChunk opInner' + return $! bufferFull + (max minBufferSize (minSize + maxReserved)) + op' + (fill nextInnerStep) + + insertChunksH opInner' n lbsC nextInnerStep + | n == 0 = do -- flush + op' <- wrapChunk opInner' + return $! insertChunks op' 0 id (fill nextInnerStep) + + | otherwise = do -- insert non-empty bytestring + op' <- wrapChunk opInner' + let !br' = BufferRange op' ope + runBuilderWith chunkB (fill nextInnerStep) br' + where + nU = fromIntegral n + chunkB = + encodeWithF (mkBeforeFE nU) nU `mappend` + lazyByteStringC n lbsC `mappend` + encodeWithB afterBE nU + + +-- | /Heavy inlining./ Prefix a 'Builder' with the size of the +-- sequence of bytes that it denotes. +-- +-- This function is optimized for streaming use. It tries to prefix the size +-- without copying the output. This is achieved by reserving space for the +-- maximum size to be encoded. This succeeds if the output is smaller than +-- the current free buffer size, which is guaranteed to be at least @8kb@. +-- +-- If the output does not fit into the current free buffer size, +-- the method falls back to encoding the data to a separate lazy bytestring, +-- computing the size, and encoding the size before inserting the chunks of +-- the separate lazy bytestring. +{-# INLINE encodeWithSize #-} +encodeWithSize + :: + Word + -- ^ Inner buffer-size. + -> (Word64 -> FixedEncoding Word64) + -- ^ Given a bound on the maximal size to encode, this function must return + -- a fixed-size encoding for all smaller sizes. + -> Builder + -- ^ 'Put' to prefix with the length of its sequence of bytes. + -> Builder +encodeWithSize innerBufSize mkSizeFE = + fromPut . putWithSize innerBufSize mkSizeFE . putBuilder + +-- | Prefix a 'Put' with the size of its written data. +{-# INLINE putWithSize #-} +putWithSize + :: forall a. + Word + -- ^ Buffer-size for inner driver. + -> (Word64 -> FixedEncoding Word64) + -- ^ Encoding the size for the fallback case. + -> Put a + -- ^ 'Put' to prefix with the length of its sequence of bytes. + -> Put a +putWithSize innerBufSize mkSizeFE innerP = + put $ encodingStep + where + -- | The minimal free size is such that we can encode any size. + minFree = I.size $ mkSizeFE maxBound + + encodingStep :: (forall r. (a -> BuildStep r) -> BuildStep r) + encodingStep k = + fill (runPut innerP) + where + fill :: BuildStep a -> BufferRange -> IO (BuildSignal r) + fill innerStep !(BufferRange op ope) + | outRemaining < minFree = + return $! bufferFull minFree op (fill innerStep) + | otherwise = do + fillWithBuildStep innerStep doneH fullH insertChunksH brInner + where + outRemaining = ope `minusPtr` op + sizeFE = mkSizeFE $ fromIntegral outRemaining + reservedBefore = I.size sizeFE + reservedAfter = minFree - reservedBefore + + -- leave enough free space such that all sizes can be encodded. + startInner = op `plusPtr` reservedBefore + opeInner = ope `plusPtr` (negate reservedAfter) + brInner = BufferRange startInner opeInner + + fastPrefixSize :: Ptr Word8 -> IO (Ptr Word8) + fastPrefixSize !opInner' + | innerSize == 0 = do runB (toB $ mkSizeFE 0) 0 op + | otherwise = do runF (sizeFE) innerSize op + return opInner' + where + innerSize = fromIntegral $ opInner' `minusPtr` startInner + + slowPrefixSize :: Ptr Word8 -> Builder -> BuildStep a -> IO (BuildSignal r) + slowPrefixSize opInner' bInner nextStep = do + (x, chunks, payLenChunks) <- toLBS $ runBuilderWith bInner nextStep + + let -- length of payload data in current buffer + payLenCur = opInner' `minusPtr` startInner + -- length of whole payload + payLen = fromIntegral payLenCur + fromIntegral payLenChunks + -- encoder for payload length + sizeFE' = mkSizeFE payLen + -- start of payload in current buffer with the payload + -- length encoded before + startInner' = op `plusPtr` I.size sizeFE' + + -- move data in current buffer out of the way, if required + unless (startInner == startInner') $ + moveBytes startInner' startInner payLenCur + -- encode payload length at start of the buffer + runF sizeFE' payLen op + -- TODO: If we were to change the CIOS definition such that it also + -- returns the last buffer for writing, we could also fill the + -- last buffer with 'k' and return the signal, once it is + -- filled, therefore avoiding unfilled space. + return $ insertChunks (startInner' `plusPtr` payLenCur) + payLenChunks + chunks + (k x) + where + toLBS = runCIOSWithLength <=< + buildStepToCIOSUntrimmedWith (fromIntegral innerBufSize) + + doneH :: Ptr Word8 -> a -> IO (BuildSignal r) + doneH opInner' x = do + op' <- fastPrefixSize opInner' + let !br' = BufferRange op' ope + k x br' + + fullH :: Ptr Word8 -> Int -> BuildStep a -> IO (BuildSignal r) + fullH opInner' minSize nextInnerStep = + slowPrefixSize opInner' (ensureFree minSize) nextInnerStep + + insertChunksH :: Ptr Word8 -> Int64 -> LazyByteStringC + -> BuildStep a -> IO (BuildSignal r) + insertChunksH opInner' n lbsC nextInnerStep = + slowPrefixSize opInner' (lazyByteStringC n lbsC) nextInnerStep + + +-- | Run a 'ChunkIOStream' and gather its results and their length. +runCIOSWithLength :: ChunkIOStream a -> IO (a, LazyByteStringC, Int64) +runCIOSWithLength = + go 0 id + where + go !l lbsC (Finished x) = return (x, lbsC, l) + go !l lbsC (YieldC n lbsC' io) = io >>= go (l + n) (lbsC . lbsC') + go !l lbsC (Yield1 bs io) = + io >>= go (l + fromIntegral (S.length bs)) (lbsC . L.Chunk bs) + +-- | Run a 'BuildStep' using the untrimmed strategy. +buildStepToCIOSUntrimmedWith :: Int -> BuildStep a -> IO (ChunkIOStream a) +buildStepToCIOSUntrimmedWith bufSize = + buildStepToCIOS (untrimmedStrategy bufSize bufSize) + (return . Finished) + + +---------------------------------------------------------------------- +-- Padded versions of encodings for streamed prefixing of output sizes +---------------------------------------------------------------------- + +{-# INLINE appsUntilZero #-} +appsUntilZero :: (Eq a, Num a) => (a -> a) -> a -> Int +appsUntilZero f x0 = + count 0 x0 + where + count !n 0 = n + count !n x = count (succ n) (f x) + + +{-# INLINE genericVarFixedBound #-} +genericVarFixedBound :: (Eq b, Show b, Bits b, Num a, Integral b) + => (b -> a -> b) -> b -> FixedEncoding b +genericVarFixedBound shiftRight bound = + fixedEncoding n0 io + where + n0 = max 1 $ appsUntilZero (`shiftRight` 7) bound + + io !x0 !op + | x0 > bound = error err + | otherwise = loop 0 x0 + where + err = "genericVarFixedBound: value " ++ show x0 ++ " > bound " ++ show bound + loop !n !x + | n0 <= n + 1 = do poke8 (x .&. 0x7f) + | otherwise = do poke8 ((x .&. 0x7f) .|. 0x80) + loop (n + 1) (x `shiftRight` 7) + where + poke8 = pokeElemOff op n . fromIntegral + +{-# INLINE wordVarFixedBound #-} +wordVarFixedBound :: Word -> FixedEncoding Word +wordVarFixedBound = genericVarFixedBound shiftr_w + +{-# INLINE word64VarFixedBound #-} +word64VarFixedBound :: Word64 -> FixedEncoding Word64 +word64VarFixedBound = genericVarFixedBound shiftr_w64 + + +-- Somehow this function doesn't really make sense, as the bound must be +-- greater when interpreted as an unsigned integer. These conversions and +-- decisions should be left to the user. +-- +--{-# INLINE intVarFixed #-} +--intVarFixed :: Size -> FixedEncoding Size +--intVarFixed bound = fromIntegral >$< wordVarFixed (fromIntegral bound) + +{-# INLINE genHexFixedBound #-} +genHexFixedBound :: (Num a, Bits a, Integral a) + => (a -> Int -> a) -> Char -> a -> FixedEncoding a +genHexFixedBound shiftr padding0 bound = + fixedEncoding n0 io + where + n0 = max 1 $ appsUntilZero (`shiftr` 4) bound + + padding = fromIntegral (ord padding0) :: Word8 + + io !x0 !op0 = + loop (op0 `plusPtr` n0) x0 + where + loop !op !x = do + let !op' = op `plusPtr` (-1) + poke op' =<< encode4_as_8 lowerTable (fromIntegral $ x .&. 0xf) + let !x' = x `shiftr` 4 + unless (op' <= op0) $ + if x' == 0 + then pad (op' `plusPtr` (-1)) + else loop op' x' + + pad !op + | op < op0 = return () + | otherwise = poke op padding >> pad (op `plusPtr` (-1)) + + +{-# INLINE wordHexFixedBound #-} +wordHexFixedBound :: Char -> Word -> FixedEncoding Word +wordHexFixedBound = genHexFixedBound shiftr_w + +{-# INLINE word64HexFixedBound #-} +word64HexFixedBound :: Char -> Word64 -> FixedEncoding Word64 +word64HexFixedBound = genHexFixedBound shiftr_w64 + +-- | Note: Works only for positive numbers. +{-# INLINE genDecFixedBound #-} +genDecFixedBound :: (Num a, Bits a, Integral a) + => Char -> a -> FixedEncoding a +genDecFixedBound padding0 bound = + fixedEncoding n0 io + where + n0 = max 1 $ appsUntilZero (`div` 10) bound + + padding = fromIntegral (ord padding0) :: Word8 + + io !x0 !op0 = + loop (op0 `plusPtr` n0) x0 + where + loop !op !x = do + let !op' = op `plusPtr` (-1) + !x' = x `div` 10 + poke op' ((fromIntegral $ (x - x' * 10) + 48) :: Word8) + unless (op' <= op0) $ + if x' == 0 + then pad (op' `plusPtr` (-1)) + else loop op' x' + + pad !op + | op < op0 = return () + | otherwise = poke op padding >> pad (op `plusPtr` (-1)) + +{-# INLINE wordDecFixedBound #-} +wordDecFixedBound :: Char -> Word -> FixedEncoding Word +wordDecFixedBound = genDecFixedBound + +{-# INLINE word64DecFixedBound #-} +word64DecFixedBound :: Char -> Word64 -> FixedEncoding Word64 +word64DecFixedBound = genDecFixedBound + diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/Builder/BasicEncoding/Internal.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Copyright : 2010-2011 Simon Meier, 2010 Jasper van der Jeugt +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : GHC +-- +-- This module is internal. It is only intended to be used by the 'bytestring' +-- and the 'text' library. Please contact the maintainer, if you need to use +-- this module in your library. We are glad to accept patches for further +-- standard encodings of standard Haskell values. +-- +-- If you need to write your own primitive encoding, then be aware that you are +-- writing code with /all saftey belts off/; i.e., +-- *this is the code that might make your application vulnerable to buffer-overflow attacks!* +-- The "Codec.Bounded.Encoding.Internal.Test" module provides you with +-- utilities for testing your encodings thoroughly. +-- +module Data.ByteString.Lazy.Builder.BasicEncoding.Internal ( + -- * Fixed-size Encodings + Size + , FixedEncoding + , fixedEncoding + , size + , runF + + , emptyF + , contramapF + , pairF + -- , liftIOF + + , storableToF + + -- * Bounded-size Encodings + , BoundedEncoding + , boundedEncoding + , sizeBound + , runB + + , emptyB + , contramapB + , pairB + , eitherB + , ifB + + -- , liftIOB + + , toB + , fromF + + -- , withSizeFB + -- , withSizeBB + + -- * Shared operators + , (>$<) + , (>*<) + + ) where + +import Foreign +import Prelude hiding (maxBound) + +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 611 +-- ghc-6.10 and older do not support {-# INLINE CONLIKE #-} +#define CONLIKE +#endif + +------------------------------------------------------------------------------ +-- Supporting infrastructure +------------------------------------------------------------------------------ + +-- | Contravariant functors as in the 'contravariant' package. +class Contravariant f where + contramap :: (b -> a) -> f a -> f b + +infixl 4 >$< + +-- | An overloaded infix operator for 'contramapF' and 'contramapB'. +-- +-- We can use it for example to prepend and/or append fixed values to an +-- encoding. +-- +-- >showEncoding ((\x -> ('\'', (x, '\''))) >$< fixed3) 'x' = "'x'" +-- > where +-- > fixed3 = char7 >*< char7 >*< char7 +-- +-- Note that the rather verbose syntax for composition stems from the +-- requirement to be able to compute the 'size's and 'sizeBound's at +-- compile time. +-- +(>$<) :: Contravariant f => (b -> a) -> f a -> f b +(>$<) = contramap + + +instance Contravariant FixedEncoding where + contramap = contramapF + +instance Contravariant BoundedEncoding where + contramap = contramapB + + +-- | Type-constructors supporting lifting of type-products. +class Monoidal f where + pair :: f a -> f b -> f (a, b) + +instance Monoidal FixedEncoding where + pair = pairF + +instance Monoidal BoundedEncoding where + pair = pairB + +infixr 5 >*< + +-- | An overloaded infix operator for 'pairF' and 'pairB'. +-- For example, +-- +-- >showF (char7 >*< char7) ('x','y') = "xy" +-- +-- We can combine multiple encodings using '>*<' multiple times. +-- +-- >showEncoding (char7 >*< char7 >*< char7) ('x',('y','z')) = "xyz" +-- +(>*<) :: Monoidal f => f a -> f b -> f (a, b) +(>*<) = pair + + +-- | The type used for sizes and sizeBounds of sizes. +type Size = Int + + +------------------------------------------------------------------------------ +-- Fixed-size Encodings +------------------------------------------------------------------------------ + +-- | An encoding that always results in a sequence of bytes of a +-- pre-determined, fixed size. +data FixedEncoding a = FE {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO ()) + +fixedEncoding :: Int -> (a -> Ptr Word8 -> IO ()) -> FixedEncoding a +fixedEncoding = FE + +-- | The size of the sequences of bytes generated by this 'FixedEncoding'. +{-# INLINE CONLIKE size #-} +size :: FixedEncoding a -> Int +size (FE l _) = l + +{-# INLINE CONLIKE runF #-} +runF :: FixedEncoding a -> a -> Ptr Word8 -> IO () +runF (FE _ io) = io + +-- | The 'FixedEncoding' that always results in the zero-length sequence. +{-# INLINE CONLIKE emptyF #-} +emptyF :: FixedEncoding a +emptyF = FE 0 (\_ _ -> return ()) + +-- | Encode a pair by encoding its first component and then its second component. +{-# INLINE CONLIKE pairF #-} +pairF :: FixedEncoding a -> FixedEncoding b -> FixedEncoding (a, b) +pairF (FE l1 io1) (FE l2 io2) = + FE (l1 + l2) (\(x1,x2) op -> io1 x1 op >> io2 x2 (op `plusPtr` l1)) + +-- | Change an encoding such that it first applies a function to the value +-- to be encoded. +-- +-- Note that encodings are 'Contrafunctors' +-- . Hence, the following +-- laws hold. +-- +-- >contramapF id = id +-- >contramapF f . contramapF g = contramapF (g . f) +{-# INLINE CONLIKE contramapF #-} +contramapF :: (b -> a) -> FixedEncoding a -> FixedEncoding b +contramapF f (FE l io) = FE l (\x op -> io (f x) op) + +-- | Convert a 'FixedEncoding' to a 'BoundedEncoding'. +{-# INLINE CONLIKE toB #-} +toB :: FixedEncoding a -> BoundedEncoding a +toB (FE l io) = BE l (\x op -> io x op >> (return $! op `plusPtr` l)) + +-- | Convert a 'FixedEncoding' to a 'BoundedEncoding'. +{-# INLINE CONLIKE fromF #-} +fromF :: FixedEncoding a -> BoundedEncoding a +fromF = toB + +{-# INLINE CONLIKE storableToF #-} +storableToF :: forall a. Storable a => FixedEncoding a +storableToF = FE (sizeOf (undefined :: a)) (\x op -> poke (castPtr op) x) + +{- +{-# INLINE CONLIKE liftIOF #-} +liftIOF :: FixedEncoding a -> FixedEncoding (IO a) +liftIOF (FE l io) = FE l (\xWrapped op -> do x <- xWrapped; io x op) +-} + +------------------------------------------------------------------------------ +-- Bounded-size Encodings +------------------------------------------------------------------------------ + +-- | An encoding that always results in sequence of bytes that is no longer +-- than a pre-determined bound. +data BoundedEncoding a = BE {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO (Ptr Word8)) + +-- | The bound on the size of sequences of bytes generated by this 'BoundedEncoding'. +{-# INLINE CONLIKE sizeBound #-} +sizeBound :: BoundedEncoding a -> Int +sizeBound (BE b _) = b + +boundedEncoding :: Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedEncoding a +boundedEncoding = BE + +{-# INLINE CONLIKE runB #-} +runB :: BoundedEncoding a -> a -> Ptr Word8 -> IO (Ptr Word8) +runB (BE _ io) = io + +-- | Change a 'BoundedEncoding' such that it first applies a function to the +-- value to be encoded. +-- +-- Note that 'BoundedEncoding's are 'Contrafunctors' +-- . Hence, the following +-- laws hold. +-- +-- >contramapB id = id +-- >contramapB f . contramapB g = contramapB (g . f) +{-# INLINE CONLIKE contramapB #-} +contramapB :: (b -> a) -> BoundedEncoding a -> BoundedEncoding b +contramapB f (BE b io) = BE b (\x op -> io (f x) op) + +-- | The 'BoundedEncoding' that always results in the zero-length sequence. +{-# INLINE CONLIKE emptyB #-} +emptyB :: BoundedEncoding a +emptyB = BE 0 (\_ op -> return op) + +-- | Encode a pair by encoding its first component and then its second component. +{-# INLINE CONLIKE pairB #-} +pairB :: BoundedEncoding a -> BoundedEncoding b -> BoundedEncoding (a, b) +pairB (BE b1 io1) (BE b2 io2) = + BE (b1 + b2) (\(x1,x2) op -> io1 x1 op >>= io2 x2) + +-- | Encode an 'Either' value using the first 'BoundedEncoding' for 'Left' +-- values and the second 'BoundedEncoding' for 'Right' values. +-- +-- Note that the functions 'eitherB', 'pairB', and 'contramapB' (written below +-- using '>$<') suffice to construct 'BoundedEncoding's for all non-recursive +-- algebraic datatypes. For example, +-- +-- @ +--maybeB :: BoundedEncoding () -> BoundedEncoding a -> BoundedEncoding (Maybe a) +--maybeB nothing just = 'maybe' (Left ()) Right '>$<' eitherB nothing just +-- @ +{-# INLINE CONLIKE eitherB #-} +eitherB :: BoundedEncoding a -> BoundedEncoding b -> BoundedEncoding (Either a b) +eitherB (BE b1 io1) (BE b2 io2) = + BE (max b1 b2) + (\x op -> case x of Left x1 -> io1 x1 op; Right x2 -> io2 x2 op) + +-- | Conditionally select a 'BoundedEncoding'. +-- For example, we can implement the ASCII encoding that drops characters with +-- Unicode codepoints above 127 as follows. +-- +-- @ +--charASCIIDrop = 'ifB' (< '\128') ('fromF' 'char7') 'emptyB' +-- @ +{-# INLINE CONLIKE ifB #-} +ifB :: (a -> Bool) -> BoundedEncoding a -> BoundedEncoding a -> BoundedEncoding a +ifB p be1 be2 = + contramapB (\x -> if p x then Left x else Right x) (eitherB be1 be2) + + +{- +{-# INLINE withSizeFB #-} +withSizeFB :: (Word -> FixedEncoding Word) -> BoundedEncoding a -> BoundedEncoding a +withSizeFB feSize (BE b io) = + BE (lSize + b) + (\x op0 -> do let !op1 = op0 `plusPtr` lSize + op2 <- io x op1 + ioSize (fromIntegral $ op2 `minusPtr` op1) op0 + return op2) + where + FE lSize ioSize = feSize (fromIntegral b) + + +{-# INLINE withSizeBB #-} +withSizeBB :: BoundedEncoding Word -> BoundedEncoding a -> BoundedEncoding a +withSizeBB (BE bSize ioSize) (BE b io) = + BE (bSize + 2*b) + (\x op0 -> do let !opTmp = op0 `plusPtr` (bSize + b) + opTmp' <- io x opTmp + let !s = opTmp' `minusPtr` opTmp + op1 <- ioSize (fromIntegral s) op0 + copyBytes op1 opTmp s + return $! op1 `plusPtr` s) + +{-# INLINE CONLIKE liftIOB #-} +liftIOB :: BoundedEncoding a -> BoundedEncoding (IO a) +liftIOB (BE l io) = BE l (\xWrapped op -> do x <- xWrapped; io x op) +-} + +------------------------------------------------------------------------------ +-- Encodings from 'ByteString's. +------------------------------------------------------------------------------ + +{- +-- | A 'FixedEncoding' that always results in the same byte sequence given as a +-- strict 'S.ByteString'. We can use this encoding to insert fixed ... +{-# INLINE CONLIKE constByteStringF #-} +constByteStringF :: S.ByteString -> FixedEncoding () +constByteStringF bs = + FE len io + where + (S.PS fp off len) = bs + io _ op = do + copyBytes op (unsafeForeignPtrToPtr fp `plusPtr` off) len + touchForeignPtr fp + +-- | Encode a fixed-length prefix of a strict 'S.ByteString' as-is. We can use +-- this function to +{-# INLINE byteStringPrefixB #-} +byteStringTakeB :: Int -- ^ Length of the prefix. It should be smaller than + -- 100 bytes, as otherwise + -> BoundedEncoding S.ByteString +byteStringTakeB n0 = + BE n io + where + n = max 0 n0 -- sanitize + + io (S.PS fp off len) op = do + let !s = min len n + copyBytes op (unsafeForeignPtrToPtr fp `plusPtr` off) s + touchForeignPtr fp + return $! op `plusPtr` s +-} + +{- + +httpChunkedTransfer :: Builder -> Builder +httpChunkedTransfer = + encodeChunked 32 (word64HexFixedBound '0') + ((\_ -> ('\r',('\n',('\r','\n')))) >$< char8x4) + where + char8x4 = toB (char8 >*< char8 >*< char8 >*< char8) + + + +chunked :: Builder -> Builder +chunked = encodeChunked 16 word64VarFixedBound emptyB + +-} + + + diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Base16.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Base16.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Base16.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE CPP #-} +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : GHC +-- +-- Hexadecimal encoding of nibbles (4-bit) and octets (8-bit) as ASCII +-- characters. +-- +-- The current implementation is based on a table based encoding inspired by +-- the code in the 'base64-bytestring' library by Bryan O'Sullivan. In our +-- benchmarks on a 32-bit machine it turned out to be the fastest +-- implementation option. +-- +module Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Base16 ( + EncodingTable + -- , upperTable + , lowerTable + , encode4_as_8 + , encode8_as_16h + -- , encode8_as_8_8 + ) where + +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S + +#if MIN_VERSION_base(4,4,0) +import Foreign hiding (unsafePerformIO, unsafeForeignPtrToPtr) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import System.IO.Unsafe (unsafePerformIO) +#else +import Foreign +#endif + +-- Creating the encoding tables +------------------------------- + +-- TODO: Use table from C implementation. + +-- | An encoding table for Base16 encoding. +newtype EncodingTable = EncodingTable (ForeignPtr Word8) + +tableFromList :: [Word8] -> EncodingTable +tableFromList xs = case S.pack xs of S.PS fp _ _ -> EncodingTable fp + +unsafeIndex :: EncodingTable -> Int -> IO Word8 +unsafeIndex (EncodingTable table) = peekElemOff (unsafeForeignPtrToPtr table) + +base16EncodingTable :: EncodingTable -> IO EncodingTable +base16EncodingTable alphabet = do + xs <- sequence $ concat $ [ [ix j, ix k] | j <- [0..15], k <- [0..15] ] + return $ tableFromList xs + where + ix = unsafeIndex alphabet + +{- +{-# NOINLINE upperAlphabet #-} +upperAlphabet :: EncodingTable +upperAlphabet = + tableFromList $ map (fromIntegral . fromEnum) $ ['0'..'9'] ++ ['A'..'F'] + +-- | The encoding table for hexadecimal values with upper-case characters; +-- e.g., DEADBEEF. +{-# NOINLINE upperTable #-} +upperTable :: EncodingTable +upperTable = unsafePerformIO $ base16EncodingTable upperAlphabet +-} + +{-# NOINLINE lowerAlphabet #-} +lowerAlphabet :: EncodingTable +lowerAlphabet = + tableFromList $ map (fromIntegral . fromEnum) $ ['0'..'9'] ++ ['a'..'f'] + +-- | The encoding table for hexadecimal values with lower-case characters; +-- e.g., deadbeef. +{-# NOINLINE lowerTable #-} +lowerTable :: EncodingTable +lowerTable = unsafePerformIO $ base16EncodingTable lowerAlphabet + + +-- Encoding nibbles and octets +------------------------------ + +-- | Encode a nibble as an octet. +-- +-- > encode4_as_8 lowerTable 10 = fromIntegral (char 'a') +-- +{-# INLINE encode4_as_8 #-} +encode4_as_8 :: EncodingTable -> Word8 -> IO Word8 +encode4_as_8 table x = unsafeIndex table (2 * fromIntegral x + 1) +-- TODO: Use a denser table to reduce cache utilization. + +-- | Encode an octet as 16bit word comprising both encoded nibbles ordered +-- according to the host endianness. Writing these 16bit to memory will write +-- the nibbles in the correct order (i.e. big-endian). +{-# INLINE encode8_as_16h #-} +encode8_as_16h :: EncodingTable -> Word8 -> IO Word16 +encode8_as_16h (EncodingTable table) = + peekElemOff (castPtr $ unsafeForeignPtrToPtr table) . fromIntegral + +{- +-- | Encode an octet as a big-endian ordered tuple of octets; i.e., +-- +-- > encode8_as_8_8 lowerTable 10 +-- > = (fromIntegral (chr '0'), fromIntegral (chr 'a')) +-- +{-# INLINE encode8_as_8_8 #-} +encode8_as_8_8 :: EncodingTable -> Word8 -> IO (Word8, Word8) +encode8_as_8_8 table x = + (,) <$> unsafeIndex table i <*> unsafeIndex table (i + 1) + where + i = 2 * fromIntegral x +-} diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Floating.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Floating.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/Floating.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Copyright : (c) 2010 Simon Meier +-- +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : GHC +-- +-- Conversion of 'Float's and 'Double's to 'Word32's and 'Word64's. +-- +module Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Floating + ( + -- coerceFloatToWord32 + -- , coerceDoubleToWord64 + encodeFloatViaWord32F + , encodeDoubleViaWord64F + ) where + +import Foreign +import Data.ByteString.Lazy.Builder.BasicEncoding.Internal + +{- +We work around ticket http://hackage.haskell.org/trac/ghc/ticket/4092 using the +FFI to store the Float/Double in the buffer and peek it out again from there. +-} + + +-- | Encode a 'Float' using a 'Word32' encoding. +-- +-- PRE: The 'Word32' encoding must have a size of at least 4 bytes. +{-# INLINE encodeFloatViaWord32F #-} +encodeFloatViaWord32F :: FixedEncoding Word32 -> FixedEncoding Float +encodeFloatViaWord32F w32fe + | size w32fe < sizeOf (undefined :: Float) = + error $ "encodeFloatViaWord32F: encoding not wide enough" + | otherwise = fixedEncoding (size w32fe) $ \x op -> do + poke (castPtr op) x + x' <- peek (castPtr op) + runF w32fe x' op + +-- | Encode a 'Double' using a 'Word64' encoding. +-- +-- PRE: The 'Word64' encoding must have a size of at least 8 bytes. +{-# INLINE encodeDoubleViaWord64F #-} +encodeDoubleViaWord64F :: FixedEncoding Word64 -> FixedEncoding Double +encodeDoubleViaWord64F w64fe + | size w64fe < sizeOf (undefined :: Float) = + error $ "encodeDoubleViaWord64F: encoding not wide enough" + | otherwise = fixedEncoding (size w64fe) $ \x op -> do + poke (castPtr op) x + x' <- peek (castPtr op) + runF w64fe x' op + diff --git a/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/UncheckedShifts.hs b/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/UncheckedShifts.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/Builder/BasicEncoding/Internal/UncheckedShifts.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE CPP, MagicHash #-} +-- | +-- Copyright : (c) 2010 Simon Meier +-- +-- Original serialization code from 'Data.Binary.Builder': +-- (c) Lennart Kolmodin, Ross Patterson +-- +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC +-- +-- Utilty module defining unchecked shifts. +-- +-- These functions are undefined when the amount being shifted by is +-- greater than the size in bits of a machine Int#.- +-- +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#include "MachDeps.h" +#endif + +module Data.ByteString.Lazy.Builder.BasicEncoding.Internal.UncheckedShifts ( + shiftr_w16 + , shiftr_w32 + , shiftr_w64 + , shiftr_w + + , caseWordSize_32_64 + ) where + + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +import GHC.Base +import GHC.Word (Word32(..),Word16(..),Word64(..)) + +#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608 +import GHC.Word (uncheckedShiftRL64#) +#endif +#else +import Data.Word +#endif + +import Foreign + + +------------------------------------------------------------------------ +-- Unchecked shifts + +-- | Right-shift of a 'Word16'. +{-# INLINE shiftr_w16 #-} +shiftr_w16 :: Word16 -> Int -> Word16 + +-- | Right-shift of a 'Word32'. +{-# INLINE shiftr_w32 #-} +shiftr_w32 :: Word32 -> Int -> Word32 + +-- | Right-shift of a 'Word64'. +{-# INLINE shiftr_w64 #-} +shiftr_w64 :: Word64 -> Int -> Word64 + +-- | Right-shift of a 'Word'. +{-# INLINE shiftr_w #-} +shiftr_w :: Word -> Int -> Word +#if WORD_SIZE_IN_BITS < 64 +shiftr_w w s = fromIntegral $ (`shiftr_w32` s) $ fromIntegral w +#else +shiftr_w w s = fromIntegral $ (`shiftr_w64` s) $ fromIntegral w +#endif + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i) +shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) + +#if WORD_SIZE_IN_BITS < 64 +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i) + +#if __GLASGOW_HASKELL__ <= 606 +-- Exported by GHC.Word in GHC 6.8 and higher +foreign import ccall unsafe "stg_uncheckedShiftRL64" + uncheckedShiftRL64# :: Word64# -> Int# -> Word64# +#endif + +#else +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i) +#endif + +#else +shiftr_w16 = shiftR +shiftr_w32 = shiftR +shiftr_w64 = shiftR +#endif + + +-- | Select an implementation depending on the bit-size of 'Word's. +-- Currently, it produces a runtime failure if the bitsize is different. +-- This is detected by the testsuite. +{-# INLINE caseWordSize_32_64 #-} +caseWordSize_32_64 :: a -- Value to use for 32-bit 'Word's + -> a -- Value to use for 64-bit 'Word's + -> a +caseWordSize_32_64 f32 f64 = case bitSize (undefined :: Word) of + 32 -> f32 + 64 -> f64 + s -> error $ "caseWordSize_32_64: unsupported Word bit-size " ++ show s + + diff --git a/Data/ByteString/Lazy/Builder/Extras.hs b/Data/ByteString/Lazy/Builder/Extras.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/Builder/Extras.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE BangPatterns #-} +----------------------------------------------------------------------------- +-- | Copyright : (c) 2010 Jasper Van der Jeugt +-- (c) 2010-2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC +-- +-- Extra functions for creating and executing 'Builder's. They are intended +-- for application-specific fine-tuning the performance of 'Builder's. +-- +----------------------------------------------------------------------------- +module Data.ByteString.Lazy.Builder.Extras + ( + -- * Execution strategies + toLazyByteStringWith + , AllocationStrategy + , safeStrategy + , untrimmedStrategy + , smallChunkSize + , defaultChunkSize + + -- * Controlling chunk boundaries + , byteStringCopy + , byteStringInsert + , byteStringThreshold + + , lazyByteStringCopy + , lazyByteStringInsert + , lazyByteStringThreshold + + , flush + + -- * Host-specific binary encodings + , intHost + , int16Host + , int32Host + , int64Host + + , wordHost + , word16Host + , word32Host + , word64Host + + , floatHost + , doubleHost + + ) where + + +import Data.ByteString.Lazy.Builder.Internal + +import qualified Data.ByteString.Lazy.Builder.BasicEncoding as E + + +import Foreign + + + +------------------------------------------------------------------------------ +-- Host-specific encodings +------------------------------------------------------------------------------ + +-- | Encode a single native machine 'Int'. The 'Int' is encoded in host order, +-- host endian form, for the machine you're on. On a 64 bit machine the 'Int' +-- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way +-- are not portable to different endian or int sized machines, without +-- conversion. +-- +{-# INLINE intHost #-} +intHost :: Int -> Builder +intHost = E.encodeWithF E.intHost + +-- | Encode a 'Int16' in native host order and host endianness. +{-# INLINE int16Host #-} +int16Host :: Int16 -> Builder +int16Host = E.encodeWithF E.int16Host + +-- | Encode a 'Int32' in native host order and host endianness. +{-# INLINE int32Host #-} +int32Host :: Int32 -> Builder +int32Host = E.encodeWithF E.int32Host + +-- | Encode a 'Int64' in native host order and host endianness. +{-# INLINE int64Host #-} +int64Host :: Int64 -> Builder +int64Host = E.encodeWithF E.int64Host + +-- | Encode a single native machine 'Word'. The 'Word' is encoded in host order, +-- host endian form, for the machine you're on. On a 64 bit machine the 'Word' +-- is an 8 byte value, on a 32 bit machine, 4 bytes. Values encoded this way +-- are not portable to different endian or word sized machines, without +-- conversion. +-- +{-# INLINE wordHost #-} +wordHost :: Word -> Builder +wordHost = E.encodeWithF E.wordHost + +-- | Encode a 'Word16' in native host order and host endianness. +{-# INLINE word16Host #-} +word16Host :: Word16 -> Builder +word16Host = E.encodeWithF E.word16Host + +-- | Encode a 'Word32' in native host order and host endianness. +{-# INLINE word32Host #-} +word32Host :: Word32 -> Builder +word32Host = E.encodeWithF E.word32Host + +-- | Encode a 'Word64' in native host order and host endianness. +{-# INLINE word64Host #-} +word64Host :: Word64 -> Builder +word64Host = E.encodeWithF E.word64Host + +-- | Encode a 'Float' in native host order. Values encoded this way are not +-- portable to different endian machines, without conversion. +{-# INLINE floatHost #-} +floatHost :: Float -> Builder +floatHost = E.encodeWithF E.floatHost + +-- | Encode a 'Double' in native host order. +{-# INLINE doubleHost #-} +doubleHost :: Double -> Builder +doubleHost = E.encodeWithF E.doubleHost + diff --git a/Data/ByteString/Lazy/Builder/Internal.hs b/Data/ByteString/Lazy/Builder/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Lazy/Builder/Internal.hs @@ -0,0 +1,854 @@ +{-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns, Rank2Types #-} +{-# OPTIONS_HADDOCK hide #-} +-- | Copyright : (c) 2010 - 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : GHC +-- +-- Core types and functions for the 'Builder' monoid and its generalization, +-- the 'Put' monad. +-- +-- The design of the 'Builder' monoid is optimized such that +-- +-- 1. buffers of arbitrary size can be filled as efficiently as possible and +-- +-- 2. sequencing of 'Builder's is as cheap as possible. +-- +-- We achieve (1) by completely handing over control over writing to the buffer +-- to the 'BuildStep' implementing the 'Builder'. This 'BuildStep' is just told +-- the start and the end of the buffer (represented as a 'BufferRange'). Then, +-- the 'BuildStep' can write to as big a prefix of this 'BufferRange' in any +-- way it desires. If the 'BuildStep' is done, the 'BufferRange' is full, or a +-- long sequence of bytes should be inserted directly, then the 'BuildStep' +-- signals this to its caller using a 'BuildSignal'. +-- +-- We achieve (2) by requiring that every 'Builder' is implemented by a +-- 'BuildStep' that takes a continuation 'BuildStep', which it calls with the +-- updated 'BufferRange' after it is done. Therefore, only two pointers have +-- to be passed in a function call to implement concatentation of 'Builder's. +-- Moreover, many 'Builder's are completely inlined, which enables the compiler +-- to sequence them without a function call and with no boxing at all. +-- +-- This design gives the implementation of a 'Builder' full access to the 'IO' +-- monad. Therefore, utmost care has to be taken to not overwrite anything +-- outside the given 'BufferRange's. Moreover, further care has to be taken to +-- ensure that 'Builder's and 'Put's are referentially transparent. See the +-- comments of the 'builder' and 'put' functions for further information. +-- Note that there are /no safety belts/ at all, when implementing a 'Builder' +-- using an 'IO' action: you are writing code that might enable the next +-- buffer-overlow attack on a Haskell server! +-- +module Data.ByteString.Lazy.Builder.Internal ( + + -- * Build signals and steps + BufferRange(..) + , LazyByteStringC + + , BuildSignal + , BuildStep + + , done + , bufferFull + , insertChunks + + , fillWithBuildStep + + -- * The Builder monoid + , Builder + , builder + , runBuilder + , runBuilderWith + + -- ** Primitive combinators + , empty + , append + , flush + , ensureFree + + , byteStringCopy + , byteStringInsert + , byteStringThreshold + + , lazyByteStringCopy + , lazyByteStringInsert + , lazyByteStringThreshold + + , lazyByteStringC + + , maximalCopySize + , byteString + , lazyByteString + + -- ** Execution strategies + , toLazyByteStringWith + , AllocationStrategy + , safeStrategy + , untrimmedStrategy + , L.smallChunkSize + , L.defaultChunkSize + + -- * The Put monad + , Put + , put + , runPut + , hPut + + -- ** Streams of chunks interleaved with IO + , ChunkIOStream(..) + , buildStepToCIOS + , ciosToLazyByteString + + -- ** Conversion to and from Builders + , putBuilder + , fromPut + + -- ** Lifting IO actions + -- , putLiftIO + +) where + +import Control.Applicative (Applicative(..), (<$>)) + +import Data.Monoid +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy.Internal as L + +#if __GLASGOW_HASKELL__ >= 611 +import GHC.IO.Buffer (Buffer(..), newByteBuffer) +import GHC.IO.Handle.Internals (wantWritableHandle, flushWriteBuffer) +import GHC.IO.Handle.Types (Handle__, haByteBuffer, haBufferMode) +import System.IO (hFlush, BufferMode(..)) +import Data.IORef +#else +import qualified Data.ByteString.Lazy as L +#endif +import System.IO (Handle) + +#if MIN_VERSION_base(4,4,0) +import Foreign hiding (unsafePerformIO, unsafeForeignPtrToPtr) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import System.IO.Unsafe (unsafePerformIO) +#else +import Foreign +#endif + + +type LazyByteStringC = L.ByteString -> L.ByteString + +-- | A range of bytes in a buffer represented by the pointer to the first byte +-- of the range and the pointer to the first byte /after/ the range. +data BufferRange = BufferRange {-# UNPACK #-} !(Ptr Word8) -- First byte of range + {-# UNPACK #-} !(Ptr Word8) -- First byte /after/ range + + +------------------------------------------------------------------------------ +-- Build signals +------------------------------------------------------------------------------ + +-- | 'BuildStep's may assume that they are called at most once. However, +-- they must not execute any function that may rise an async. exception, +-- as this would invalidate the code of 'hPut' below. +type BuildStep a = BufferRange -> IO (BuildSignal a) + +-- | 'BuildSignal's abstract signals to the caller of a 'BuildStep'. There are +-- exactly three signals: 'done', 'bufferFull', and 'insertChunks'. +data BuildSignal a = + Done {-# UNPACK #-} !(Ptr Word8) a + | BufferFull + {-# UNPACK #-} !Int + {-# UNPACK #-} !(Ptr Word8) + !(BuildStep a) + | InsertChunks + {-# UNPACK #-} !(Ptr Word8) + {-# UNPACK #-} !Int64 -- size of bytes in continuation + LazyByteStringC + !(BuildStep a) + +-- | Signal that the current 'BuildStep' is done and has computed a value. +{-# INLINE done #-} +done :: Ptr Word8 -- ^ Next free byte in current 'BufferRange' + -> a -- ^ Computed value + -> BuildSignal a +done = Done + +-- | Signal that the current buffer is full. +{-# INLINE bufferFull #-} +bufferFull :: Int + -- ^ Minimal size of next 'BufferRange'. + -> Ptr Word8 + -- ^ Next free byte in current 'BufferRange'. + -> BuildStep a + -- ^ 'BuildStep' to run on the next 'BufferRange'. This 'BuildStep' + -- may assume that it is called with a 'BufferRange' of at least the + -- required minimal size; i.e., the caller of this 'BuildStep' must + -- guarantee this. + -> BuildSignal a +bufferFull = BufferFull + +-- TODO: Decide whether we should inline the bytestring constructor. +-- Therefore, making builders independent of strict bytestrings. + +-- | Signal that several chunks should be inserted directly. +{-# INLINE insertChunks #-} +insertChunks :: Ptr Word8 + -- ^ Next free byte in current 'BufferRange' + -> Int64 + -- ^ Number of bytes in 'L.ByteString' continuation. + -> (L.ByteString -> L.ByteString) + -- ^ Chunks to insert. + -> BuildStep a + -- ^ 'BuildStep' to run on next 'BufferRange' + -> BuildSignal a +insertChunks = InsertChunks + +-- | Fill a 'BufferRange' using a 'BuildStep'. +{-# INLINE fillWithBuildStep #-} +fillWithBuildStep + :: BuildStep a + -- ^ Build step to use for filling the 'BufferRange'. + -> (Ptr Word8 -> a -> IO b) + -- ^ Handling the 'done' signal + -> (Ptr Word8 -> Int -> BuildStep a -> IO b) + -- ^ Handling the 'bufferFull' signal + -> (Ptr Word8 -> Int64 -> LazyByteStringC -> BuildStep a -> IO b) + -- ^ Handling the 'insertChunks' signal + -> BufferRange + -- ^ Buffer range to fill. + -> IO b + -- ^ Value computed by filling this 'BufferRange'. +fillWithBuildStep step fDone fFull fChunk !br = do + signal <- step br + case signal of + Done op x -> fDone op x + BufferFull minSize op nextStep -> fFull op minSize nextStep + InsertChunks op len lbsC nextStep -> fChunk op len lbsC nextStep + + + +------------------------------------------------------------------------------ +-- The 'Builder' monoid +------------------------------------------------------------------------------ + +-- | 'Builder's denote sequences of bytes. +-- They are 'Monoid's where +-- 'mempty' is the zero-length sequence and +-- 'mappend' is concatenation, which runs in /O(1)/. +newtype Builder = Builder (forall r. BuildStep r -> BuildStep r) + +-- | Construct a 'Builder'. In contrast to 'BuildStep's, 'Builder's are +-- referentially transparent. +{-# INLINE builder #-} +builder :: (forall r. BuildStep r -> BuildStep r) + -- ^ A function that fills a 'BufferRange', calls the continuation with + -- the updated 'BufferRange' once its done, and signals its caller how + -- to proceed using 'done', 'bufferFull', or 'insertChunk'. + -- + -- This function must be referentially transparent; i.e., calling it + -- multiple times must result in the same sequence of bytes being + -- written. If you need mutable state, then you must allocate it newly + -- upon each call of this function. Moroever, this function must call + -- the continuation once its done. Otherwise, concatenation of + -- 'Builder's does not work. Finally, this function must write to all + -- bytes that it claims it has written. Otherwise, the resulting + -- 'Builder' is not guaranteed to be referentially transparent and + -- sensitive data might leak. + -> Builder +builder = Builder + +-- | Run a 'Builder'. +{-# INLINE runBuilder #-} +runBuilder :: Builder -- ^ 'Builder' to run + -> BuildStep () -- ^ 'BuildStep' that writes the byte stream of this + -- 'Builder' and signals 'done' upon completion. +runBuilder (Builder b) = b $ \(BufferRange op _) -> return $ done op () + +-- | Run a 'Builder'. +{-# INLINE runBuilderWith #-} +runBuilderWith :: Builder -- ^ 'Builder' to run + -> BuildStep a -- ^ Continuation 'BuildStep' + -> BuildStep a +runBuilderWith (Builder b) = b + +-- | The 'Builder' denoting a zero-length sequence of bytes. This function is +-- only exported for use in rewriting rules. Use 'mempty' otherwise. +{-# INLINE[1] empty #-} +empty :: Builder +empty = Builder id + +-- | Concatenate two 'Builder's. This function is only exported for use in rewriting +-- rules. Use 'mappend' otherwise. +{-# INLINE[1] append #-} +append :: Builder -> Builder -> Builder +append (Builder b1) (Builder b2) = Builder $ b1 . b2 + +instance Monoid Builder where + {-# INLINE mempty #-} + mempty = empty + {-# INLINE mappend #-} + mappend = append + {-# INLINE mconcat #-} + mconcat = foldr mappend mempty + +-- | Flush the current buffer. This introduces a chunk boundary. +-- +{-# INLINE flush #-} +flush :: Builder +flush = builder step + where + step k !(BufferRange op _) = return $ insertChunks op 0 id k + + +------------------------------------------------------------------------------ +-- Put +------------------------------------------------------------------------------ + +-- | A 'Put' action denotes a computation of a value that writes a stream of +-- bytes as a side-effect. 'Put's are strict in their side-effect; i.e., the +-- stream of bytes will always be written before the computed value is +-- returned. +-- +-- 'Put's are a generalization of 'Builder's. They are used when values need to +-- be returned during the computation of a stream of bytes. For example, when +-- performing a block-based encoding of 'S.ByteString's like Base64 encoding, +-- there might be a left-over partial block. Using the 'Put' monad, this +-- partial block can be returned after the complete blocks have been encoded. +-- Then, in a later step when more input is known, this partial block can be +-- completed and also encoded. +-- +-- @Put ()@ actions are isomorphic to 'Builder's. The functions 'putBuilder' +-- and 'fromPut' convert between these two types. Where possible, you should +-- use 'Builder's, as they are slightly cheaper than 'Put's because they do not +-- carry a computed value. +newtype Put a = Put { unPut :: forall r. (a -> BuildStep r) -> BuildStep r } + +-- | Construct a 'Put' action. In contrast to 'BuildStep's, 'Put's are +-- referentially transparent in the sense that sequencing the same 'Put' +-- multiple times yields every time the same value with the same side-effect. +{-# INLINE put #-} +put :: (forall r. (a -> BuildStep r) -> BuildStep r) + -- ^ A function that fills a 'BufferRange', calls the continuation with + -- the updated 'BufferRange' and its computed value once its done, and + -- signals its caller how to proceed using 'done', 'bufferFull', or + -- 'insertChunk'. + -- + -- This function must be referentially transparent; i.e., calling it + -- multiple times must result in the same sequence of bytes being + -- written and the same value being computed. If you need mutable state, + -- then you must allocate it newly upon each call of this function. + -- Moroever, this function must call the continuation once its done. + -- Otherwise, monadic sequencing of 'Put's does not work. Finally, this + -- function must write to all bytes that it claims it has written. + -- Otherwise, the resulting 'Put' is not guaranteed to be referentially + -- transparent and sensitive data might leak. + -> Put a +put = Put + +-- | Run a 'Put'. +{-# INLINE runPut #-} +runPut :: Put a -- ^ Put to run + -> BuildStep a -- ^ 'BuildStep' that first writes the byte stream of + -- this 'Put' and then yields the computed value using + -- the 'done' signal. +runPut (Put p) = p $ \x (BufferRange op _) -> return $ Done op x + +instance Functor Put where + fmap f p = Put $ \k -> unPut p (\x -> k (f x)) + {-# INLINE fmap #-} + +instance Applicative Put where + {-# INLINE pure #-} + pure x = Put $ \k -> k x + {-# INLINE (<*>) #-} + Put f <*> Put a = Put $ \k -> f (\f' -> a (\a' -> k (f' a'))) +#if MIN_VERSION_base(4,2,0) + {-# INLINE (<*) #-} + Put a <* Put b = Put $ \k -> a (\a' -> b (\_ -> k a')) + {-# INLINE (*>) #-} + Put a *> Put b = Put $ \k -> a (\_ -> b k) +#endif + +instance Monad Put where + {-# INLINE return #-} + return x = Put $ \k -> k x + {-# INLINE (>>=) #-} + Put m >>= f = Put $ \k -> m (\m' -> unPut (f m') k) + {-# INLINE (>>) #-} + Put m >> Put n = Put $ \k -> m (\_ -> n k) + + +-- Conversion between Put and Builder +------------------------------------- + +-- | Run a 'Builder' as a side-effect of a @Put ()@ action. +{-# INLINE putBuilder #-} +putBuilder :: Builder -> Put () +putBuilder (Builder b) = Put $ \k -> b (k ()) + +-- | Convert a @Put ()@ action to a 'Builder'. +{-# INLINE fromPut #-} +fromPut :: Put () -> Builder +fromPut (Put p) = Builder $ \k -> p (\_ -> k) + + +-- Lifting IO actions +--------------------- + +{- +-- | Lift an 'IO' action to a 'Put' action. +{-# INLINE putLiftIO #-} +putLiftIO :: IO a -> Put a +putLiftIO io = put $ \k br -> io >>= (`k` br) +-} + + +------------------------------------------------------------------------------ +-- Executing a Put directly on a buffered Handle +------------------------------------------------------------------------------ + +-- | Run a 'Put' action redirecting the produced output to a 'Handle'. +-- +-- The output is buffered using the 'Handle's associated buffer. If this +-- buffer is too small to execute one step of the 'Put' action, then +-- it is replaced with a large enough buffer. +hPut :: forall a. Handle -> Put a -> IO a +#if __GLASGOW_HASKELL__ >= 611 +hPut h p = do + fillHandle 1 (runPut p) + where + fillHandle :: Int -> BuildStep a -> IO a + fillHandle !minFree step = do + next <- wantWritableHandle "hPut" h fillHandle_ + next + where + -- | We need to return an inner IO action that is executed outside + -- the lock taken on the Handle for two reasons: + -- + -- 1. GHC.IO.Handle.Internals mentions in "Note [async]" that + -- we should never do any side-effecting operations before + -- an interuptible operation that may raise an async. exception + -- as long as we are inside 'wantWritableHandle' and the like. + -- We possibly run the interuptible 'flushWriteBuffer' right at + -- the start of 'fillHandle', hence entering it a second time is + -- not safe, as it could lead to a 'BuildStep' being run twice. + -- + -- 2. We use the 'S.hPut' function to also write to the handle. + -- This function tries to take the same lock taken by + -- 'wantWritableHandle'. Therefore, we cannot call 'S.hPut' + -- inside 'wantWritableHandle'. + -- + fillHandle_ :: Handle__ -> IO (IO a) + fillHandle_ h_ = do + makeSpace =<< readIORef refBuf + fillBuffer =<< readIORef refBuf + where + refBuf = haByteBuffer h_ + freeSpace buf = bufSize buf - bufR buf + + makeSpace buf + | bufSize buf < minFree = do + flushWriteBuffer h_ + s <- bufState <$> readIORef refBuf + newByteBuffer minFree s >>= writeIORef refBuf + + | freeSpace buf < minFree = flushWriteBuffer h_ + | otherwise = +#if __GLASGOW_HASKELL__ >= 613 + return () +#else + -- required for ghc-6.12 + flushWriteBuffer h_ +#endif + + fillBuffer buf + | freeSpace buf < minFree = + error $ unlines + [ "Data.ByteString.Lazy.Builder.Internal.hPut: internal error." + , " Not enough space after flush." + , " required: " ++ show minFree + , " free: " ++ show (freeSpace buf) + ] + | otherwise = do + let !br = BufferRange op (pBuf `plusPtr` bufSize buf) + res <- fillWithBuildStep step doneH fullH insertChunksH br + touchForeignPtr fpBuf + return res + where + fpBuf = bufRaw buf + pBuf = unsafeForeignPtrToPtr fpBuf + op = pBuf `plusPtr` bufR buf + + {-# INLINE updateBufR #-} + updateBufR op' = do + let !off' = op' `minusPtr` pBuf + !buf' = buf {bufR = off'} + writeIORef refBuf buf' + + doneH op' x = do + updateBufR op' + -- We must flush if this Handle is set to NoBuffering. + -- If it is set to LineBuffering, be conservative and + -- flush anyway (we didn't check for newlines in the data). + -- Flushing must happen outside this 'wantWriteableHandle' + -- due to the possible async. exception. + case haBufferMode h_ of + BlockBuffering _ -> return $ return x + _line_or_no_buffering -> return $ hFlush h >> return x + + fullH op' minSize nextStep = do + updateBufR op' + return $ fillHandle minSize nextStep + -- 'fillHandle' will flush the buffer (provided there is + -- really less than 'minSize' space left) before executing + -- the 'nextStep'. + + insertChunksH op' _ lbsC nextStep = do + updateBufR op' + return $ do + L.foldrChunks (\c rest -> S.hPut h c >> rest) (return ()) + (lbsC L.Empty) + fillHandle 1 nextStep +#else +hPut h p = + go =<< buildStepToCIOS strategy (return . Finished) (runPut p) + where + go (Finished k) = return k + go (Yield1 bs io) = S.hPut h bs >> io >>= go + go (YieldC _ lbsC io) = L.hPut h (lbsC L.Empty) >> io >>= go + strategy = untrimmedStrategy L.smallChunkSize L.defaultChunkSize +#endif + +------------------------------------------------------------------------------ +-- ByteString insertion / controlling chunk boundaries +------------------------------------------------------------------------------ + +-- Raw memory +------------- + +-- | Ensure that there are at least 'n' free bytes for the following 'Builder'. +{-# INLINE ensureFree #-} +ensureFree :: Int -> Builder +ensureFree minFree = + builder step + where + step k br@(BufferRange op ope) + | ope `minusPtr` op < minFree = return $ bufferFull minFree op k + | otherwise = k br + +-- | Copy the bytes from a 'BufferRange' into the output stream. +{-# INLINE bytesCopyStep #-} +bytesCopyStep :: BufferRange -- ^ Input 'BufferRange'. + -> BuildStep a -> BuildStep a +bytesCopyStep !(BufferRange ip0 ipe) k = + go ip0 + where + go !ip !(BufferRange op ope) + | inpRemaining <= outRemaining = do + copyBytes op ip inpRemaining + let !br' = BufferRange (op `plusPtr` inpRemaining) ope + k br' + | otherwise = do + copyBytes op ip outRemaining + let !ip' = ip `plusPtr` outRemaining + return $ bufferFull 1 ope (go ip') + where + outRemaining = ope `minusPtr` op + inpRemaining = ipe `minusPtr` ip + + + +-- Strict ByteStrings +------------------------------------------------------------------------------ + + +-- | Construct a 'Builder' that copies the strict 'S.ByteString's, if it is +-- smaller than the treshold, and inserts it directly otherwise. +-- +-- For example, @byteStringThreshold 1024@ copies strict 'S.ByteString's whose size +-- is less or equal to 1kb, and inserts them directly otherwise. This implies +-- that the average chunk-size of the generated lazy 'L.ByteString' may be as +-- low as 513 bytes, as there could always be just a single byte between the +-- directly inserted 1025 byte, strict 'S.ByteString's. +-- +{-# INLINE byteStringThreshold #-} +byteStringThreshold :: Int -> S.ByteString -> Builder +byteStringThreshold maxCopySize = + \bs -> builder $ step bs + where + step !bs@(S.PS _ _ len) !k br@(BufferRange !op _) + | len <= maxCopySize = byteStringCopyStep bs k br + | otherwise = + return $! insertChunks op (fromIntegral len) (L.chunk bs) k + +-- | Construct a 'Builder' that copies the strict 'S.ByteString'. +-- +-- Use this function to create 'Builder's from smallish (@<= 4kb@) +-- 'S.ByteString's or if you need to guarantee that the 'S.ByteString' is not +-- shared with the chunks generated by the 'Builder'. +-- +{-# INLINE byteStringCopy #-} +byteStringCopy :: S.ByteString -> Builder +byteStringCopy = \bs -> builder $ byteStringCopyStep bs + +{-# INLINE byteStringCopyStep #-} +byteStringCopyStep :: S.ByteString -> BuildStep a -> BuildStep a +byteStringCopyStep (S.PS ifp ioff isize) !k0 = + bytesCopyStep (BufferRange ip ipe) k + where + ip = unsafeForeignPtrToPtr ifp `plusPtr` ioff + ipe = ip `plusPtr` isize + k br = do touchForeignPtr ifp -- input consumed: OK to release here + k0 br + +-- | Construct a 'Builder' that always inserts the strict 'S.ByteString' +-- directly as a chunk. +-- +-- This implies flushing the output buffer, even if it contains just +-- a single byte. You should therefore use 'byteStringInsert' only for large +-- (@> 8kb@) 'S.ByteString's. Otherwise, the generated chunks are too +-- fragmented to be processed efficiently afterwards. +-- +{-# INLINE byteStringInsert #-} +byteStringInsert :: S.ByteString -> Builder +byteStringInsert = + \bs -> builder $ step bs + where + step !bs k !br@(BufferRange op _) + | S.null bs = k br + | otherwise = + return $ insertChunks op (fromIntegral $ S.length bs) (L.Chunk bs) k + + +-- Lazy bytestrings +------------------------------------------------------------------------------ + +-- | Construct a 'Builder' that uses the thresholding strategy of 'byteStringThreshold' +-- for each chunk of the lazy 'L.ByteString'. +-- +{-# INLINE lazyByteStringThreshold #-} +lazyByteStringThreshold :: Int -> L.ByteString -> Builder +lazyByteStringThreshold maxCopySize = + L.foldrChunks (\bs b -> byteStringThreshold maxCopySize bs `mappend` b) mempty + -- TODO: We could do better here. Currently, Large, Small, Large, leads to + -- an unnecessary copy of the 'Small' chunk. + +-- | Construct a 'Builder' that copies the lazy 'L.ByteString'. +-- +{-# INLINE lazyByteStringCopy #-} +lazyByteStringCopy :: L.ByteString -> Builder +lazyByteStringCopy = + L.foldrChunks (\bs b -> byteStringCopy bs `mappend` b) mempty + + +-- | Construct a 'Builder' that inserts all chunks of the lazy 'L.ByteString' +-- directly. +-- +{-# INLINE lazyByteStringInsert #-} +lazyByteStringInsert :: L.ByteString -> Builder +lazyByteStringInsert = + \lbs -> builder $ step lbs + where + step L.Empty k br = k br + step lbs k (BufferRange op _) = case go 0 id lbs of + (n, lbsC) -> return $ insertChunks op n lbsC k + + go !n lbsC L.Empty = (n, lbsC) + go !n lbsC (L.Chunk bs lbs) = + go (n + fromIntegral (S.length bs)) (lbsC . L.Chunk bs) lbs + + +-- | Create a 'Builder' denoting the same sequence of bytes as a strict +-- 'S.ByteString'. +-- The 'Builder' inserts large 'S.ByteString's directly, but copies small ones +-- to ensure that the generated chunks are large on average. +-- +{-# INLINE byteString #-} +byteString :: S.ByteString -> Builder +byteString = byteStringThreshold maximalCopySize + +-- | Create a 'Builder' denoting the same sequence of bytes as a lazy +-- 'S.ByteString'. +-- The 'Builder' inserts large chunks of the lazy 'L.ByteString' directly, +-- but copies small ones to ensure that the generated chunks are large on +-- average. +-- +{-# INLINE lazyByteString #-} +lazyByteString :: L.ByteString -> Builder +lazyByteString = lazyByteStringThreshold maximalCopySize +-- FIXME: also insert the small chunk for [large,small,large] directly. +-- Perhaps it makes even sense to concatenate the small chunks in +-- [large,small,small,small,large] and insert them directly afterwards to avoid +-- unnecessary buffer spilling. Hmm, but that uncontrollably increases latency +-- => no good! + +-- | The maximal size of a 'S.ByteString' that is copied. +-- @2 * 'L.smallChunkSize'@ to guarantee that on average a chunk is of +-- 'L.smallChunkSize'. +maximalCopySize :: Int +maximalCopySize = 2 * L.smallChunkSize + +-- LazyByteStringC: difference lists of lazy bytestrings +-------------------------------------------------------- + +-- | Insert a 'LazyByteStringC' of the given size directly. +{-# INLINE lazyByteStringC #-} +lazyByteStringC :: Int64 -> LazyByteStringC -> Builder +lazyByteStringC n lbsC = + builder $ \k (BufferRange op _) -> return $ insertChunks op n lbsC k + +------------------------------------------------------------------------------ +-- Builder execution +------------------------------------------------------------------------------ + +-- | A buffer allocation strategy for executing 'Builder's. + +-- The strategy +-- +-- > 'AllocationStrategy' firstBufSize bufSize trim +-- +-- states that the first buffer is of size @firstBufSize@, all following buffers +-- are of size @bufSize@, and a buffer of size @n@ filled with @k@ bytes should +-- be trimmed iff @trim k n@ is 'True'. +data AllocationStrategy = AllocationStrategy + {-# UNPACK #-} !Int -- size of first buffer + {-# UNPACK #-} !Int -- size of successive buffers + (Int -> Int -> Bool) -- trim + +-- | Sanitize a buffer size; i.e., make it at least the size of a 'Int'. +{-# INLINE sanitize #-} +sanitize :: Int -> Int +sanitize = max (sizeOf (undefined :: Int)) + +-- | Use this strategy for generating lazy 'L.ByteString's whose chunks are +-- discarded right after they are generated. For example, if you just generate +-- them to write them to a network socket. +{-# INLINE untrimmedStrategy #-} +untrimmedStrategy :: Int -- ^ Size of the first buffer + -> Int -- ^ Size of successive buffers + -> AllocationStrategy + -- ^ An allocation strategy that does not trim any of the + -- filled buffers before converting it to a chunk. +untrimmedStrategy firstSize bufSize = + AllocationStrategy (sanitize firstSize) (sanitize bufSize) (\_ _ -> False) + + +-- | Use this strategy for generating lazy 'L.ByteString's whose chunks are +-- likely to survive one garbage collection. This strategy trims buffers +-- that are filled less than half in order to avoid spilling too much memory. +{-# INLINE safeStrategy #-} +safeStrategy :: Int -- ^ Size of first buffer + -> Int -- ^ Size of successive buffers + -> AllocationStrategy + -- ^ An allocation strategy that guarantees that at least half + -- of the allocated memory is used for live data +safeStrategy firstSize bufSize = + AllocationStrategy (sanitize firstSize) (sanitize bufSize) + (\used size -> 2*used < size) + +-- | Execute a 'Builder' with custom execution parameters. +-- +-- This function is forced to be inlined to allow fusing with the allocation +-- strategy despite its rather heavy code-size. We therefore recommend +-- that you introduce a top-level function once you have fixed your strategy. +-- This avoids unnecessary code duplication. +-- For example, the default 'Builder' execution function 'toLazyByteString' is +-- defined as follows. +-- +-- @ +-- {-# NOINLINE toLazyByteString #-} +-- toLazyByteString = +-- toLazyByteStringWith ('safeStrategy' 'L.smallChunkSize' 'L.defaultChunkSize') empty +-- @ +-- +-- where @empty@ is the zero-length lazy 'L.ByteString'. +-- +-- In most cases, the parameters used by 'toLazyByteString' give good +-- performance. A sub-performing case of 'toLazyByteString' is executing short +-- (<128 bytes) 'Builder's. In this case, the allocation overhead for the first +-- 4kb buffer and the trimming cost dominate the cost of executing the +-- 'Builder'. You can avoid this problem using +-- +-- >toLazyByteStringWith (safeStrategy 128 smallChunkSize) empty +-- +-- This reduces the allocation and trimming overhead, as all generated +-- 'L.ByteString's fit into the first buffer and there is no trimming +-- required, if more than 64 bytes are written. +-- +{-# INLINE toLazyByteStringWith #-} +toLazyByteStringWith + :: AllocationStrategy + -- ^ Buffer allocation strategy to use + -> L.ByteString + -- ^ Lazy 'L.ByteString' to use as the tail of the generated lazy + -- 'L.ByteString' + -> Builder + -- ^ Builder to execute + -> L.ByteString + -- ^ Resulting lazy 'L.ByteString' +toLazyByteStringWith strategy k b = + ciosToLazyByteString k $ unsafePerformIO $ + buildStepToCIOS strategy (return . Finished) (runBuilder b) + +-- | A stream of non-empty chunks interleaved with 'IO'. +data ChunkIOStream a = + Finished a + | Yield1 {-# UNPACK #-} !S.ByteString (IO (ChunkIOStream a)) + | YieldC {-# UNPACK #-} !Int64 LazyByteStringC (IO (ChunkIOStream a)) + +{-# INLINE ciosToLazyByteString #-} +ciosToLazyByteString :: L.ByteString -> ChunkIOStream () -> L.ByteString +ciosToLazyByteString k = go + where + go (Finished _) = k + go (Yield1 bs io) = L.Chunk bs $ unsafePerformIO (go <$> io) + go (YieldC _ lbsC io) = lbsC $ unsafePerformIO (go <$> io) + +{-# INLINE buildStepToCIOS #-} +buildStepToCIOS + :: AllocationStrategy -- ^ Buffer allocation strategy to use + -> (a -> IO (ChunkIOStream b)) -- ^ Continuation stream constructor. + -> BuildStep a -- ^ 'Put' to execute + -> IO (ChunkIOStream b) +buildStepToCIOS (AllocationStrategy firstSize bufSize trim) k = + \step -> fillNew step firstSize + where + fillNew !step0 !size = do + S.mallocByteString size >>= fill step0 + where + fill !step !fpbuf = do + res <- fillWithBuildStep step doneH fullH insertChunksH br + touchForeignPtr fpbuf + return res + where + op = unsafeForeignPtrToPtr fpbuf -- safe due to mkCIOS + pe = op `plusPtr` size + br = BufferRange op pe + + doneH op' x = wrapChunk op' (const $ k x) + + fullH op' minSize nextStep = + wrapChunk op' (const $ fillNew nextStep (max minSize bufSize)) + + insertChunksH op' n lbsC nextStep = + wrapChunk op' $ \isEmpty -> return $ YieldC n lbsC $ + -- Checking for empty case avoids allocating 'n-1' empty + -- buffers for 'n' insertChunksH right after each other. + if isEmpty + then fill nextStep fpbuf + else fillNew nextStep bufSize + + -- Yield a chunk, trimming it if necesary + {-# INLINE wrapChunk #-} + wrapChunk !op' mkCIOS + | pe < op' = error $ + "buildStepToCIOS: overwrite by " ++ show (op' `minusPtr` pe) ++ " bytes" + | chunkSize == 0 = mkCIOS True + | trim chunkSize size = do + bs <- S.create chunkSize $ \pbuf -> copyBytes pbuf op chunkSize + return $ Yield1 bs (mkCIOS False) + | otherwise = + return $ Yield1 (S.PS fpbuf 0 chunkSize) (mkCIOS False) + where + chunkSize = op' `minusPtr` op diff --git a/Data/ByteString/Lazy/Char8.hs b/Data/ByteString/Lazy/Char8.hs --- a/Data/ByteString/Lazy/Char8.hs +++ b/Data/ByteString/Lazy/Char8.hs @@ -6,12 +6,13 @@ -- | -- Module : Data.ByteString.Lazy.Char8 --- Copyright : (c) Don Stewart 2006 +-- Copyright : (c) Don Stewart 2006-2008 +-- (c) Duncan Coutts 2006-2011 -- License : BSD-style -- --- Maintainer : dons@cse.unsw.edu.au --- Stability : experimental --- Portability : non-portable (imports Data.ByteString.Lazy) +-- Maintainer : dons00@gmail.com, duncan@community.haskell.org +-- Stability : stable +-- Portability : portable -- -- Manipulate /lazy/ 'ByteString's using 'Char' operations. All Chars will -- be truncated to 8 bits. It can be expected that these functions will @@ -23,6 +24,11 @@ -- -- > import qualified Data.ByteString.Lazy.Char8 as C -- +-- 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 @{-\# LANGUAGE OverloadedStrings \#-}@ to enable this. +-- module Data.ByteString.Lazy.Char8 ( @@ -36,6 +42,8 @@ unpack, -- :: ByteString -> String fromChunks, -- :: [Strict.ByteString] -> ByteString toChunks, -- :: ByteString -> [Strict.ByteString] + fromStrict, -- :: Strict.ByteString -> ByteString + toStrict, -- :: ByteString -> Strict.ByteString -- * Basic interface cons, -- :: Char -> ByteString -> ByteString @@ -183,7 +191,7 @@ -- Functions transparently exported import Data.ByteString.Lazy - (fromChunks, toChunks + (fromChunks, toChunks, fromStrict, toStrict ,empty,null,length,tail,init,append,reverse,transpose,cycle ,concat,take,drop,splitAt,intercalate,isPrefixOf,group,inits,tails,copy ,hGetContents, hGet, hPut, getContents @@ -216,10 +224,6 @@ import IO (bracket) #endif -#if __GLASGOW_HASKELL__ >= 608 -import Data.String (IsString(..)) -#endif - #define STRICT1(f) f a | a `seq` False = undefined #define STRICT2(f) f a b | a `seq` b `seq` False = undefined #define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined @@ -234,20 +238,16 @@ singleton = L.singleton . c2w {-# INLINE singleton #-} -#if __GLASGOW_HASKELL__ >= 608 -instance IsString ByteString where - fromString = pack - {-# INLINE fromString #-} -#endif - -- | /O(n)/ Convert a 'String' into a 'ByteString'. pack :: [Char] -> ByteString -pack = L.pack. List.map c2w +pack = packChars -- | /O(n)/ Converts a 'ByteString' to a 'String'. unpack :: ByteString -> [Char] -unpack = List.map w2c . L.unpack -{-# INLINE unpack #-} +unpack = unpackChars + +infixr 5 `cons`, `cons'` --same as list (:) +infixl 5 `snoc` -- | /O(1)/ 'cons' is analogous to '(:)' for lists. cons :: Char -> ByteString -> ByteString diff --git a/Data/ByteString/Lazy/Internal.hs b/Data/ByteString/Lazy/Internal.hs --- a/Data/ByteString/Lazy/Internal.hs +++ b/Data/ByteString/Lazy/Internal.hs @@ -1,15 +1,17 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} --- We cannot actually specify all the language pragmas, see ghc ticket # --- If we could, these are what they would be: -{- LANGUAGE DeriveDataTypeable -} +{-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns #-} +#if __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable #-} +#endif {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.ByteString.Lazy.Internal +-- Copyright : (c) Don Stewart 2006-2008 +-- (c) Duncan Coutts 2006-2011 -- License : BSD-style --- Maintainer : dons@galois.com, duncan@haskell.org --- Stability : experimental --- Portability : portable +-- Maintainer : dons00@gmail.com, duncan@community.haskell.org +-- Stability : unstable +-- Portability : non-portable -- -- A module containing semi-public 'ByteString' internals. This exposes -- the 'ByteString' representation and low level construction functions. @@ -32,21 +34,39 @@ -- * Chunk allocation sizes defaultChunkSize, smallChunkSize, - chunkOverhead + chunkOverhead, + -- * Conversion with lists: packing and unpacking + packBytes, packChars, + unpackBytes, unpackChars, + ) where +import Prelude hiding (concat) + import qualified Data.ByteString.Internal as S +import qualified Data.ByteString as S (length, take, drop) +import Data.Word (Word8) import Foreign.Storable (Storable(sizeOf)) -#if defined(__GLASGOW_HASKELL__) -import Data.Typeable (Typeable) -#if __GLASGOW_HASKELL__ >= 610 -import Data.Data (Data) +import Data.Monoid (Monoid(..)) +import Control.DeepSeq (NFData, rnf) + +#if MIN_VERSION_base(3,0,0) +import Data.String (IsString(..)) +#endif + +import Data.Typeable (Typeable) +#if MIN_VERSION_base(4,1,0) +import Data.Data (Data(..)) +#if MIN_VERSION_base(4,2,0) +import Data.Data (mkNoRepType) #else -import Data.Generics (Data) +import Data.Data (mkNorepType) #endif +#else +import Data.Generics (Data(..), mkNorepType) #endif -- | A space-efficient representation of a Word8 vector, supporting many @@ -55,14 +75,76 @@ -- Instances of Eq, Ord, Read, Show, Data, Typeable -- data ByteString = Empty | Chunk {-# UNPACK #-} !S.ByteString ByteString - deriving (Show, Read + #if defined(__GLASGOW_HASKELL__) - ,Data, Typeable + deriving (Typeable) #endif - ) +instance Eq ByteString where + (==) = eq + +instance Ord ByteString where + compare = cmp + +instance Monoid ByteString where + mempty = Empty + mappend = append + mconcat = concat + +instance NFData ByteString where + rnf Empty = () + rnf (Chunk _ b) = rnf b + +instance Show ByteString where + showsPrec p ps r = showsPrec p (unpackChars ps) r + +instance Read ByteString where + readsPrec p str = [ (packChars x, y) | (x, y) <- readsPrec p str ] + +#if MIN_VERSION_base(3,0,0) +instance IsString ByteString where + fromString = packChars +#endif + +instance Data ByteString where + gfoldl f z txt = z packBytes `f` unpackBytes txt + toConstr _ = error "Data.ByteString.Lazy.ByteString.toConstr" + gunfold _ _ = error "Data.ByteString.Lazy.ByteString.gunfold" +#if MIN_VERSION_base(4,2,0) + dataTypeOf _ = mkNoRepType "Data.ByteString.Lazy.ByteString" +#else + dataTypeOf _ = mkNorepType "Data.ByteString.Lazy.ByteString" +#endif + ------------------------------------------------------------------------ +-- Packing and unpacking from lists +packBytes :: [Word8] -> ByteString +packBytes cs0 = + packChunks 32 cs0 + where + packChunks n cs = case S.packUptoLenBytes n cs of + (bs, []) -> chunk bs Empty + (bs, cs') -> Chunk bs (packChunks (min (n * 2) smallChunkSize) cs') + +packChars :: [Char] -> ByteString +packChars cs0 = + packChunks 32 cs0 + where + packChunks n cs = case S.packUptoLenChars n cs of + (bs, []) -> chunk bs Empty + (bs, cs') -> Chunk bs (packChunks (min (n * 2) smallChunkSize) cs') + +unpackBytes :: ByteString -> [Word8] +unpackBytes Empty = [] +unpackBytes (Chunk c cs) = S.unpackAppendBytesLazy c (unpackBytes cs) + +unpackChars :: ByteString -> [Char] +unpackChars Empty = [] +unpackChars (Chunk c cs) = S.unpackAppendCharsLazy c (unpackChars cs) + +------------------------------------------------------------------------ + -- | The data type invariant: -- Every ByteString is either 'Empty' or consists of non-null 'S.ByteString's. -- All functions must preserve this, and the QC properties must check this. @@ -116,12 +198,12 @@ -- The following value assumes people have something greater than 128k, -- and need to share the cache with other programs. --- | Currently set to 32k, less the memory management overhead +-- | The chunk size used for I\/O. Currently set to 32k, less the memory management overhead defaultChunkSize :: Int defaultChunkSize = 32 * k - chunkOverhead where k = 1024 --- | Currently set to 4k, less the memory management overhead +-- | The recommended chunk size. Currently set to 4k, less the memory management overhead smallChunkSize :: Int smallChunkSize = 4 * k - chunkOverhead where k = 1024 @@ -129,3 +211,43 @@ -- | The memory management overhead. Currently this is tuned for GHC only. chunkOverhead :: Int chunkOverhead = 2 * sizeOf (undefined :: Int) + +------------------------------------------------------------------------ +-- Implementations for Eq, Ord and Monoid instances + +eq :: ByteString -> ByteString -> Bool +eq Empty Empty = True +eq Empty _ = False +eq _ Empty = False +eq (Chunk a as) (Chunk b bs) = + case compare (S.length a) (S.length b) of + LT -> a == (S.take (S.length a) b) && eq as (Chunk (S.drop (S.length a) b) bs) + EQ -> a == b && eq as bs + GT -> (S.take (S.length b) a) == b && eq (Chunk (S.drop (S.length b) a) as) bs + +cmp :: ByteString -> ByteString -> Ordering +cmp Empty Empty = EQ +cmp Empty _ = LT +cmp _ Empty = GT +cmp (Chunk a as) (Chunk b bs) = + case compare (S.length a) (S.length b) of + LT -> case compare a (S.take (S.length a) b) of + EQ -> cmp as (Chunk (S.drop (S.length a) b) bs) + result -> result + EQ -> case compare a b of + EQ -> cmp as bs + result -> result + GT -> case compare (S.take (S.length b) a) b of + EQ -> cmp (Chunk (S.drop (S.length b) a) as) bs + result -> result + +append :: ByteString -> ByteString -> ByteString +append xs ys = foldrChunks Chunk ys xs + +concat :: [ByteString] -> ByteString +concat css0 = to css0 + where + go Empty css = to css + go (Chunk c cs) css = Chunk c (go cs css) + to [] = Empty + to (cs:css) = go cs css diff --git a/Data/ByteString/Unsafe.hs b/Data/ByteString/Unsafe.hs --- a/Data/ByteString/Unsafe.hs +++ b/Data/ByteString/Unsafe.hs @@ -1,14 +1,16 @@ {-# LANGUAGE CPP #-} --- We cannot actually specify all the language pragmas, see ghc ticket # --- If we could, these are what they would be: -{- LANGUAGE MagicHash -} +#if __GLASGOW_HASKELL__ +{-# LANGUAGE MagicHash #-} +#endif -- | -- Module : Data.ByteString.Unsafe +-- Copyright : (c) Don Stewart 2006-2008 +-- (c) Duncan Coutts 2006-2011 -- License : BSD-style --- Maintainer : dons@cse.unsw.edu.au, duncan@haskell.org --- Stability : experimental --- Portability : portable +-- Maintainer : dons00@gmail.com, duncan@community.haskell.org +-- Stability : provisional +-- Portability : non-portable -- -- A module containing unsafe 'ByteString' operations. -- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,7 @@ Copyright (c) Don Stewart 2005-2009 - (c) Duncan Coutts 2006-2009 - (c) David Roundy 2003-2005. + (c) Duncan Coutts 2006-2011 + (c) David Roundy 2003-2005 + (c) Simon Meier 2010-2011 All rights reserved. diff --git a/bench/BenchAll.hs b/bench/BenchAll.hs new file mode 100644 --- /dev/null +++ b/bench/BenchAll.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE PackageImports, ScopedTypeVariables, BangPatterns #-} +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Benchmark all 'Builder' functions. +module Main (main) where + +import Prelude hiding (words) +import Criterion.Main +import Data.Foldable (foldMap) + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +import Data.ByteString.Lazy.Builder +import Data.ByteString.Lazy.Builder.ASCII +import Data.ByteString.Lazy.Builder.BasicEncoding + ( FixedEncoding, BoundedEncoding, (>$<) ) +import qualified Data.ByteString.Lazy.Builder.BasicEncoding as E +import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Internal as EI + +import Foreign + +------------------------------------------------------------------------------ +-- Benchmark support +------------------------------------------------------------------------------ + +countToZero :: Int -> Maybe (Int, Int) +countToZero 0 = Nothing +countToZero n = Just (n, n - 1) + + +------------------------------------------------------------------------------ +-- Benchmark +------------------------------------------------------------------------------ + +-- input data (NOINLINE to ensure memoization) +---------------------------------------------- + +-- | Few-enough repetitions to avoid making GC too expensive. +nRepl :: Int +nRepl = 10000 + +{-# NOINLINE intData #-} +intData :: [Int] +intData = [1..nRepl] + +-- Half of the integers inside the range of an Int and half of them outside. +{-# NOINLINE integerData #-} +integerData :: [Integer] +integerData = map (\x -> fromIntegral x + fromIntegral (maxBound - nRepl `div` 2)) intData + +{-# NOINLINE floatData #-} +floatData :: [Float] +floatData = map (\x -> (3.14159 * fromIntegral x) ^ (3 :: Int)) intData + +{-# NOINLINE doubleData #-} +doubleData :: [Double] +doubleData = map (\x -> (3.14159 * fromIntegral x) ^ (3 :: Int)) intData + +{-# NOINLINE byteStringData #-} +byteStringData :: S.ByteString +byteStringData = S.pack $ map fromIntegral intData + +{-# NOINLINE lazyByteStringData #-} +lazyByteStringData :: L.ByteString +lazyByteStringData = case S.splitAt (nRepl `div` 2) byteStringData of + (bs1, bs2) -> L.fromChunks [bs1, bs2] + + +-- benchmark wrappers +--------------------- + +{-# INLINE benchB #-} +benchB :: String -> a -> (a -> Builder) -> Benchmark +benchB name x b = + bench (name ++" (" ++ show nRepl ++ ")") $ + whnf (L.length . toLazyByteString . b) x + +{-# INLINE benchBInts #-} +benchBInts :: String -> ([Int] -> Builder) -> Benchmark +benchBInts name = benchB name intData + +-- | Benchmark a 'FixedEncoding'. Full inlining to enable specialization. +{-# INLINE benchFE #-} +benchFE :: String -> FixedEncoding Int -> Benchmark +benchFE name = benchBE name . E.fromF + +-- | Benchmark a 'BoundedEncoding'. Full inlining to enable specialization. +{-# INLINE benchBE #-} +benchBE :: String -> BoundedEncoding Int -> Benchmark +benchBE name e = + bench (name ++" (" ++ show nRepl ++ ")") $ benchIntEncodingB nRepl e + +-- We use this construction of just looping through @n,n-1,..,1@ to ensure that +-- we measure the speed of the encoding and not the speed of generating the +-- values to be encoded. +{-# INLINE benchIntEncodingB #-} +benchIntEncodingB :: Int -- ^ Maximal 'Int' to write + -> BoundedEncoding Int -- ^ 'BoundedEncoding' to execute + -> IO () -- ^ 'IO' action to benchmark +benchIntEncodingB n0 w + | n0 <= 0 = return () + | otherwise = do + fpbuf <- mallocForeignPtrBytes (n0 * EI.sizeBound w) + withForeignPtr fpbuf (loop n0) >> return () + where + loop !n !op + | n <= 0 = return op + | otherwise = EI.runB w n op >>= loop (n - 1) + + + +-- benchmarks +------------- + +sanityCheckInfo :: [String] +sanityCheckInfo = + [ "Sanity checks:" + , " lengths of input data: " ++ show + [ length intData, length floatData, length doubleData, length integerData + , S.length byteStringData, fromIntegral (L.length lazyByteStringData) + ] + ] + +main :: IO () +main = do + mapM_ putStrLn sanityCheckInfo + putStrLn "" + Criterion.Main.defaultMain + [ bgroup "Data.ByteString.Lazy.Builder" + [ bgroup "Encoding wrappers" + [ benchBInts "foldMap word8" $ + foldMap (word8 . fromIntegral) + , benchBInts "encodeListWithF word8" $ + E.encodeListWithF (fromIntegral >$< E.word8) + , benchB "encodeUnfoldrWithF word8" nRepl $ + E.encodeUnfoldrWithF (fromIntegral >$< E.word8) countToZero + , benchB "encodeByteStringWithF word8" byteStringData $ + E.encodeByteStringWithF E.word8 + , benchB "encodeLazyByteStringWithF word8" lazyByteStringData $ + E.encodeLazyByteStringWithF E.word8 + ] + + , bgroup "Non-bounded encodings" + [ benchB "foldMap floatDec" floatData $ foldMap floatDec + , benchB "foldMap doubleDec" doubleData $ foldMap doubleDec + , benchB "foldMap integerDec" integerData $ foldMap integerDec + , benchB "byteStringHexFixed" byteStringData $ byteStringHexFixed + , benchB "lazyByteStringHexFixed" lazyByteStringData $ lazyByteStringHexFixed + ] + ] + + , bgroup "Data.ByteString.Lazy.Builder.BasicEncoding" + [ benchFE "char7" $ toEnum >$< E.char7 + , benchFE "char8" $ toEnum >$< E.char8 + , benchBE "charUtf8" $ toEnum >$< E.charUtf8 + + -- binary encoding + , benchFE "int8" $ fromIntegral >$< E.int8 + , benchFE "word8" $ fromIntegral >$< E.word8 + + -- big-endian + , benchFE "int16BE" $ fromIntegral >$< E.int16BE + , benchFE "int32BE" $ fromIntegral >$< E.int32BE + , benchFE "int64BE" $ fromIntegral >$< E.int64BE + + , benchFE "word16BE" $ fromIntegral >$< E.word16BE + , benchFE "word32BE" $ fromIntegral >$< E.word32BE + , benchFE "word64BE" $ fromIntegral >$< E.word64BE + + , benchFE "floatBE" $ fromIntegral >$< E.floatBE + , benchFE "doubleBE" $ fromIntegral >$< E.doubleBE + + -- little-endian + , benchFE "int16LE" $ fromIntegral >$< E.int16LE + , benchFE "int32LE" $ fromIntegral >$< E.int32LE + , benchFE "int64LE" $ fromIntegral >$< E.int64LE + + , benchFE "word16LE" $ fromIntegral >$< E.word16LE + , benchFE "word32LE" $ fromIntegral >$< E.word32LE + , benchFE "word64LE" $ fromIntegral >$< E.word64LE + + , benchFE "floatLE" $ fromIntegral >$< E.floatLE + , benchFE "doubleLE" $ fromIntegral >$< E.doubleLE + + -- host-dependent + , benchFE "int16Host" $ fromIntegral >$< E.int16Host + , benchFE "int32Host" $ fromIntegral >$< E.int32Host + , benchFE "int64Host" $ fromIntegral >$< E.int64Host + , benchFE "intHost" $ fromIntegral >$< E.intHost + + , benchFE "word16Host" $ fromIntegral >$< E.word16Host + , benchFE "word32Host" $ fromIntegral >$< E.word32Host + , benchFE "word64Host" $ fromIntegral >$< E.word64Host + , benchFE "wordHost" $ fromIntegral >$< E.wordHost + + , benchFE "floatHost" $ fromIntegral >$< E.floatHost + , benchFE "doubleHost" $ fromIntegral >$< E.doubleHost + ] + + , bgroup "Data.ByteString.Lazy.Builder.BoundedEncoding.ASCII" + [ + -- decimal number + benchBE "int8Dec" $ fromIntegral >$< E.int8Dec + , benchBE "int16Dec" $ fromIntegral >$< E.int16Dec + , benchBE "int32Dec" $ fromIntegral >$< E.int32Dec + , benchBE "int64Dec" $ fromIntegral >$< E.int64Dec + , benchBE "intDec" $ fromIntegral >$< E.intDec + + , benchBE "word8Dec" $ fromIntegral >$< E.word8Dec + , benchBE "word16Dec" $ fromIntegral >$< E.word16Dec + , benchBE "word32Dec" $ fromIntegral >$< E.word32Dec + , benchBE "word64Dec" $ fromIntegral >$< E.word64Dec + , benchBE "wordDec" $ fromIntegral >$< E.wordDec + + -- hexadecimal number + , benchBE "word8Hex" $ fromIntegral >$< E.word8Hex + , benchBE "word16Hex" $ fromIntegral >$< E.word16Hex + , benchBE "word32Hex" $ fromIntegral >$< E.word32Hex + , benchBE "word64Hex" $ fromIntegral >$< E.word64Hex + , benchBE "wordHex" $ fromIntegral >$< E.wordHex + + -- fixed-width hexadecimal numbers + , benchFE "int8HexFixed" $ fromIntegral >$< E.int8HexFixed + , benchFE "int16HexFixed" $ fromIntegral >$< E.int16HexFixed + , benchFE "int32HexFixed" $ fromIntegral >$< E.int32HexFixed + , benchFE "int64HexFixed" $ fromIntegral >$< E.int64HexFixed + + , benchFE "word8HexFixed" $ fromIntegral >$< E.word8HexFixed + , benchFE "word16HexFixed" $ fromIntegral >$< E.word16HexFixed + , benchFE "word32HexFixed" $ fromIntegral >$< E.word32HexFixed + , benchFE "word64HexFixed" $ fromIntegral >$< E.word64HexFixed + + , benchFE "floatHexFixed" $ fromIntegral >$< E.floatHexFixed + , benchFE "doubleHexFixed" $ fromIntegral >$< E.doubleHexFixed + ] + ] diff --git a/bench/BoundsCheckFusion.hs b/bench/BoundsCheckFusion.hs new file mode 100644 --- /dev/null +++ b/bench/BoundsCheckFusion.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE PackageImports, ScopedTypeVariables, BangPatterns #-} +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- Benchmark that the bounds checks fuse. +module Main (main) where + +import Prelude hiding (words) +import Criterion.Main +import Data.Monoid +import Data.Foldable (foldMap) + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +import Data.ByteString.Lazy.Builder +import Data.ByteString.Lazy.Builder.Extras +import Data.ByteString.Lazy.Builder.BasicEncoding + ( FixedEncoding, BoundedEncoding, (>$<), (>*<) ) +import qualified Data.ByteString.Lazy.Builder.BasicEncoding as E +import qualified Data.ByteString.Lazy.Builder.Internal as I +import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Internal as I + +import Foreign + +------------------------------------------------------------------------------ +-- Benchmark support +------------------------------------------------------------------------------ + +countToZero :: Int -> Maybe (Int, Int) +countToZero 0 = Nothing +countToZero n = Just (n, n - 1) + + +------------------------------------------------------------------------------ +-- Benchmark +------------------------------------------------------------------------------ + +-- input data (NOINLINE to ensure memoization) +---------------------------------------------- + +-- | Few-enough repetitions to avoid making GC too expensive. +nRepl :: Int +nRepl = 10000 + +{-# NOINLINE intData #-} +intData :: [Int] +intData = [1..nRepl] + +-- benchmark wrappers +--------------------- + +{-# INLINE benchB #-} +benchB :: String -> a -> (a -> Builder) -> Benchmark +benchB name x b = + bench (name ++" (" ++ show nRepl ++ ")") $ + whnf (L.length . toLazyByteString . b) x + +{-# INLINE benchBInts #-} +benchBInts :: String -> ([Int] -> Builder) -> Benchmark +benchBInts name = benchB name intData + + +-- benchmarks +------------- + +sanityCheckInfo :: [String] +sanityCheckInfo = + [ "Sanity checks:" + , " lengths of input data: " ++ show + [ length intData ] + ] + +main :: IO () +main = do + mapM_ putStrLn sanityCheckInfo + putStrLn "" + Criterion.Main.defaultMain + [ bgroup "Data.ByteString.Lazy.Builder" + [ -- benchBInts "foldMap intHost" $ + -- foldMap (intHost . fromIntegral) + +{- + benchBInts "mapM_ (\\x -> intHost x `mappend` intHost x)" $ + foldMap ((\x -> intHost x `mappend` intHost x) + + , benchBInts "foldMap (\\x -> intHost x `mappend` intHost x)" $ + foldMap (\x -> intHost x `mappend` intHost x) +-} + + benchBInts "foldMap (left-assoc)" $ + foldMap (\x -> (stringUtf8 "s" `mappend` intHost x) `mappend` intHost x) + + , benchBInts "foldMap (right-assoc)" $ + foldMap (\x -> intHost x `mappend` (intHost x `mappend` stringUtf8 "s")) + + , benchBInts "foldMap [manually fused, left-assoc]" $ + foldMap (\x -> stringUtf8 "s" `mappend` E.encodeWithB (E.fromF $ E.intHost >*< E.intHost) (x, x)) + + , benchBInts "foldMap [manually fused, right-assoc]" $ + foldMap (\x -> E.encodeWithB (E.fromF $ E.intHost >*< E.intHost) (x, x) `mappend` stringUtf8 "s") + + -- , benchBInts "encodeListWithF intHost" $ + -- E.encodeListWithF (fromIntegral >$< E.intHost) + ] + ] + +{-# RULES + +"append/encodeWithB" forall w1 w2 x1 x2. + I.append (E.encodeWithB w1 x1) (E.encodeWithB w2 x2) + = E.encodeWithB (E.pairB w1 w2) (x1, x2) + +"append/encodeWithB/assoc_r" forall w1 w2 x1 x2 b. + I.append (E.encodeWithB w1 x1) (I.append (E.encodeWithB w2 x2) b) + = I.append (E.encodeWithB (E.pairB w1 w2) (x1, x2)) b + +"append/encodeWithB/assoc_l" forall w1 w2 x1 x2 b. + I.append (I.append b (E.encodeWithB w1 x1)) (E.encodeWithB w2 x2) + = I.append b (E.encodeWithB (E.pairB w1 w2) (x1, x2)) + #-} + diff --git a/bytestring.cabal b/bytestring.cabal --- a/bytestring.cabal +++ b/bytestring.cabal @@ -1,33 +1,64 @@ Name: bytestring -Version: 0.9.2.1 -Synopsis: Fast, packed, strict and lazy byte arrays with a list interface +Version: 0.10.0.0 +Synopsis: Fast, compact, strict and lazy byte strings 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, and lazy lists of - strict chunks, held in a 'ForeignPtr', and can be passed between C - and Haskell with little effort. + An efficient compact, immutable byte string type (both strict and lazy) + suitable for binary or 8-bit character data. . - Test coverage data for this library is available at: - + The 'ByteString' type represents sequences of bytes or 8-bit characters. + It is suitable for high performance use, both in terms of large data + quantities, or high speed requirements. The 'ByteStrin'g functions follow + the same style as Haskell\'s ordinary lists, so it is easy to convert code + from using 'String' to 'ByteString'. + . + Two 'ByteString' variants are provided: + . + * Strict 'ByteString's keep the string as a single large array. This + makes them convenient for passing data between C and Haskell. + . + * Lazy 'ByteStrings' use a lazy list of strict chunks which makes it + suitable for I\/O streaming tasks. + . + The @Char8@ modules provide a character-based view of the same + underlying 'ByteString' types. This makes it convenient to handle mixed + binary and 8-bit character content (which is common in many file formats + and network protocols). + . + 'ByteString's are not designed for Unicode. For Unicode strings you should + use the 'Text' type from the @text@ package. + . + These modules are intended to be imported qualified, to avoid name clashes + with "Prelude" functions, e.g. + . + > import qualified Data.ByteString as BS License: BSD3 License-file: LICENSE Category: Data -Copyright: Copyright (c) Don Stewart 2005-2009, - (c) Duncan Coutts 2006-2009, - (c) David Roundy 2003-2005. -Author: Don Stewart, Duncan Coutts -Maintainer: dons00@gmail.com, duncan@community.haskell.org -Homepage: http://www.cse.unsw.edu.au/~dons/fps.html -Tested-With: GHC==7.0.2, GHC==6.12.3, GHC==6.10.4, GHC ==6.8.2 +Copyright: Copyright (c) Don Stewart 2005-2009, + (c) Duncan Coutts 2006-2011, + (c) David Roundy 2003-2005, + (c) Jasper Van der Jeugt 2010, + (c) Simon Meier 2010-2011. + +Author: Don Stewart, + Duncan Coutts +Maintainer: Don Stewart , + Duncan Coutts +Bug-reports: dons00@gmail.com, + duncan@community.haskell.org +Tested-With: GHC==7.2.1, GHC==7.0.2, GHC==6.12.3, + GHC==6.10.4, GHC ==6.8.2 Build-Type: Simple Cabal-Version: >= 1.8 extra-source-files: README TODO +source-repository head + type: darcs + location: http://darcs.haskell.org/bytestring/ + library - build-depends: base >= 3 && < 5 + build-depends: base >= 3 && < 5, deepseq if impl(ghc >= 6.10) build-depends: ghc-prim, base >= 4 @@ -39,27 +70,48 @@ Data.ByteString.Lazy Data.ByteString.Lazy.Char8 Data.ByteString.Lazy.Internal - Data.ByteString.Fusion - extensions: CPP, ForeignFunctionInterface + Data.ByteString.Lazy.Builder + Data.ByteString.Lazy.Builder.Extras + Data.ByteString.Lazy.Builder.ASCII + other-modules: + -- these three modules should be exposed in a future + -- release once we're confident the API is stable. + Data.ByteString.Lazy.Builder.Internal + Data.ByteString.Lazy.Builder.BasicEncoding + Data.ByteString.Lazy.Builder.BasicEncoding.Extras + Data.ByteString.Lazy.Builder.BasicEncoding.Internal + + Data.ByteString.Lazy.Builder.BasicEncoding.Binary + Data.ByteString.Lazy.Builder.BasicEncoding.ASCII + Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Floating + Data.ByteString.Lazy.Builder.BasicEncoding.Internal.UncheckedShifts + Data.ByteString.Lazy.Builder.BasicEncoding.Internal.Base16 + + extensions: CPP, + ForeignFunctionInterface, + BangPatterns + if impl(ghc) extensions: UnliftedFFITypes, MagicHash, UnboxedTuples, DeriveDataTypeable ScopedTypeVariables + Rank2Types if impl(ghc >= 6.11) extensions: NamedFieldPuns - --TODO: eliminate orphan instances: - ghc-options: -Wall -fno-warn-orphans + ghc-options: -Wall -O2 - -funbox-strict-fields - -fmax-simplifier-iterations10 + -fmax-simplifier-iterations=10 -fdicts-cheap + if impl(ghc >= 6.10) + ghc-options: -fspec-constr-count=6 c-sources: cbits/fpstring.c + cbits/itoa.c include-dirs: include includes: fpstring.h install-includes: fpstring.h @@ -71,16 +123,18 @@ type: exitcode-stdio-1.0 main-is: Properties.hs hs-source-dirs: . tests - build-depends: base, random, directory, + build-depends: base, deepseq, random, directory, QuickCheck >= 2.3 && < 3 if impl(ghc >= 6.10) build-depends: ghc-prim c-sources: cbits/fpstring.c include-dirs: include + ghc-options: -fwarn-unused-binds if impl(ghc >= 6.10) ghc-options: -fno-enable-rewrite-rules else ghc-options: -fno-rewrite-rules + extensions: BangPatterns if impl(ghc) extensions: UnliftedFFITypes, MagicHash, @@ -89,3 +143,79 @@ ScopedTypeVariables if impl(ghc >= 6.11) extensions: NamedFieldPuns + +test-suite test-builder + type: exitcode-stdio-1.0 + hs-source-dirs: . tests tests/builder + main-is: TestSuite.hs + + build-depends: base, ghc-prim, + deepseq, + QuickCheck >= 2.4 && < 3, + byteorder == 1.0.*, + dlist == 0.5.*, + directory >= 1.0 && < 1.2, + mtl == 2.0.* + + ghc-options: -Wall -fwarn-tabs + + extensions: CPP, ForeignFunctionInterface + UnliftedFFITypes, + MagicHash, + UnboxedTuples, + DeriveDataTypeable + ScopedTypeVariables + Rank2Types + BangPatterns + NamedFieldPuns + + c-sources: cbits/fpstring.c + cbits/itoa.c + include-dirs: include + includes: fpstring.h + install-includes: fpstring.h + +benchmark bench-builder-all + type: exitcode-stdio-1.0 + hs-source-dirs: . bench + main-is: BenchAll.hs + build-depends: base, deepseq, ghc-prim, + criterion + c-sources: cbits/fpstring.c + cbits/itoa.c + include-dirs: include + ghc-options: -O2 + -fmax-simplifier-iterations=10 + -fdicts-cheap + -fspec-constr-count=6 + +benchmark bench-builder-boundscheck + type: exitcode-stdio-1.0 + hs-source-dirs: . bench + main-is: BoundsCheckFusion.hs + build-depends: base, deepseq, ghc-prim, + criterion + c-sources: cbits/fpstring.c + cbits/itoa.c + include-dirs: include + ghc-options: -O2 + -fmax-simplifier-iterations=10 + -fdicts-cheap + -fspec-constr-count=6 + +-- Sadly we cannot use benchmark bench-builder-csv currently because it +-- depends on both text and binary, which both depend on bytestring +-- which gives cabal fits about cyclic dependencies. +-- type: exitcode-stdio-1.0 +-- hs-source-dirs: . bench +-- main-is: CSV.hs +-- build-depends: base, deepseq, ghc-prim, +-- text, binary, +-- criterion +-- c-sources: cbits/fpstring.c +-- cbits/itoa.c +-- include-dirs: include +-- ghc-options: -O2 +-- -fmax-simplifier-iterations=10 +-- -fdicts-cheap +-- -fspec-constr-count=6 diff --git a/cbits/itoa.c b/cbits/itoa.c new file mode 100644 --- /dev/null +++ b/cbits/itoa.c @@ -0,0 +1,171 @@ +/////////////////////////////////////////////////////////////// +// Encoding numbers using ASCII characters // +// // +// inspired by: http://www.jb.man.ac.uk/~slowe/cpp/itoa.html // +/////////////////////////////////////////////////////////////// + +#include + +// Decimal Encoding +/////////////////// + +const char* digits = "0123456789abcdef"; + +// signed integers +char* _hs_bytestring_int_dec (int x, char* buf) +{ + char c, *ptr = buf, *next_free; + int x_tmp; + + // we cannot negate directly as 0 - (minBound :: Int) = minBound + if (x < 0) { + *ptr++ = '-'; + buf++; + x_tmp = x; + x /= 10; + *ptr++ = digits[x * 10 - x_tmp]; + if (x == 0) + return ptr; + else + x = -x; + } + + // encode positive number as little-endian decimal + do { + x_tmp = x; + x /= 10; + *ptr++ = digits[x_tmp - x * 10]; + } while ( x ); + + // reverse written digits + next_free = ptr--; + while (buf < ptr) { + c = *ptr; + *ptr-- = *buf; + *buf++ = c; + } + return next_free; +} + +// signed long long ints (64 bit integers) +char* _hs_bytestring_long_long_int_dec (long long int x, char* buf) +{ + char c, *ptr = buf, *next_free; + long long int x_tmp; + + // we cannot negate directly as 0 - (minBound :: Int) = minBound + if (x < 0) { + *ptr++ = '-'; + buf++; + x_tmp = x; + x /= 10; + *ptr++ = digits[x * 10 - x_tmp]; + if (x == 0) + return ptr; + else + x = -x; + } + + // encode positive number as little-endian decimal + do { + x_tmp = x; + x /= 10; + *ptr++ = digits[x_tmp - x * 10]; + } while ( x ); + + // reverse written digits + next_free = ptr--; + while (buf < ptr) { + c = *ptr; + *ptr-- = *buf; + *buf++ = c; + } + return next_free; +} + +// unsigned integers +char* _hs_bytestring_uint_dec (unsigned int x, char* buf) +{ + char c, *ptr = buf, *next_free; + unsigned int x_tmp; + + // encode positive number as little-endian decimal + do { + x_tmp = x; + x /= 10; + *ptr++ = digits[x_tmp - x * 10]; + } while ( x ); + + // reverse written digits + next_free = ptr--; + while (buf < ptr) { + c = *ptr; + *ptr-- = *buf; + *buf++ = c; + } + return next_free; +} + +// unsigned long ints +char* _hs_bytestring_long_long_uint_dec (long long unsigned int x, char* buf) +{ + char c, *ptr = buf, *next_free; + long long unsigned int x_tmp; + + // encode positive number as little-endian decimal + do { + x_tmp = x; + x /= 10; + *ptr++ = digits[x_tmp - x * 10]; + } while ( x ); + + // reverse written digits + next_free = ptr--; + while (buf < ptr) { + c = *ptr; + *ptr-- = *buf; + *buf++ = c; + } + return next_free; +} + + +/////////////////////// +// Hexadecimal encoding +/////////////////////// + +// unsigned ints (32 bit words) +char* _hs_bytestring_uint_hex (unsigned int x, char* buf) { + // write hex representation in reverse order + char c, *ptr = buf, *next_free; + do { + *ptr++ = digits[x & 0xf]; + x >>= 4; + } while ( x ); + // invert written digits + next_free = ptr--; + while(buf < ptr) { + c = *ptr; + *ptr-- = *buf; + *buf++ = c; + } + return next_free; +}; + +// unsigned long ints (64 bit words) +char* _hs_bytestring_long_long_uint_hex (long long unsigned int x, char* buf) { + // write hex representation in reverse order + char c, *ptr = buf, *next_free; + do { + *ptr++ = digits[x & 0xf]; + x >>= 4; + } while ( x ); + // invert written digits + next_free = ptr--; + while(buf < ptr) { + c = *ptr; + *ptr-- = *buf; + *buf++ = c; + } + return next_free; +}; diff --git a/include/fpstring.h b/include/fpstring.h --- a/include/fpstring.h +++ b/include/fpstring.h @@ -1,6 +1,21 @@ +#include + void fps_reverse(unsigned char *dest, unsigned char *from, unsigned long len); void fps_intersperse(unsigned char *dest, unsigned char *from, unsigned long len, unsigned char c); unsigned char fps_maximum(unsigned char *p, unsigned long len); unsigned char fps_minimum(unsigned char *p, unsigned long len); unsigned long fps_count(unsigned char *p, unsigned long len, unsigned char w); + +#ifndef INLINE +# if defined(_MSC_VER) +# define INLINE extern __inline +# else +# define INLINE static inline +# endif +#endif +INLINE void * +__hscore_memcpy_src_off( char *dst, char *src, int src_off, size_t sz ) +{ return memcpy(dst, src+src_off, sz); } + + diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -1,2348 +1,2467 @@ -{-# 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 -import System.IO.Unsafe -import System.Random - -import Foreign.Ptr - -import Data.ByteString.Lazy (ByteString(..), pack , unpack) -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.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 = adjustSize (min 50) $ - 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 = forAll arbitrarySizedIntegral $ - 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 = adjustSize (`div` 2) $ - 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 -prop_tailsBP = L.tails `eq1` P.tails -prop_allBP = L.all `eq2` P.all -prop_anyBP = L.any `eq2` P.any -prop_appendBP = L.append `eq2` P.append -prop_breakBP = L.break `eq2` P.break -prop_concatMapBP = adjustSize (`div` 4) $ - 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 -prop_filterBP = L.filter `eq2` P.filter -prop_findBP = L.find `eq2` P.find -prop_findIndexBP = L.findIndex `eq2` P.findIndex -prop_findIndicesBP = L.findIndices `eq2` P.findIndices -prop_isPrefixOfBP = L.isPrefixOf `eq2` P.isPrefixOf -prop_mapBP = L.map `eq2` P.map -prop_replicateBP = forAll arbitrarySizedIntegral $ - L.replicate `eq2` P.replicate -prop_snocBP = L.snoc `eq2` P.snoc -prop_spanBP = L.span `eq2` P.span -prop_splitBP = L.split `eq2` P.split -prop_splitAtBP = L.splitAt `eq2` P.splitAt -prop_takeBP = L.take `eq2` P.take -prop_takeWhileBP = L.takeWhile `eq2` P.takeWhile -prop_elemBP = L.elem `eq2` P.elem -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 - --- double check: --- Currently there's a bug in the lazy bytestring version of lines, this --- catches it: -prop_linesNLBP = eq1 D.lines C.lines x - where x = D.pack "one\ntwo\n\n\nfive\n\nseven\n" - -prop_headBP = L.head `eqnotnull1` P.head -prop_initBP = L.init `eqnotnull1` P.init -prop_lastBP = L.last `eqnotnull1` P.last -prop_maximumBP = L.maximum `eqnotnull1` P.maximum -prop_minimumBP = L.minimum `eqnotnull1` P.minimum -prop_tailBP = L.tail `eqnotnull1` P.tail -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) -prop_compareBP = eq2 - ((compare) :: B -> B -> Ordering) - ((compare) :: P -> P -> Ordering) -prop_foldlBP = eq3 - (L.foldl :: (X -> W -> X) -> X -> B -> X) - (P.foldl :: (X -> W -> X) -> X -> P -> X) -prop_foldlBP' = eq3 - (L.foldl' :: (X -> W -> X) -> X -> B -> X) - (P.foldl' :: (X -> W -> X) -> X -> P -> X) -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)) - -prop_unfoldrBP = - forAll arbitrarySizedIntegral $ - eq3 - ((\n f a -> L.take (fromIntegral n) $ - L.unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> B) - ((\n f a -> fst $ - P.unfoldrN n f a) :: Int -> (X -> Maybe (W,X)) -> X -> P) - -prop_unfoldr2BP = - forAll arbitrarySizedIntegral $ \n -> - forAll arbitrarySizedIntegral $ \a -> - 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) - n a - -prop_unfoldr2CP = - forAll arbitrarySizedIntegral $ \n -> - forAll arbitrarySizedIntegral $ \a -> - 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) - n a - - -prop_unfoldrLC = - forAll arbitrarySizedIntegral $ - 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) ==> - forAll arbitrarySizedIntegral $ - 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 = - forAll arbitrarySizedIntegral $ - 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 = - forAll arbitrarySizedIntegral $ - 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 = - forAll arbitrarySizedIntegral $ - 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 = - forAll arbitrarySizedIntegral $ - 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 = - forAll arbitrarySizedIntegral $ - 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 --- - -prop_concatBL = adjustSize (`div` 2) $ - L.concat `eq1` (concat :: [[W]] -> [W]) -prop_lengthBL = L.length `eq1` (length :: [W] -> Int) -prop_nullBL = L.null `eq1` (null :: [W] -> Bool) -prop_reverseBL = L.reverse `eq1` (reverse :: [W] -> [W]) -prop_transposeBL = L.transpose `eq1` (transpose :: [[W]] -> [[W]]) -prop_groupBL = L.group `eq1` (group :: [W] -> [[W]]) -prop_initsBL = L.inits `eq1` (inits :: [W] -> [[W]]) -prop_tailsBL = L.tails `eq1` (tails :: [W] -> [[W]]) -prop_allBL = L.all `eq2` (all :: (W -> Bool) -> [W] -> Bool) -prop_anyBL = L.any `eq2` (any :: (W -> Bool) -> [W] -> Bool) -prop_appendBL = L.append `eq2` ((++) :: [W] -> [W] -> [W]) -prop_breakBL = L.break `eq2` (break :: (W -> Bool) -> [W] -> ([W],[W])) -prop_concatMapBL = adjustSize (`div` 2) $ - L.concatMap `eq2` (concatMap :: (W -> [W]) -> [W] -> [W]) -prop_consBL = L.cons `eq2` ((:) :: W -> [W] -> [W]) -prop_dropBL = L.drop `eq2` (drop :: Int -> [W] -> [W]) -prop_dropWhileBL = L.dropWhile `eq2` (dropWhile :: (W -> Bool) -> [W] -> [W]) -prop_filterBL = L.filter `eq2` (filter :: (W -> Bool ) -> [W] -> [W]) -prop_findBL = L.find `eq2` (find :: (W -> Bool) -> [W] -> Maybe W) -prop_findIndicesBL = L.findIndices `eq2` (findIndices:: (W -> Bool) -> [W] -> [Int]) -prop_findIndexBL = L.findIndex `eq2` (findIndex :: (W -> Bool) -> [W] -> Maybe Int) -prop_isPrefixOfBL = L.isPrefixOf `eq2` (isPrefixOf:: [W] -> [W] -> Bool) -prop_mapBL = L.map `eq2` (map :: (W -> W) -> [W] -> [W]) -prop_replicateBL = forAll arbitrarySizedIntegral $ - L.replicate `eq2` (replicate :: Int -> W -> [W]) -prop_snocBL = L.snoc `eq2` ((\xs x -> xs ++ [x]) :: [W] -> W -> [W]) -prop_spanBL = L.span `eq2` (span :: (W -> Bool) -> [W] -> ([W],[W])) -prop_splitAtBL = L.splitAt `eq2` (splitAt :: Int -> [W] -> ([W],[W])) -prop_takeBL = L.take `eq2` (take :: Int -> [W] -> [W]) -prop_takeWhileBL = L.takeWhile `eq2` (takeWhile :: (W -> Bool) -> [W] -> [W]) -prop_elemBL = L.elem `eq2` (elem :: W -> [W] -> Bool) -prop_notElemBL = L.notElem `eq2` (notElem :: W -> [W] -> Bool) -prop_elemIndexBL = L.elemIndex `eq2` (elemIndex :: W -> [W] -> Maybe Int) -prop_elemIndicesBL = L.elemIndices `eq2` (elemIndices:: W -> [W] -> [Int]) -prop_linesBL = D.lines `eq1` (lines :: String -> [String]) - -prop_foldl1BL = L.foldl1 `eqnotnull2` (foldl1 :: (W -> W -> W) -> [W] -> W) -prop_foldl1BL' = L.foldl1' `eqnotnull2` (foldl1' :: (W -> W -> W) -> [W] -> W) -prop_foldr1BL = L.foldr1 `eqnotnull2` (foldr1 :: (W -> W -> W) -> [W] -> W) -prop_headBL = L.head `eqnotnull1` (head :: [W] -> W) -prop_initBL = L.init `eqnotnull1` (init :: [W] -> [W]) -prop_lastBL = L.last `eqnotnull1` (last :: [W] -> W) -prop_maximumBL = L.maximum `eqnotnull1` (maximum :: [W] -> W) -prop_minimumBL = L.minimum `eqnotnull1` (minimum :: [W] -> W) -prop_tailBL = L.tail `eqnotnull1` (tail :: [W] -> [W]) - -prop_eqBL = eq2 - ((==) :: B -> B -> Bool) - ((==) :: [W] -> [W] -> Bool) -prop_compareBL = eq2 - ((compare) :: B -> B -> Ordering) - ((compare) :: [W] -> [W] -> Ordering) -prop_foldlBL = eq3 - (L.foldl :: (X -> W -> X) -> X -> B -> X) - ( foldl :: (X -> W -> X) -> X -> [W] -> X) -prop_foldlBL' = eq3 - (L.foldl' :: (X -> W -> X) -> X -> B -> X) - ( foldl' :: (X -> W -> X) -> X -> [W] -> X) -prop_foldrBL = eq3 - (L.foldr :: (W -> X -> X) -> X -> B -> X) - ( foldr :: (W -> X -> X) -> X -> [W] -> X) -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 = - forAll arbitrarySizedIntegral $ - eq3 - ((\n f a -> L.take (fromIntegral n) $ - L.unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> B) - ((\n f a -> take n $ - unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> [W]) - --- --- And finally, check correspondance between Data.ByteString and List --- - -prop_lengthPL = (fromIntegral.P.length :: P -> Int) `eq1` (length :: [W] -> Int) -prop_nullPL = P.null `eq1` (null :: [W] -> Bool) -prop_reversePL = P.reverse `eq1` (reverse :: [W] -> [W]) -prop_transposePL = P.transpose `eq1` (transpose :: [[W]] -> [[W]]) -prop_groupPL = P.group `eq1` (group :: [W] -> [[W]]) -prop_initsPL = P.inits `eq1` (inits :: [W] -> [[W]]) -prop_tailsPL = P.tails `eq1` (tails :: [W] -> [[W]]) -prop_concatPL = adjustSize (`div` 2) $ - P.concat `eq1` (concat :: [[W]] -> [W]) -prop_allPL = P.all `eq2` (all :: (W -> Bool) -> [W] -> Bool) -prop_anyPL = P.any `eq2` (any :: (W -> Bool) -> [W] -> Bool) -prop_appendPL = P.append `eq2` ((++) :: [W] -> [W] -> [W]) -prop_breakPL = P.break `eq2` (break :: (W -> Bool) -> [W] -> ([W],[W])) -prop_concatMapPL = adjustSize (`div` 2) $ - P.concatMap `eq2` (concatMap :: (W -> [W]) -> [W] -> [W]) -prop_consPL = P.cons `eq2` ((:) :: W -> [W] -> [W]) -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 = forAll arbitrarySizedIntegral $ - P.replicate `eq2` (replicate :: Int -> W -> [W]) -prop_snocPL = P.snoc `eq2` ((\xs x -> xs ++ [x]) :: [W] -> W -> [W]) -prop_spanPL = P.span `eq2` (span :: (W -> Bool) -> [W] -> ([W],[W])) -prop_splitAtPL = P.splitAt `eq2` (splitAt :: Int -> [W] -> ([W],[W])) -prop_takePL = P.take `eq2` (take :: Int -> [W] -> [W]) -prop_takeWhilePL = P.takeWhile `eq2` (takeWhile :: (W -> Bool) -> [W] -> [W]) -prop_elemPL = P.elem `eq2` (elem :: W -> [W] -> Bool) -prop_notElemPL = P.notElem `eq2` (notElem :: W -> [W] -> Bool) -prop_elemIndexPL = P.elemIndex `eq2` (elemIndex :: W -> [W] -> Maybe Int) -prop_linesPL = C.lines `eq1` (lines :: String -> [String]) -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) -prop_foldr1PL = P.foldr1 `eqnotnull2` (foldr1 :: (W -> W -> W) -> [W] -> W) -prop_scanlPL = P.scanl `eqnotnull3` (scanl :: (W -> W -> W) -> W -> [W] -> [W]) -prop_scanl1PL = P.scanl1 `eqnotnull2` (scanl1 :: (W -> W -> W) -> [W] -> [W]) -prop_scanrPL = P.scanr `eqnotnull3` (scanr :: (W -> W -> W) -> W -> [W] -> [W]) -prop_scanr1PL = P.scanr1 `eqnotnull2` (scanr1 :: (W -> W -> W) -> [W] -> [W]) -prop_headPL = P.head `eqnotnull1` (head :: [W] -> W) -prop_initPL = P.init `eqnotnull1` (init :: [W] -> [W]) -prop_lastPL = P.last `eqnotnull1` (last :: [W] -> W) -prop_maximumPL = P.maximum `eqnotnull1` (maximum :: [W] -> W) -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) -prop_comparePL = eq2 - ((compare) :: P -> P -> Ordering) - ((compare) :: [W] -> [W] -> Ordering) -prop_foldlPL = eq3 - (P.foldl :: (X -> W -> X) -> X -> P -> X) - ( foldl :: (X -> W -> X) -> X -> [W] -> X) -prop_foldlPL' = eq3 - (P.foldl' :: (X -> W -> X) -> X -> P -> X) - ( foldl' :: (X -> W -> X) -> X -> [W] -> X) -prop_foldrPL = eq3 - (P.foldr :: (W -> X -> X) -> X -> P -> X) - ( foldr :: (W -> X -> X) -> X -> [W] -> X) -prop_mapAccumLPL= eq3 - (P.mapAccumL :: (X -> W -> (X,W)) -> X -> P -> (X, P)) - ( mapAccumL :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) -prop_mapAccumRPL= eq3 - (P.mapAccumR :: (X -> W -> (X,W)) -> X -> P -> (X, P)) - ( mapAccumR :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) -prop_unfoldrPL = - forAll arbitrarySizedIntegral $ - eq3 - ((\n f a -> fst $ - P.unfoldrN n f a) :: Int -> (X -> Maybe (W,X)) -> X -> P) - ((\n f a -> take n $ - unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> [W]) - ------------------------------------------------------------------------- --- --- These are miscellaneous tests left over. Or else they test some --- property internal to a type (i.e. head . sort == minimum), without --- reference to a model type. --- - -invariant :: L.ByteString -> Bool -invariant Empty = True -invariant (Chunk c cs) = not (P.null c) && invariant cs - -prop_invariant = invariant - -prop_eq_refl x = x == (x :: ByteString) -prop_eq_symm x y = (x == y) == (y == (x :: ByteString)) - -prop_eq1 xs = xs == (unpack . pack $ xs) -prop_eq2 xs = xs == (xs :: ByteString) -prop_eq3 xs ys = (xs == ys) == (unpack xs == unpack ys) - -prop_compare1 xs = (pack xs `compare` pack xs) == EQ -prop_compare2 xs c = (pack (xs++[c]) `compare` pack xs) == GT -prop_compare3 xs c = (pack xs `compare` pack (xs++[c])) == LT - -prop_compare4 xs = (not (null xs)) ==> (pack xs `compare` L.empty) == GT -prop_compare5 xs = (not (null xs)) ==> (L.empty `compare` pack xs) == LT -prop_compare6 xs ys = (not (null ys)) ==> (pack (xs++ys) `compare` pack xs) == GT - -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 == [] - -prop_packunpack s = (L.unpack . L.pack) s == id s -prop_unpackpack s = (L.pack . L.unpack) s == id s - -prop_null xs = null (L.unpack xs) == L.null xs - -prop_length1 xs = fromIntegral (length xs) == L.length (L.pack xs) - -prop_length2 xs = L.length xs == length1 xs - where length1 ys - | L.null ys = 0 - | otherwise = 1 + length1 (L.tail ys) - -prop_cons1 c xs = unpack (L.cons c (pack xs)) == (c:xs) -prop_cons2 c = L.singleton c == (c `L.cons` L.empty) -prop_cons3 c = unpack (L.singleton c) == (c:[]) -prop_cons4 c = (c `L.cons` L.empty) == pack (c:[]) - -prop_snoc1 xs c = xs ++ [c] == unpack ((pack xs) `L.snoc` c) - -prop_head xs = (not (null xs)) ==> head xs == (L.head . pack) xs -prop_head1 xs = not (L.null xs) ==> L.head xs == head (L.unpack xs) - -prop_tail xs = not (L.null xs) ==> L.tail xs == pack (tail (unpack xs)) -prop_tail1 xs = (not (null xs)) ==> tail xs == (unpack . L.tail . pack) xs - -prop_last xs = (not (null xs)) ==> last xs == (L.last . pack) xs - -prop_init xs = - (not (null xs)) ==> - init xs == (unpack . L.init . pack) xs - -prop_append1 xs = (xs ++ xs) == (unpack $ pack xs `L.append` pack xs) -prop_append2 xs ys = (xs ++ ys) == (unpack $ pack xs `L.append` pack ys) -prop_append3 xs ys = L.append xs ys == pack (unpack xs ++ unpack ys) - -prop_map1 f xs = L.map f (pack xs) == pack (map f xs) -prop_map2 f g xs = L.map f (L.map g xs) == L.map (f . g) xs -prop_map3 f xs = map f xs == (unpack . L.map f . pack) xs - -prop_filter1 c xs = (filter (/=c) xs) == (unpack $ L.filter (/=c) (pack xs)) -prop_filter2 p xs = (filter p xs) == (unpack $ L.filter p (pack xs)) - -prop_reverse xs = reverse xs == (unpack . L.reverse . pack) xs -prop_reverse1 xs = L.reverse (pack xs) == pack (reverse xs) -prop_reverse2 xs = reverse (unpack xs) == (unpack . L.reverse) xs - -prop_transpose xs = (transpose xs) == ((map unpack) . L.transpose . (map pack)) xs - -prop_foldl f c xs = L.foldl f c (pack xs) == foldl f c xs - where _ = c :: Char - -prop_foldr f c xs = L.foldl f c (pack xs) == foldl f c xs - where _ = c :: Char - -prop_foldl_1 xs = L.foldl (\xs c -> c `L.cons` xs) L.empty xs == L.reverse xs -prop_foldr_1 xs = L.foldr (\c xs -> c `L.cons` xs) L.empty xs == id xs - -prop_foldl1_1 xs = - (not . L.null) xs ==> - L.foldl1 (\x c -> if c > x then c else x) xs == - L.foldl (\x c -> if c > x then c else x) 0 xs - -prop_foldl1_2 xs = - (not . L.null) xs ==> - L.foldl1 const xs == L.head xs - -prop_foldl1_3 xs = - (not . L.null) xs ==> - L.foldl1 (flip const) xs == L.last xs - -prop_foldr1_1 xs = - (not . L.null) xs ==> - L.foldr1 (\c x -> if c > x then c else x) xs == - L.foldr (\c x -> if c > x then c else x) 0 xs - -prop_foldr1_2 xs = - (not . L.null) xs ==> - L.foldr1 (flip const) xs == L.last xs - -prop_foldr1_3 xs = - (not . L.null) xs ==> - L.foldr1 const xs == L.head xs - -prop_concat1 xs = (concat [xs,xs]) == (unpack $ L.concat [pack xs, pack xs]) -prop_concat2 xs = (concat [xs,[]]) == (unpack $ L.concat [pack xs, pack []]) -prop_concat3 xss = adjustSize (`div` 2) $ - L.concat (map pack xss) == pack (concat xss) - -prop_concatMap xs = L.concatMap L.singleton xs == (pack . concatMap (:[]) . unpack) xs - -prop_any xs a = (any (== a) xs) == (L.any (== a) (pack xs)) -prop_all xs a = (all (== a) xs) == (L.all (== a) (pack xs)) - -prop_maximum xs = (not (null xs)) ==> (maximum xs) == (L.maximum ( pack xs )) -prop_minimum xs = (not (null xs)) ==> (minimum xs) == (L.minimum ( pack xs )) - -prop_replicate1 c = - forAll arbitrarySizedIntegral $ \(Positive n) -> - unpack (L.replicate (fromIntegral n) c) == replicate n c - -prop_replicate2 c = unpack (L.replicate 0 c) == replicate 0 c - -prop_take1 i xs = L.take (fromIntegral i) (pack xs) == pack (take i xs) -prop_drop1 i xs = L.drop (fromIntegral i) (pack xs) == pack (drop i xs) - -prop_splitAt i xs = --collect (i >= 0 && i < length xs) $ - L.splitAt (fromIntegral i) (pack xs) == let (a,b) = splitAt i xs in (pack a, pack b) - -prop_takeWhile f xs = L.takeWhile f (pack xs) == pack (takeWhile f xs) -prop_dropWhile f xs = L.dropWhile f (pack xs) == pack (dropWhile f xs) - -prop_break f xs = L.break f (pack xs) == - let (a,b) = break f xs in (pack a, pack b) - -prop_breakspan xs c = L.break (==c) xs == L.span (/=c) xs - -prop_span xs a = (span (/=a) xs) == (let (x,y) = L.span (/=a) (pack xs) in (unpack x, unpack y)) - --- prop_breakByte xs c = L.break (== c) xs == L.breakByte c xs - --- prop_spanByte c xs = (L.span (==c) xs) == L.spanByte c xs - -prop_split c xs = (map L.unpack . map checkInvariant . L.split c $ xs) - == (map P.unpack . P.split c . P.pack . L.unpack $ xs) - -prop_splitWith f xs = (l1 == l2 || l1 == l2+1) && - sum (map L.length splits) == L.length xs - l2 - where splits = L.splitWith f xs - 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] - -prop_index xs = - not (null xs) ==> - 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)) - -prop_count c xs = length (L.elemIndices c xs) == fromIntegral (L.count c xs) - -prop_findIndex xs f = (findIndex f xs) == fmap fromIntegral (L.findIndex f (pack xs)) -prop_findIndicies xs f = (findIndices f xs) == map fromIntegral (L.findIndices f (pack xs)) - -prop_elem xs c = (c `elem` xs) == (c `L.elem` (pack xs)) -prop_notElem xs c = (c `notElem` xs) == (L.notElem c (pack xs)) -prop_elem_notelem xs c = c `L.elem` xs == not (c `L.notElem` xs) - --- prop_filterByte xs c = L.filterByte c xs == L.filter (==c) xs --- prop_filterByte2 xs c = unpack (L.filterByte c xs) == filter (==c) (unpack xs) - --- prop_filterNotByte xs c = L.filterNotByte c xs == L.filter (/=c) xs --- prop_filterNotByte2 xs c = unpack (L.filterNotByte c xs) == filter (/=c) (unpack xs) - -prop_find p xs = find p xs == L.find p (pack xs) - -prop_find_findIndex p xs = - L.find p xs == case L.findIndex p xs of - Just n -> Just (xs `L.index` n) - _ -> Nothing - -prop_isPrefixOf xs ys = isPrefixOf xs ys == (pack xs `L.isPrefixOf` pack ys) - -{- -prop_sort1 xs = sort xs == (unpack . L.sort . pack) xs -prop_sort2 xs = (not (null xs)) ==> (L.head . L.sort . pack $ xs) == minimum xs -prop_sort3 xs = (not (null xs)) ==> (L.last . L.sort . pack $ xs) == maximum xs -prop_sort4 xs ys = - (not (null xs)) ==> - (not (null ys)) ==> - (L.head . L.sort) (L.append (pack xs) (pack ys)) == min (minimum xs) (minimum ys) - -prop_sort5 xs ys = - (not (null xs)) ==> - (not (null ys)) ==> - (L.last . L.sort) (L.append (pack xs) (pack ys)) == max (maximum xs) (maximum ys) - --} - ------------------------------------------------------------------------- --- Misc ByteString properties - -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 - -prop_lengthBB xs = P.length xs == length1 xs - where - length1 ys - | P.null ys = 0 - | otherwise = 1 + length1 (P.tail ys) - -prop_lengthSBB xs = length xs == P.length (P.pack xs) - -prop_indexBB xs = - not (null xs) ==> - forAll indices $ \i -> (xs !! i) == P.pack xs `P.index` i - where indices = choose (0, length xs -1) - -prop_unsafeIndexBB xs = - not (null xs) ==> - forAll indices $ \i -> (xs !! i) == P.pack xs `P.unsafeIndex` i - where indices = choose (0, length xs -1) - -prop_mapfusionBB f g xs = P.map f (P.map g xs) == P.map (f . g) xs - -prop_filterBB f xs = P.filter f (P.pack xs) == P.pack (filter f xs) - -prop_filterfusionBB f g xs = P.filter f (P.filter g xs) == P.filter (\c -> f c && g c) xs - -prop_elemSBB x xs = P.elem x (P.pack xs) == elem x xs - -prop_takeSBB i xs = P.take i (P.pack xs) == P.pack (take i xs) -prop_dropSBB i xs = P.drop i (P.pack xs) == P.pack (drop i xs) - -prop_splitAtSBB i xs = -- collect (i >= 0 && i < length xs) $ - P.splitAt i (P.pack xs) == - let (a,b) = splitAt i xs in (P.pack a, P.pack b) - -prop_foldlBB f c xs = P.foldl f c (P.pack xs) == foldl f c xs - where types = c :: Char - -prop_scanlfoldlBB f z xs = not (P.null xs) ==> P.last (P.scanl f z xs) == P.foldl f z xs - -prop_foldrBB f c xs = P.foldl f c (P.pack xs) == foldl f c xs - where types = c :: Char - -prop_takeWhileSBB f xs = P.takeWhile f (P.pack xs) == P.pack (takeWhile f xs) -prop_dropWhileSBB f xs = P.dropWhile f (P.pack xs) == P.pack (dropWhile f xs) - -prop_spanSBB f xs = P.span f (P.pack xs) == - let (a,b) = span f xs in (P.pack a, P.pack b) - -prop_breakSBB f xs = P.break f (P.pack xs) == - let (a,b) = break f xs in (P.pack a, P.pack b) - -prop_breakspan_1BB xs c = P.break (== c) xs == P.span (/= c) xs - -prop_linesSBB xs = C.lines (C.pack xs) == map C.pack (lines xs) - -prop_unlinesSBB xss = C.unlines (map C.pack xss) == C.pack (unlines xss) - -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 - where splits = P.splitWith f xs - l1 = length splits - l2 = P.length (P.filter f xs) - -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 - -prop_bijectionBB c = (P.w2c . P.c2w) c == id c -prop_bijectionBB' w = (P.c2w . P.w2c) w == id w - -prop_packunpackBB s = (P.unpack . P.pack) s == id s -prop_packunpackBB' s = (P.pack . P.unpack) s == id s - -prop_eq1BB xs = xs == (P.unpack . P.pack $ 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 -prop_compare2BB xs c = (P.pack (xs++[c]) `compare` P.pack xs) == GT -prop_compare3BB xs c = (P.pack xs `compare` P.pack (xs++[c])) == LT - -prop_compare4BB xs = (not (null xs)) ==> (P.pack xs `compare` P.empty) == GT -prop_compare5BB xs = (not (null xs)) ==> (P.empty `compare` P.pack xs) == LT -prop_compare6BB xs ys= (not (null ys)) ==> (P.pack (xs++ys) `compare` P.pack xs) == GT - -prop_compare7BB x y = x `compare` y == (C.singleton x `compare` C.singleton y) -prop_compare8BB xs ys = xs `compare` ys == (P.pack xs `compare` P.pack ys) - -prop_consBB c xs = P.unpack (P.cons c (P.pack xs)) == (c:xs) -prop_cons1BB xs = 'X' : xs == C.unpack ('X' `C.cons` (C.pack xs)) -prop_cons2BB xs c = c : xs == P.unpack (c `P.cons` (P.pack xs)) -prop_cons3BB c = C.unpack (C.singleton c) == (c:[]) -prop_cons4BB c = (c `P.cons` P.empty) == P.pack (c:[]) - -prop_snoc1BB xs c = xs ++ [c] == P.unpack ((P.pack xs) `P.snoc` c) - -prop_head1BB xs = (not (null xs)) ==> head xs == (P.head . P.pack) xs -prop_head2BB xs = (not (null xs)) ==> head xs == (P.unsafeHead . P.pack) xs -prop_head3BB xs = not (P.null xs) ==> P.head xs == head (P.unpack xs) - -prop_tailBB xs = (not (null xs)) ==> tail xs == (P.unpack . P.tail . P.pack) xs -prop_tail1BB xs = (not (null xs)) ==> tail xs == (P.unpack . P.unsafeTail. P.pack) xs - -prop_lastBB xs = (not (null xs)) ==> last xs == (P.last . P.pack) xs - -prop_initBB xs = - (not (null xs)) ==> - init xs == (P.unpack . P.init . P.pack) xs - --- prop_null xs = (null xs) ==> null xs == (nullPS (pack xs)) - -prop_append1BB xs = (xs ++ xs) == (P.unpack $ P.pack xs `P.append` P.pack xs) -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 --- prop_mapBB' f xs = P.map' f (P.pack xs) == P.pack (map f xs) - -prop_filter1BB xs = (filter (=='X') xs) == (C.unpack $ C.filter (=='X') (C.pack xs)) -prop_filter2BB p xs = (filter p xs) == (P.unpack $ P.filter p (P.pack xs)) - -prop_findBB p xs = find p xs == P.find p (P.pack xs) - -prop_find_findIndexBB p xs = - P.find p xs == case P.findIndex p xs of - Just n -> Just (xs `P.unsafeIndex` n) - _ -> Nothing - -prop_foldl1BB xs a = ((foldl (\x c -> if c == a then x else c:x) [] xs)) == - (P.unpack $ P.foldl (\x c -> if c == a then x else c `P.cons` x) P.empty (P.pack xs)) -prop_foldl2BB xs = P.foldl (\xs c -> c `P.cons` xs) P.empty (P.pack xs) == P.reverse (P.pack xs) - -prop_foldr1BB xs a = ((foldr (\c x -> if c == a then x else c:x) [] xs)) == - (P.unpack $ P.foldr (\c x -> if c == a then x else c `P.cons` x) - P.empty (P.pack xs)) - -prop_foldr2BB xs = P.foldr (\c xs -> c `P.cons` xs) P.empty (P.pack xs) == (P.pack xs) - -prop_foldl1_1BB xs = - (not . P.null) xs ==> - P.foldl1 (\x c -> if c > x then c else x) xs == - P.foldl (\x c -> if c > x then c else x) 0 xs - -prop_foldl1_2BB xs = - (not . P.null) xs ==> - P.foldl1 const xs == P.head xs - -prop_foldl1_3BB xs = - (not . P.null) xs ==> - P.foldl1 (flip const) xs == P.last xs - -prop_foldr1_1BB xs = - (not . P.null) xs ==> - P.foldr1 (\c x -> if c > x then c else x) xs == - P.foldr (\c x -> if c > x then c else x) 0 xs - -prop_foldr1_2BB xs = - (not . P.null) xs ==> - P.foldr1 (flip const) xs == P.last xs - -prop_foldr1_3BB xs = - (not . P.null) xs ==> - P.foldr1 const xs == P.head xs - -prop_takeWhileBB xs a = (takeWhile (/= a) xs) == (P.unpack . (P.takeWhile (/= a)) . P.pack) xs - -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 - -prop_splitAtBB i xs = -- collect (i >= 0 && i < length xs) $ - splitAt i xs == - let (x,y) = P.splitAt i (P.pack xs) in (P.unpack x, P.unpack y) - -prop_spanBB xs a = (span (/=a) xs) == (let (x,y) = P.span (/=a) (P.pack xs) - in (P.unpack x, P.unpack y)) - -prop_breakBB xs a = (break (/=a) xs) == (let (x,y) = P.break (/=a) (P.pack xs) - in (P.unpack x, P.unpack y)) - -prop_reverse1BB xs = (reverse xs) == (P.unpack . P.reverse . P.pack) xs -prop_reverse2BB xs = P.reverse (P.pack xs) == P.pack (reverse xs) -prop_reverse3BB xs = reverse (P.unpack xs) == (P.unpack . P.reverse) xs - -prop_elemBB xs a = (a `elem` xs) == (a `P.elem` (P.pack xs)) - -prop_notElemBB c xs = P.notElem c (P.pack xs) == notElem c xs - --- should try to stress it -prop_concat1BB xs = (concat [xs,xs]) == (P.unpack $ P.concat [P.pack xs, P.pack xs]) -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)) -prop_allBB xs a = (all (== a) xs) == (P.all (== a) (P.pack xs)) - -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 --- prop_wordstokensBB xs = C.words xs == C.tokens isSpace xs - -prop_unwordsBB xs = - (C.pack.unwords.words) xs == (C.unwords . C.words .C.pack) xs - -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))) - -prop_elemIndex1BB xs = (elemIndex 'X' xs) == (C.elemIndex 'X' (C.pack xs)) -prop_elemIndex2BB xs c = (elemIndex c xs) == (C.elemIndex c (C.pack xs)) - --- prop_lineIndices1BB xs = C.elemIndices '\n' xs == C.lineIndices xs - -prop_countBB c xs = length (P.elemIndices c xs) == P.count c xs - -prop_elemIndexEnd1BB c xs = (P.elemIndexEnd c (P.pack xs)) == - (case P.elemIndex c (P.pack (reverse xs)) of - 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)) - -prop_elemIndicesBB xs c = elemIndices c xs == P.elemIndices c (P.pack xs) - -prop_findIndexBB xs a = (findIndex (==a) xs) == (P.findIndex (==a) (P.pack xs)) - -prop_findIndiciesBB xs c = (findIndices (==c) xs) == (P.findIndices (==c) (P.pack xs)) - --- example properties from QuickCheck.Batch -prop_sort1BB xs = sort xs == (P.unpack . P.sort . P.pack) xs -prop_sort2BB xs = (not (null xs)) ==> (P.head . P.sort . P.pack $ xs) == minimum xs -prop_sort3BB xs = (not (null xs)) ==> (P.last . P.sort . P.pack $ xs) == maximum xs -prop_sort4BB xs ys = - (not (null xs)) ==> - (not (null ys)) ==> - (P.head . P.sort) (P.append (P.pack xs) (P.pack ys)) == min (minimum xs) (minimum ys) -prop_sort5BB xs ys = - (not (null xs)) ==> - (not (null ys)) ==> - (P.last . P.sort) (P.append (P.pack xs) (P.pack ys)) == max (maximum xs) (maximum ys) - -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_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 )) - --- prop_dropSpaceBB xs = dropWhile isSpace xs == C.unpack (C.dropSpace (C.pack xs)) --- prop_dropSpaceEndBB xs = (C.reverse . (C.dropWhile isSpace) . C.reverse) (C.pack xs) == --- (C.dropSpaceEnd (C.pack xs)) - --- prop_breakSpaceBB xs = --- (let (x,y) = C.breakSpace (C.pack xs) --- in (C.unpack x, C.unpack y)) == (break isSpace xs) - -prop_spanEndBB xs = - (C.spanEnd (not . isSpace) (C.pack xs)) == - (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 = - (break (==c) xs) == - (let (x,y) = C.breakChar c (C.pack xs) in (C.unpack x, C.unpack y)) - -prop_spanCharBB c xs = - (break (/=c) xs) == - (let (x,y) = C.spanChar c (C.pack xs) in (C.unpack x, C.unpack y)) - -prop_spanChar_1BB c xs = - (C.span (==c) xs) == C.spanChar c xs - -prop_wordsBB' xs = - (C.unpack . C.unwords . C.words' . C.pack) xs == - (map (\c -> if isSpace c then ' ' else c) xs) - --- prop_linesBB' xs = (C.unpack . C.unlines' . C.lines' . C.pack) xs == (xs) --} - -prop_unfoldrBB c = - forAll arbitrarySizedIntegral $ \n -> - (fst $ C.unfoldrN n fn c) == (C.pack $ take n $ unfoldr fn c) - where - fn x = Just (x, chr (ord x + 1)) - -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)) - -prop_tailsBB xs = tails xs == map P.unpack (P.tails (P.pack xs)) - -prop_findSubstringsBB s x l - = C.findSubstrings (C.pack p) (C.pack s) == naive_findSubstrings 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_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 c = forAll arbitrarySizedIntegral $ \n -> - P.unpack (P.replicate n c) == replicate n c -prop_replicate2BB c = forAll arbitrarySizedIntegral $ \n -> - P.replicate n c == fst (P.unfoldrN n (\u -> Just (u,u)) c) - -prop_replicate3BB c = P.unpack (P.replicate 0 c) == replicate 0 c - -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 - -prop_readintegerBB n = (fst . fromJust . C.readInteger . C.pack . show) n == (n :: Integer) -prop_readintegerLL n = (fst . fromJust . D.readInteger . D.pack . show) n == (n :: Integer) - -prop_readinteger2BB s = - let s' = filter (\c -> c `notElem` ['0'..'9']) s - in C.readInteger (C.pack s') == Nothing - --- prop_filterChar1BB c xs = (filter (==c) xs) == ((C.unpack . C.filterChar c . C.pack) xs) --- prop_filterChar2BB c xs = (C.filter (==c) (C.pack xs)) == (C.filterChar c (C.pack xs)) --- prop_filterChar3BB c xs = C.filterChar c xs == C.replicate (C.count c xs) c - --- prop_filterNotChar1BB c xs = (filter (/=c) xs) == ((C.unpack . C.filterNotChar c . C.pack) xs) --- prop_filterNotChar2BB c xs = (C.filter (/=c) (C.pack xs)) == (C.filterNotChar c (C.pack xs)) - --- 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 - ------------------------------------------------------------------------- --- --- 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) - where - _ = start1 :: Int - _ = start2 :: Int - -prop_looploop em1 em2 start1 start2 arr = - loopU em2 start2 (loopArr (loopU em1 start1 arr)) == - loopSndAcc (loopU (em1 `fuseEFL` em2) (start1 :*: start2) arr) - where - _ = start1 :: Int - _ = start2 :: Int - ------------------------------------------------------------------------- - --- check associativity of sequence loops -prop_sequenceloops_assoc n m o x y z a1 a2 a3 xs = - - k ((f * g) * h) == k (f * (g * h)) -- associativity - - where - (*) = sequenceLoops - f = (sel n) x a1 - g = (sel m) y a2 - h = (sel o) z a3 - - _ = a1 :: Int; _ = a2 :: Int; _ = a3 :: Int - k g = loopArr (loopWrapper g xs) - --- check wrapper elimination -prop_loop_loop_wrapper_elimination n m x y a1 a2 xs = - loopWrapper g (loopArr (loopWrapper f xs)) == - loopSndAcc (loopWrapper (sequenceLoops f g) xs) - where - f = (sel n) x a1 - g = (sel m) y a2 - _ = a1 :: Int; _ = a2 :: Int - -sel :: Bool - -> (acc -> Word8 -> PairS acc (MaybeS Word8)) - -> acc - -> Ptr Word8 - -> Ptr Word8 - -> Int - -> IO (PairS (PairS acc Int) Int) -sel False = doDownLoop -sel True = doUpLoop - ------------------------------------------------------------------------- --- --- Test fusion forms --- - -prop_up_up_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doUpLoop f1 acc1) (doUpLoop f2 acc2)) == - k (doUpLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int; k g = loopWrapper g xs - -prop_down_down_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doDownLoop f1 acc1) (doDownLoop f2 acc2)) == - k (doDownLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int ; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_noAcc_noAcc_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doNoAccLoop f1 acc1) (doNoAccLoop f2 acc2)) == - k (doNoAccLoop (f1 `fuseNoAccNoAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int ; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_noAcc_up_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doNoAccLoop f1 acc1) (doUpLoop f2 acc2)) == - k (doUpLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int; k g = loopWrapper g xs - -prop_up_noAcc_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doUpLoop f1 acc1) (doNoAccLoop f2 acc2)) == - k (doUpLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int; k g = loopWrapper g xs - -prop_noAcc_down_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doNoAccLoop f1 acc1) (doDownLoop f2 acc2)) == - k (doDownLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_down_noAcc_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doDownLoop f1 acc1) (doNoAccLoop f2 acc2)) == - k (doDownLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int; k g = loopWrapper g xs - -prop_map_map_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doMapLoop f1 acc1) (doMapLoop f2 acc2)) == - k (doMapLoop (f1 `fuseMapMapEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_filter_filter_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doFilterLoop f1 acc1) (doFilterLoop f2 acc2)) == - k (doFilterLoop (f1 `fuseFilterFilterEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_map_filter_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doMapLoop f1 acc1) (doFilterLoop f2 acc2)) == - k (doNoAccLoop (f1 `fuseMapFilterEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_filter_map_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doFilterLoop f1 acc1) (doMapLoop f2 acc2)) == - k (doNoAccLoop (f1 `fuseFilterMapEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_map_noAcc_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doMapLoop f1 acc1) (doNoAccLoop f2 acc2)) == - k (doNoAccLoop (f1 `fuseMapNoAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_noAcc_map_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doNoAccLoop f1 acc1) (doMapLoop f2 acc2)) == - k (doNoAccLoop (f1 `fuseNoAccMapEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_map_up_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doMapLoop f1 acc1) (doUpLoop f2 acc2)) == - k (doUpLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_up_map_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doUpLoop f1 acc1) (doMapLoop f2 acc2)) == - k (doUpLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_map_down_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doMapLoop f1 acc1) (doDownLoop f2 acc2)) == - k (doDownLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_down_map_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doDownLoop f1 acc1) (doMapLoop f2 acc2)) == - k (doDownLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_filter_noAcc_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doFilterLoop f1 acc1) (doNoAccLoop f2 acc2)) == - k (doNoAccLoop (f1 `fuseFilterNoAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_noAcc_filter_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doNoAccLoop f1 acc1) (doFilterLoop f2 acc2)) == - k (doNoAccLoop (f1 `fuseNoAccFilterEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_filter_up_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doFilterLoop f1 acc1) (doUpLoop f2 acc2)) == - k (doUpLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_up_filter_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doUpLoop f1 acc1) (doFilterLoop f2 acc2)) == - k (doUpLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_filter_down_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doFilterLoop f1 acc1) (doDownLoop f2 acc2)) == - k (doDownLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - -prop_down_filter_loop_fusion f1 f2 acc1 acc2 xs = - k (sequenceLoops (doDownLoop f1 acc1) (doFilterLoop f2 acc2)) == - k (doDownLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2)) - where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs - ------------------------------------------------------------------------- - -{- -prop_length_loop_fusion_1 f1 acc1 xs = - P.length (loopArr (loopWrapper (doUpLoop f1 acc1) xs)) == - P.lengthU (loopArr (loopWrapper (doUpLoop f1 acc1) xs)) - where _ = acc1 :: Int - -prop_length_loop_fusion_2 f1 acc1 xs = - P.length (loopArr (loopWrapper (doDownLoop f1 acc1) xs)) == - P.lengthU (loopArr (loopWrapper (doDownLoop f1 acc1) xs)) - where _ = acc1 :: Int - -prop_length_loop_fusion_3 f1 acc1 xs = - P.length (loopArr (loopWrapper (doMapLoop f1 acc1) xs)) == - P.lengthU (loopArr (loopWrapper (doMapLoop f1 acc1) xs)) - where _ = acc1 :: Int - -prop_length_loop_fusion_4 f1 acc1 xs = - P.length (loopArr (loopWrapper (doFilterLoop f1 acc1) xs)) == - P.lengthU (loopArr (loopWrapper (doFilterLoop f1 acc1) xs)) - 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 - --- prop_join_spec c s1 s2 = --- P.join (P.singleton c) (s1 : s2 : []) == P.joinWithByte c s1 s2 - --- prop_break_spec x s = --- P.break ((==) x) s == P.breakByte x s - --- 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 (CByteString 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 (CByteString x) = unsafePerformIO $ do - y <- P.useAsCString x $ P.unsafePackCString - return (y == x) - -prop_packCString_safe (CByteString 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 (CByteString 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 (Bool,Int))] -> IO () -run tests = do - x <- getArgs - let n = if null x then 100 else read . head $ x - (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. --- - -tests = misc_tests - ++ bl_tests - ++ cc_tests - ++ bp_tests - ++ pl_tests - ++ bb_tests - ++ ll_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) - ,("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 - -bl_tests = - [("all", mytest prop_allBL) - ,("any", mytest prop_anyBL) - ,("append", mytest prop_appendBL) - ,("compare", mytest prop_compareBL) - ,("concat", mytest prop_concatBL) - ,("cons", mytest prop_consBL) - ,("eq", mytest prop_eqBL) - ,("filter", mytest prop_filterBL) - ,("find", mytest prop_findBL) - ,("findIndex", mytest prop_findIndexBL) - ,("findIndices", mytest prop_findIndicesBL) - ,("foldl", mytest prop_foldlBL) - ,("foldl'", mytest prop_foldlBL') - ,("foldl1", mytest prop_foldl1BL) - ,("foldl1'", mytest prop_foldl1BL') - ,("foldr", mytest prop_foldrBL) - ,("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) - ,("last", mytest prop_lastBL) - ,("length", mytest prop_lengthBL) - ,("map", mytest prop_mapBL) - ,("maximum", mytest prop_maximumBL) - ,("minimum", mytest prop_minimumBL) - ,("null", mytest prop_nullBL) - ,("reverse", mytest prop_reverseBL) - ,("snoc", mytest prop_snocBL) - ,("tail", mytest prop_tailBL) - ,("transpose", mytest prop_transposeBL) - ,("replicate", mytest prop_replicateBL) - ,("take", mytest prop_takeBL) - ,("drop", mytest prop_dropBL) - ,("splitAt", mytest prop_splitAtBL) - ,("takeWhile", mytest prop_takeWhileBL) - ,("dropWhile", mytest prop_dropWhileBL) - ,("break", mytest prop_breakBL) - ,("span", mytest prop_spanBL) - ,("group", mytest prop_groupBL) - ,("inits", mytest prop_initsBL) - ,("tails", mytest prop_tailsBL) - ,("elem", mytest prop_elemBL) - ,("notElem", mytest prop_notElemBL) - ,("lines", mytest prop_linesBL) - ,("elemIndex", mytest prop_elemIndexBL) - ,("elemIndices", mytest prop_elemIndicesBL) - ,("concatMap", mytest prop_concatMapBL) - ] - ------------------------------------------------------------------------- --- 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) - ,("append", mytest prop_appendBP) - ,("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) - ,("findIndex", mytest prop_findIndexBP) - ,("findIndices", mytest prop_findIndicesBP) - ,("foldl", mytest prop_foldlBP) - ,("foldl'", mytest prop_foldlBP') - ,("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) - ,("last", mytest prop_lastBP) - ,("length", mytest prop_lengthBP) - ,("readInt", mytest prop_readIntBP) - ,("lines", mytest prop_linesBP) - ,("lines \\n", mytest prop_linesNLBP) - ,("map", mytest prop_mapBP) - ,("maximum ", mytest prop_maximumBP) - ,("minimum" , mytest prop_minimumBP) - ,("null", mytest prop_nullBP) - ,("reverse", mytest prop_reverseBP) - ,("snoc", mytest prop_snocBP) - ,("tail", mytest prop_tailBP) - ,("scanl", mytest prop_scanlBP) - ,("transpose", mytest prop_transposeBP) - ,("replicate", mytest prop_replicateBP) - ,("take", mytest prop_takeBP) - ,("drop", mytest prop_dropBP) - ,("splitAt", mytest prop_splitAtBP) - ,("takeWhile", mytest prop_takeWhileBP) - ,("dropWhile", mytest prop_dropWhileBP) - ,("break", mytest prop_breakBP) - ,("span", mytest prop_spanBP) - ,("split", mytest prop_splitBP) - ,("count", mytest prop_countBP) - ,("group", mytest prop_groupBP) - ,("inits", mytest prop_initsBP) - ,("tails", mytest prop_tailsBP) - ,("elem", mytest prop_elemBP) - ,("notElem", mytest prop_notElemBP) - ,("elemIndex", mytest prop_elemIndexBP) - ,("elemIndices", mytest prop_elemIndicesBP) - ,("intersperse", mytest prop_intersperseBP) - ,("concatMap", mytest prop_concatMapBP) - ] - ------------------------------------------------------------------------- --- ByteString <=> List - -pl_tests = - [("all", mytest prop_allPL) - ,("any", mytest prop_anyPL) - ,("append", mytest prop_appendPL) - ,("compare", mytest prop_comparePL) - ,("concat", mytest prop_concatPL) - ,("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) - ,("foldl", mytest prop_foldlPL) - ,("foldl'", mytest prop_foldlPL') - ,("foldl1", mytest prop_foldl1PL) - ,("foldl1'", mytest prop_foldl1PL') - ,("foldr1", mytest prop_foldr1PL) - ,("foldr", mytest prop_foldrPL) - ,("mapAccumL", mytest prop_mapAccumLPL) - ,("mapAccumR", mytest prop_mapAccumRPL) - ,("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) - ,("maximum", mytest prop_maximumPL) - ,("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) - ,("reverse", mytest prop_reversePL) - ,("snoc", mytest prop_snocPL) - ,("transpose", mytest prop_transposePL) - ,("replicate", mytest prop_replicatePL) - ,("take", mytest prop_takePL) - ,("drop", mytest prop_dropPL) - ,("splitAt", mytest prop_splitAtPL) - ,("takeWhile", mytest prop_takeWhilePL) - ,("dropWhile", mytest prop_dropWhilePL) - ,("break", mytest prop_breakPL) - ,("span", mytest prop_spanPL) - ,("group", mytest prop_groupPL) - ,("inits", mytest prop_initsPL) - ,("tails", mytest prop_tailsPL) - ,("elem", mytest prop_elemPL) - ,("notElem", mytest prop_notElemPL) - ,("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) - ] - ------------------------------------------------------------------------- --- extra ByteString properties - -bb_tests = - [ ("bijection", mytest prop_bijectionBB) - , ("bijection'", mytest prop_bijectionBB') - , ("pack/unpack", mytest prop_packunpackBB) - , ("unpack/pack", mytest prop_packunpackBB') - , ("eq 1", mytest prop_eq1BB) - , ("eq 2", mytest prop_eq2BB) - , ("eq 3", mytest prop_eq3BB) - , ("compare 1", mytest prop_compare1BB) - , ("compare 2", mytest prop_compare2BB) - , ("compare 3", mytest prop_compare3BB) - , ("compare 4", mytest prop_compare4BB) - , ("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) - , ("cons 1", mytest prop_consBB) - , ("cons 2", mytest prop_cons1BB) - , ("cons 3", mytest prop_cons2BB) - , ("cons 4", mytest prop_cons3BB) - , ("cons 5", mytest prop_cons4BB) - , ("snoc", mytest prop_snoc1BB) - , ("head 1", mytest prop_head1BB) - , ("head 2", mytest prop_head2BB) - , ("head 3", mytest prop_head3BB) - , ("tail", mytest prop_tailBB) - , ("tail 1", mytest prop_tail1BB) - , ("last", mytest prop_lastBB) - , ("init", mytest prop_initBB) - , ("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) - , ("reverse 1", mytest prop_reverse1BB) - , ("reverse 2", mytest prop_reverse2BB) - , ("reverse 3", mytest prop_reverse3BB) - , ("foldl 1", mytest prop_foldl1BB) - , ("foldl 2", mytest prop_foldl2BB) - , ("foldr 1", mytest prop_foldr1BB) - , ("foldr 2", mytest prop_foldr2BB) - , ("foldl1 1", mytest prop_foldl1_1BB) - , ("foldl1 2", mytest prop_foldl1_2BB) - , ("foldl1 3", mytest prop_foldl1_3BB) - , ("foldr1 1", mytest prop_foldr1_1BB) - , ("foldr1 2", mytest prop_foldr1_2BB) - , ("foldr1 3", mytest prop_foldr1_3BB) - , ("scanl/foldl", mytest prop_scanlfoldlBB) - , ("all", mytest prop_allBB) - , ("any", mytest prop_anyBB) - , ("take", mytest prop_takeBB) - , ("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) - , ("findIndex", mytest prop_findIndexBB) - , ("findIndicies", mytest prop_findIndiciesBB) - , ("elemIndices", mytest prop_elemIndicesBB) - , ("find", mytest prop_findBB) - , ("find/findIndex", mytest prop_find_findIndexBB) - , ("sort 1", mytest prop_sort1BB) - , ("sort 2", mytest prop_sort2BB) - , ("sort 3", mytest prop_sort3BB) - , ("sort 4", mytest prop_sort4BB) - , ("sort 5", mytest prop_sort5BB) - , ("intersperse", mytest prop_intersperseBB) - , ("maximum", mytest prop_maximumBB) - , ("minimum", mytest prop_minimumBB) --- , ("breakChar", mytest prop_breakCharBB) --- , ("spanChar 1", mytest prop_spanCharBB) --- , ("spanChar 2", mytest prop_spanChar_1BB) --- , ("breakSpace", mytest prop_breakSpaceBB) --- , ("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') --- , ("dropSpaceEnd", mytest prop_dropSpaceEndBB) - , ("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) - , ("readInt", mytest prop_readintBB) - , ("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) --- , ("filterNotChar1", mytest prop_filterNotChar1BB) --- , ("filterNotChar2", mytest prop_filterNotChar2BB) - , ("tail", mytest prop_tailSBB) - , ("index", mytest prop_indexBB) - , ("unsafeIndex", mytest prop_unsafeIndexBB) --- , ("map'", mytest prop_mapBB') - , ("filter", mytest prop_filterBB) - , ("elem", mytest prop_elemSBB) - , ("take", mytest prop_takeSBB) - , ("drop", mytest prop_dropSBB) - , ("splitAt", mytest prop_splitAtSBB) - , ("foldl", mytest prop_foldlBB) - , ("foldr", mytest prop_foldrBB) - , ("takeWhile ", mytest prop_takeWhileSBB) - , ("dropWhile ", mytest prop_dropWhileSBB) - , ("span ", mytest prop_spanSBB) - , ("break ", mytest prop_breakSBB) - , ("breakspan", mytest prop_breakspan_1BB) - , ("lines ", mytest prop_linesSBB) - , ("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_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) --- , ("join/joinByte", mytest prop_join_spec) --- , ("span/spanByte", mytest prop_span_spec) --- , ("break/breakByte",mytest prop_break_spec) - ] - ------------------------------------------------------------------------- --- Fusion rules - -{- -fusion_tests = --- v1 fusion - [ ("lazy loop/loop fusion", mytest prop_lazylooploop) - , ("loop/loop fusion", mytest prop_looploop) - --- v2 fusion - ,("loop/loop wrapper elim", mytest prop_loop_loop_wrapper_elimination) - ,("sequence association", mytest prop_sequenceloops_assoc) - - ,("up/up loop fusion", mytest prop_up_up_loop_fusion) - ,("down/down loop fusion", mytest prop_down_down_loop_fusion) - ,("noAcc/noAcc loop fusion", mytest prop_noAcc_noAcc_loop_fusion) - ,("noAcc/up loop fusion", mytest prop_noAcc_up_loop_fusion) - ,("up/noAcc loop fusion", mytest prop_up_noAcc_loop_fusion) - ,("noAcc/down loop fusion", mytest prop_noAcc_down_loop_fusion) - ,("down/noAcc loop fusion", mytest prop_down_noAcc_loop_fusion) - ,("map/map loop fusion", mytest prop_map_map_loop_fusion) - ,("filter/filter loop fusion", mytest prop_filter_filter_loop_fusion) - ,("map/filter loop fusion", mytest prop_map_filter_loop_fusion) - ,("filter/map loop fusion", mytest prop_filter_map_loop_fusion) - ,("map/noAcc loop fusion", mytest prop_map_noAcc_loop_fusion) - ,("noAcc/map loop fusion", mytest prop_noAcc_map_loop_fusion) - ,("map/up loop fusion", mytest prop_map_up_loop_fusion) - ,("up/map loop fusion", mytest prop_up_map_loop_fusion) - ,("map/down loop fusion", mytest prop_map_down_fusion) - ,("down/map loop fusion", mytest prop_down_map_loop_fusion) - ,("filter/noAcc loop fusion", mytest prop_filter_noAcc_loop_fusion) - ,("noAcc/filter loop fusion", mytest prop_noAcc_filter_loop_fusion) - ,("filter/up loop fusion", mytest prop_filter_up_loop_fusion) - ,("up/filter loop fusion", mytest prop_up_filter_loop_fusion) - ,("filter/down loop fusion", mytest prop_filter_down_fusion) - ,("down/filter loop fusion", mytest prop_down_filter_loop_fusion) - -{- - ,("length/loop fusion", mytest prop_length_loop_fusion_1) - ,("length/loop fusion", mytest prop_length_loop_fusion_2) - ,("length/loop fusion", mytest prop_length_loop_fusion_3) - ,("length/loop fusion", mytest prop_length_loop_fusion_4) --} - --- ,("zipwith/spec", mytest prop_zipwith_spec) - ] - --} - - ------------------------------------------------------------------------- --- Extra lazy properties - -ll_tests = - [("eq 1", mytest prop_eq1) - ,("eq 2", mytest prop_eq2) - ,("eq 3", mytest prop_eq3) - ,("eq refl", mytest prop_eq_refl) - ,("eq symm", mytest prop_eq_symm) - ,("compare 1", mytest prop_compare1) - ,("compare 2", mytest prop_compare2) - ,("compare 3", mytest prop_compare3) - ,("compare 4", mytest prop_compare4) - ,("compare 5", mytest prop_compare5) - ,("compare 6", mytest prop_compare6) - ,("compare 7", mytest prop_compare7) - ,("compare 8", mytest prop_compare8) - ,("empty 1", mytest prop_empty1) - ,("empty 2", mytest prop_empty2) - ,("pack/unpack", mytest prop_packunpack) - ,("unpack/pack", mytest prop_unpackpack) - ,("null", mytest prop_null) - ,("length 1", mytest prop_length1) - ,("length 2", mytest prop_length2) - ,("cons 1" , mytest prop_cons1) - ,("cons 2" , mytest prop_cons2) - ,("cons 3" , mytest prop_cons3) - ,("cons 4" , mytest prop_cons4) - ,("snoc" , mytest prop_snoc1) - ,("head/pack", mytest prop_head) - ,("head/unpack", mytest prop_head1) - ,("tail/pack", mytest prop_tail) - ,("tail/unpack", mytest prop_tail1) - ,("last", mytest prop_last) - ,("init", mytest prop_init) - ,("append 1", mytest prop_append1) - ,("append 2", mytest prop_append2) - ,("append 3", mytest prop_append3) - ,("map 1", mytest prop_map1) - ,("map 2", mytest prop_map2) - ,("map 3", mytest prop_map3) - ,("filter 1", mytest prop_filter1) - ,("filter 2", mytest prop_filter2) - ,("reverse", mytest prop_reverse) - ,("reverse1", mytest prop_reverse1) - ,("reverse2", mytest prop_reverse2) - ,("transpose", mytest prop_transpose) - ,("foldl", mytest prop_foldl) - ,("foldl/reverse", mytest prop_foldl_1) - ,("foldr", mytest prop_foldr) - ,("foldr/id", mytest prop_foldr_1) - ,("foldl1/foldl", mytest prop_foldl1_1) - ,("foldl1/head", mytest prop_foldl1_2) - ,("foldl1/tail", mytest prop_foldl1_3) - ,("foldr1/foldr", mytest prop_foldr1_1) - ,("foldr1/last", mytest prop_foldr1_2) - ,("foldr1/head", mytest prop_foldr1_3) - ,("concat 1", mytest prop_concat1) - ,("concat 2", mytest prop_concat2) - ,("concat/pack", mytest prop_concat3) - ,("any", mytest prop_any) - ,("all", mytest prop_all) - ,("maximum", mytest prop_maximum) - ,("minimum", mytest prop_minimum) - ,("replicate 1", mytest prop_replicate1) - ,("replicate 2", mytest prop_replicate2) - ,("take", mytest prop_take1) - ,("drop", mytest prop_drop1) - ,("splitAt", mytest prop_drop1) - ,("takeWhile", mytest prop_takeWhile) - ,("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) - ,("findIndex", mytest prop_findIndex) - ,("findIndices", mytest prop_findIndicies) - ,("find", mytest prop_find) - ,("find/findIndex", mytest prop_find_findIndex) - ,("elem", mytest prop_elem) - ,("notElem", mytest prop_notElem) - ,("elem/notElem", mytest prop_elem_notelem) --- ,("filterByte 1", mytest prop_filterByte) --- ,("filterByte 2", mytest prop_filterByte2) --- ,("filterNotByte 1", mytest prop_filterNotByte) --- ,("filterNotByte 2", mytest prop_filterNotByte2) - ,("isPrefixOf", mytest prop_isPrefixOf) - ,("concatMap", mytest prop_concatMap) - ,("isSpace", mytest prop_isSpaceWord8) +{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +-- +-- 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.Storable +import Foreign.ForeignPtr +import Foreign.Marshal.Alloc +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 Data.String + +import System.Environment +import System.IO +import System.IO.Unsafe + +import Data.ByteString.Lazy (ByteString(..), pack , unpack) +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.Lazy.Char8 as LC +import qualified Data.ByteString.Lazy.Char8 as D + +import qualified Data.ByteString.Lazy.Internal as L +import Prelude hiding (abs) + +import Rules +import QuickCheckUtils +import TestFramework + +toInt64 :: Int -> Int64 +toInt64 = fromIntegral + +-- +-- 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_groupByCC = D.groupBy `eq2` C.groupBy +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 = adjustSize (min 50) $ + D.concatMap `eq2` C.concatMap +prop_consCC = D.cons `eq2` C.cons +prop_consCC' = D.cons' `eq2` C.cons +prop_unconsCC = D.uncons `eq1` C.uncons +prop_countCC = D.count `eq2` ((toInt64 .) . C.count) +prop_dropCC = (D.drop . toInt64) `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` ((fmap toInt64 .) . C.findIndex) +prop_findIndicesCC = D.findIndices `eq2` ((fmap toInt64 .) . C.findIndices) +prop_isPrefixOfCC = D.isPrefixOf `eq2` C.isPrefixOf +prop_mapCC = D.map `eq2` C.map +prop_replicateCC = forAll arbitrarySizedIntegral $ + (D.replicate . toInt64) `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 . toInt64) `eq2` C.splitAt +prop_takeCC = (D.take . toInt64) `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` ((fmap toInt64 .) . C.elemIndex) +prop_elemIndicesCC = D.elemIndices `eq2` ((fmap toInt64 .) . C.elemIndices) +prop_lengthCC = D.length `eq1` (toInt64 . C.length) + +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 = adjustSize (`div` 2) $ + 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_groupByBP = L.groupBy `eq2` P.groupBy +prop_initsBP = L.inits `eq1` P.inits +prop_tailsBP = L.tails `eq1` P.tails +prop_allBP = L.all `eq2` P.all +prop_anyBP = L.any `eq2` P.any +prop_appendBP = L.append `eq2` P.append +prop_breakBP = L.break `eq2` P.break +prop_concatMapBP = adjustSize (`div` 4) $ + L.concatMap `eq2` P.concatMap +prop_consBP = L.cons `eq2` P.cons +prop_consBP' = L.cons' `eq2` P.cons +prop_unconsBP = L.uncons `eq1` P.uncons +prop_countBP = L.count `eq2` ((toInt64 .) . P.count) +prop_dropBP = (L.drop. toInt64) `eq2` P.drop +prop_dropWhileBP = L.dropWhile `eq2` P.dropWhile +prop_filterBP = L.filter `eq2` P.filter +prop_findBP = L.find `eq2` P.find +prop_findIndexBP = L.findIndex `eq2` ((fmap toInt64 .) . P.findIndex) +prop_findIndicesBP = L.findIndices `eq2` ((fmap toInt64 .) . P.findIndices) +prop_isPrefixOfBP = L.isPrefixOf `eq2` P.isPrefixOf +prop_mapBP = L.map `eq2` P.map +prop_replicateBP = forAll arbitrarySizedIntegral $ + (L.replicate. toInt64) `eq2` P.replicate +prop_snocBP = L.snoc `eq2` P.snoc +prop_spanBP = L.span `eq2` P.span +prop_splitBP = L.split `eq2` P.split +prop_splitAtBP = (L.splitAt. toInt64) `eq2` P.splitAt +prop_takeBP = (L.take . toInt64) `eq2` P.take +prop_takeWhileBP = L.takeWhile `eq2` P.takeWhile +prop_elemBP = L.elem `eq2` P.elem +prop_notElemBP = L.notElem `eq2` P.notElem +prop_elemIndexBP = L.elemIndex `eq2` ((fmap toInt64 .) . P.elemIndex) +prop_elemIndicesBP = L.elemIndices `eq2` ((fmap toInt64 .) . P.elemIndices) +prop_intersperseBP = L.intersperse `eq2` P.intersperse +prop_lengthBP = L.length `eq1` (toInt64 . P.length) +prop_readIntBP = D.readInt `eq1` C.readInt +prop_linesBP = D.lines `eq1` C.lines + +-- double check: +-- Currently there's a bug in the lazy bytestring version of lines, this +-- catches it: +prop_linesNLBP = eq1 D.lines C.lines x + where x = D.pack "one\ntwo\n\n\nfive\n\nseven\n" + +prop_headBP = L.head `eqnotnull1` P.head +prop_initBP = L.init `eqnotnull1` P.init +prop_lastBP = L.last `eqnotnull1` P.last +prop_maximumBP = L.maximum `eqnotnull1` P.maximum +prop_minimumBP = L.minimum `eqnotnull1` P.minimum +prop_tailBP = L.tail `eqnotnull1` P.tail +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) +prop_compareBP = eq2 + ((compare) :: B -> B -> Ordering) + ((compare) :: P -> P -> Ordering) +prop_foldlBP = eq3 + (L.foldl :: (X -> W -> X) -> X -> B -> X) + (P.foldl :: (X -> W -> X) -> X -> P -> X) +prop_foldlBP' = eq3 + (L.foldl' :: (X -> W -> X) -> X -> B -> X) + (P.foldl' :: (X -> W -> X) -> X -> P -> X) +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)) + +prop_unfoldrBP = + forAll arbitrarySizedIntegral $ + eq3 + ((\n f a -> L.take (fromIntegral n) $ + L.unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> B) + ((\n f a -> fst $ + P.unfoldrN n f a) :: Int -> (X -> Maybe (W,X)) -> X -> P) + +prop_unfoldr2BP = + forAll arbitrarySizedIntegral $ \n -> + forAll arbitrarySizedIntegral $ \a -> + 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) + n a + +prop_unfoldr2CP = + forAll arbitrarySizedIntegral $ \n -> + forAll arbitrarySizedIntegral $ \a -> + 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) + n a + + +prop_unfoldrLC = + forAll arbitrarySizedIntegral $ + 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) ==> + forAll arbitrarySizedIntegral $ + 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 = + forAll arbitrarySizedIntegral $ + 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 = + forAll arbitrarySizedIntegral $ + 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 = + forAll arbitrarySizedIntegral $ + 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 = + forAll arbitrarySizedIntegral $ + 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 = + forAll arbitrarySizedIntegral $ + 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 +-- + +prop_concatBL = adjustSize (`div` 2) $ + L.concat `eq1` (concat :: [[W]] -> [W]) +prop_lengthBL = L.length `eq1` (toInt64 . length :: [W] -> Int64) +prop_nullBL = L.null `eq1` (null :: [W] -> Bool) +prop_reverseBL = L.reverse `eq1` (reverse :: [W] -> [W]) +prop_transposeBL = L.transpose `eq1` (transpose :: [[W]] -> [[W]]) +prop_groupBL = L.group `eq1` (group :: [W] -> [[W]]) +prop_groupByBL = L.groupBy `eq2` (groupBy :: (W -> W -> Bool) -> [W] -> [[W]]) +prop_initsBL = L.inits `eq1` (inits :: [W] -> [[W]]) +prop_tailsBL = L.tails `eq1` (tails :: [W] -> [[W]]) +prop_allBL = L.all `eq2` (all :: (W -> Bool) -> [W] -> Bool) +prop_anyBL = L.any `eq2` (any :: (W -> Bool) -> [W] -> Bool) +prop_appendBL = L.append `eq2` ((++) :: [W] -> [W] -> [W]) +prop_breakBL = L.break `eq2` (break :: (W -> Bool) -> [W] -> ([W],[W])) +prop_concatMapBL = adjustSize (`div` 2) $ + L.concatMap `eq2` (concatMap :: (W -> [W]) -> [W] -> [W]) +prop_consBL = L.cons `eq2` ((:) :: W -> [W] -> [W]) +prop_dropBL = (L.drop . toInt64) `eq2` (drop :: Int -> [W] -> [W]) +prop_dropWhileBL = L.dropWhile `eq2` (dropWhile :: (W -> Bool) -> [W] -> [W]) +prop_filterBL = L.filter `eq2` (filter :: (W -> Bool ) -> [W] -> [W]) +prop_findBL = L.find `eq2` (find :: (W -> Bool) -> [W] -> Maybe W) +prop_findIndicesBL = L.findIndices `eq2` ((fmap toInt64 .) . findIndices:: (W -> Bool) -> [W] -> [Int64]) +prop_findIndexBL = L.findIndex `eq2` ((fmap toInt64 .) . findIndex :: (W -> Bool) -> [W] -> Maybe Int64) +prop_isPrefixOfBL = L.isPrefixOf `eq2` (isPrefixOf:: [W] -> [W] -> Bool) +prop_mapBL = L.map `eq2` (map :: (W -> W) -> [W] -> [W]) +prop_replicateBL = forAll arbitrarySizedIntegral $ + (L.replicate . toInt64) `eq2` (replicate :: Int -> W -> [W]) +prop_snocBL = L.snoc `eq2` ((\xs x -> xs ++ [x]) :: [W] -> W -> [W]) +prop_spanBL = L.span `eq2` (span :: (W -> Bool) -> [W] -> ([W],[W])) +prop_splitAtBL = (L.splitAt . toInt64) `eq2` (splitAt :: Int -> [W] -> ([W],[W])) +prop_takeBL = (L.take . toInt64) `eq2` (take :: Int -> [W] -> [W]) +prop_takeWhileBL = L.takeWhile `eq2` (takeWhile :: (W -> Bool) -> [W] -> [W]) +prop_elemBL = L.elem `eq2` (elem :: W -> [W] -> Bool) +prop_notElemBL = L.notElem `eq2` (notElem :: W -> [W] -> Bool) +prop_elemIndexBL = L.elemIndex `eq2` ((fmap toInt64 .) . elemIndex :: W -> [W] -> Maybe Int64) +prop_elemIndicesBL = L.elemIndices `eq2` ((fmap toInt64 .) . elemIndices :: W -> [W] -> [Int64]) +prop_linesBL = D.lines `eq1` (lines :: String -> [String]) + +prop_foldl1BL = L.foldl1 `eqnotnull2` (foldl1 :: (W -> W -> W) -> [W] -> W) +prop_foldl1BL' = L.foldl1' `eqnotnull2` (foldl1' :: (W -> W -> W) -> [W] -> W) +prop_foldr1BL = L.foldr1 `eqnotnull2` (foldr1 :: (W -> W -> W) -> [W] -> W) +prop_headBL = L.head `eqnotnull1` (head :: [W] -> W) +prop_initBL = L.init `eqnotnull1` (init :: [W] -> [W]) +prop_lastBL = L.last `eqnotnull1` (last :: [W] -> W) +prop_maximumBL = L.maximum `eqnotnull1` (maximum :: [W] -> W) +prop_minimumBL = L.minimum `eqnotnull1` (minimum :: [W] -> W) +prop_tailBL = L.tail `eqnotnull1` (tail :: [W] -> [W]) + +prop_eqBL = eq2 + ((==) :: B -> B -> Bool) + ((==) :: [W] -> [W] -> Bool) +prop_compareBL = eq2 + ((compare) :: B -> B -> Ordering) + ((compare) :: [W] -> [W] -> Ordering) +prop_foldlBL = eq3 + (L.foldl :: (X -> W -> X) -> X -> B -> X) + ( foldl :: (X -> W -> X) -> X -> [W] -> X) +prop_foldlBL' = eq3 + (L.foldl' :: (X -> W -> X) -> X -> B -> X) + ( foldl' :: (X -> W -> X) -> X -> [W] -> X) +prop_foldrBL = eq3 + (L.foldr :: (W -> X -> X) -> X -> B -> X) + ( foldr :: (W -> X -> X) -> X -> [W] -> X) +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 = + forAll arbitrarySizedIntegral $ + eq3 + ((\n f a -> L.take (fromIntegral n) $ + L.unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> B) + ((\n f a -> take n $ + unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> [W]) + +-- +-- And finally, check correspondance between Data.ByteString and List +-- + +prop_lengthPL = (fromIntegral.P.length :: P -> Int) `eq1` (length :: [W] -> Int) +prop_nullPL = P.null `eq1` (null :: [W] -> Bool) +prop_reversePL = P.reverse `eq1` (reverse :: [W] -> [W]) +prop_transposePL = P.transpose `eq1` (transpose :: [[W]] -> [[W]]) +prop_groupPL = P.group `eq1` (group :: [W] -> [[W]]) +prop_groupByPL = P.groupBy `eq2` (groupBy :: (W -> W -> Bool) -> [W] -> [[W]]) +prop_initsPL = P.inits `eq1` (inits :: [W] -> [[W]]) +prop_tailsPL = P.tails `eq1` (tails :: [W] -> [[W]]) +prop_concatPL = adjustSize (`div` 2) $ + P.concat `eq1` (concat :: [[W]] -> [W]) +prop_allPL = P.all `eq2` (all :: (W -> Bool) -> [W] -> Bool) +prop_anyPL = P.any `eq2` (any :: (W -> Bool) -> [W] -> Bool) +prop_appendPL = P.append `eq2` ((++) :: [W] -> [W] -> [W]) +prop_breakPL = P.break `eq2` (break :: (W -> Bool) -> [W] -> ([W],[W])) +prop_concatMapPL = adjustSize (`div` 2) $ + P.concatMap `eq2` (concatMap :: (W -> [W]) -> [W] -> [W]) +prop_consPL = P.cons `eq2` ((:) :: W -> [W] -> [W]) +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 = forAll arbitrarySizedIntegral $ + P.replicate `eq2` (replicate :: Int -> W -> [W]) +prop_snocPL = P.snoc `eq2` ((\xs x -> xs ++ [x]) :: [W] -> W -> [W]) +prop_spanPL = P.span `eq2` (span :: (W -> Bool) -> [W] -> ([W],[W])) +prop_splitAtPL = P.splitAt `eq2` (splitAt :: Int -> [W] -> ([W],[W])) +prop_takePL = P.take `eq2` (take :: Int -> [W] -> [W]) +prop_takeWhilePL = P.takeWhile `eq2` (takeWhile :: (W -> Bool) -> [W] -> [W]) +prop_elemPL = P.elem `eq2` (elem :: W -> [W] -> Bool) +prop_notElemPL = P.notElem `eq2` (notElem :: W -> [W] -> Bool) +prop_elemIndexPL = P.elemIndex `eq2` (elemIndex :: W -> [W] -> Maybe Int) +prop_linesPL = C.lines `eq1` (lines :: String -> [String]) +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) +prop_foldr1PL = P.foldr1 `eqnotnull2` (foldr1 :: (W -> W -> W) -> [W] -> W) +prop_scanlPL = P.scanl `eqnotnull3` (scanl :: (W -> W -> W) -> W -> [W] -> [W]) +prop_scanl1PL = P.scanl1 `eqnotnull2` (scanl1 :: (W -> W -> W) -> [W] -> [W]) +prop_scanrPL = P.scanr `eqnotnull3` (scanr :: (W -> W -> W) -> W -> [W] -> [W]) +prop_scanr1PL = P.scanr1 `eqnotnull2` (scanr1 :: (W -> W -> W) -> [W] -> [W]) +prop_headPL = P.head `eqnotnull1` (head :: [W] -> W) +prop_initPL = P.init `eqnotnull1` (init :: [W] -> [W]) +prop_lastPL = P.last `eqnotnull1` (last :: [W] -> W) +prop_maximumPL = P.maximum `eqnotnull1` (maximum :: [W] -> W) +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) +prop_comparePL = eq2 + ((compare) :: P -> P -> Ordering) + ((compare) :: [W] -> [W] -> Ordering) +prop_foldlPL = eq3 + (P.foldl :: (X -> W -> X) -> X -> P -> X) + ( foldl :: (X -> W -> X) -> X -> [W] -> X) +prop_foldlPL' = eq3 + (P.foldl' :: (X -> W -> X) -> X -> P -> X) + ( foldl' :: (X -> W -> X) -> X -> [W] -> X) +prop_foldrPL = eq3 + (P.foldr :: (W -> X -> X) -> X -> P -> X) + ( foldr :: (W -> X -> X) -> X -> [W] -> X) +prop_mapAccumLPL= eq3 + (P.mapAccumL :: (X -> W -> (X,W)) -> X -> P -> (X, P)) + ( mapAccumL :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) +prop_mapAccumRPL= eq3 + (P.mapAccumR :: (X -> W -> (X,W)) -> X -> P -> (X, P)) + ( mapAccumR :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) +prop_unfoldrPL = + forAll arbitrarySizedIntegral $ + eq3 + ((\n f a -> fst $ + P.unfoldrN n f a) :: Int -> (X -> Maybe (W,X)) -> X -> P) + ((\n f a -> take n $ + unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> [W]) + +------------------------------------------------------------------------ +-- +-- These are miscellaneous tests left over. Or else they test some +-- property internal to a type (i.e. head . sort == minimum), without +-- reference to a model type. +-- + +invariant :: L.ByteString -> Bool +invariant Empty = True +invariant (Chunk c cs) = not (P.null c) && invariant cs + +prop_invariant = invariant + +prop_eq_refl x = x == (x :: ByteString) +prop_eq_symm x y = (x == y) == (y == (x :: ByteString)) + +prop_eq1 xs = xs == (unpack . pack $ xs) +prop_eq2 xs = xs == (xs :: ByteString) +prop_eq3 xs ys = (xs == ys) == (unpack xs == unpack ys) + +prop_compare1 xs = (pack xs `compare` pack xs) == EQ +prop_compare2 xs c = (pack (xs++[c]) `compare` pack xs) == GT +prop_compare3 xs c = (pack xs `compare` pack (xs++[c])) == LT + +prop_compare4 xs = (not (null xs)) ==> (pack xs `compare` L.empty) == GT +prop_compare5 xs = (not (null xs)) ==> (L.empty `compare` pack xs) == LT +prop_compare6 xs ys = (not (null ys)) ==> (pack (xs++ys) `compare` pack xs) == GT + +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 == [] + +prop_packunpack s = (L.unpack . L.pack) s == id s +prop_unpackpack s = (L.pack . L.unpack) s == id s + +prop_null xs = null (L.unpack xs) == L.null xs + +prop_length1 xs = fromIntegral (length xs) == L.length (L.pack xs) + +prop_length2 xs = L.length xs == length1 xs + where length1 ys + | L.null ys = 0 + | otherwise = 1 + length1 (L.tail ys) + +prop_cons1 c xs = unpack (L.cons c (pack xs)) == (c:xs) +prop_cons2 c = L.singleton c == (c `L.cons` L.empty) +prop_cons3 c = unpack (L.singleton c) == (c:[]) +prop_cons4 c = (c `L.cons` L.empty) == pack (c:[]) + +prop_snoc1 xs c = xs ++ [c] == unpack ((pack xs) `L.snoc` c) + +prop_head xs = (not (null xs)) ==> head xs == (L.head . pack) xs +prop_head1 xs = not (L.null xs) ==> L.head xs == head (L.unpack xs) + +prop_tail xs = not (L.null xs) ==> L.tail xs == pack (tail (unpack xs)) +prop_tail1 xs = (not (null xs)) ==> tail xs == (unpack . L.tail . pack) xs + +prop_last xs = (not (null xs)) ==> last xs == (L.last . pack) xs + +prop_init xs = + (not (null xs)) ==> + init xs == (unpack . L.init . pack) xs + +prop_append1 xs = (xs ++ xs) == (unpack $ pack xs `L.append` pack xs) +prop_append2 xs ys = (xs ++ ys) == (unpack $ pack xs `L.append` pack ys) +prop_append3 xs ys = L.append xs ys == pack (unpack xs ++ unpack ys) + +prop_map1 f xs = L.map f (pack xs) == pack (map f xs) +prop_map2 f g xs = L.map f (L.map g xs) == L.map (f . g) xs +prop_map3 f xs = map f xs == (unpack . L.map f . pack) xs + +prop_filter1 c xs = (filter (/=c) xs) == (unpack $ L.filter (/=c) (pack xs)) +prop_filter2 p xs = (filter p xs) == (unpack $ L.filter p (pack xs)) + +prop_reverse xs = reverse xs == (unpack . L.reverse . pack) xs +prop_reverse1 xs = L.reverse (pack xs) == pack (reverse xs) +prop_reverse2 xs = reverse (unpack xs) == (unpack . L.reverse) xs + +prop_transpose xs = (transpose xs) == ((map unpack) . L.transpose . (map pack)) xs + +prop_foldl f c xs = L.foldl f c (pack xs) == foldl f c xs + where _ = c :: Char + +prop_foldr f c xs = L.foldl f c (pack xs) == foldl f c xs + where _ = c :: Char + +prop_foldl_1 xs = L.foldl (\xs c -> c `L.cons` xs) L.empty xs == L.reverse xs +prop_foldr_1 xs = L.foldr (\c xs -> c `L.cons` xs) L.empty xs == id xs + +prop_foldl1_1 xs = + (not . L.null) xs ==> + L.foldl1 (\x c -> if c > x then c else x) xs == + L.foldl (\x c -> if c > x then c else x) 0 xs + +prop_foldl1_2 xs = + (not . L.null) xs ==> + L.foldl1 const xs == L.head xs + +prop_foldl1_3 xs = + (not . L.null) xs ==> + L.foldl1 (flip const) xs == L.last xs + +prop_foldr1_1 xs = + (not . L.null) xs ==> + L.foldr1 (\c x -> if c > x then c else x) xs == + L.foldr (\c x -> if c > x then c else x) 0 xs + +prop_foldr1_2 xs = + (not . L.null) xs ==> + L.foldr1 (flip const) xs == L.last xs + +prop_foldr1_3 xs = + (not . L.null) xs ==> + L.foldr1 const xs == L.head xs + +prop_concat1 xs = (concat [xs,xs]) == (unpack $ L.concat [pack xs, pack xs]) +prop_concat2 xs = (concat [xs,[]]) == (unpack $ L.concat [pack xs, pack []]) +prop_concat3 xss = adjustSize (`div` 2) $ + L.concat (map pack xss) == pack (concat xss) + +prop_concatMap xs = L.concatMap L.singleton xs == (pack . concatMap (:[]) . unpack) xs + +prop_any xs a = (any (== a) xs) == (L.any (== a) (pack xs)) +prop_all xs a = (all (== a) xs) == (L.all (== a) (pack xs)) + +prop_maximum xs = (not (null xs)) ==> (maximum xs) == (L.maximum ( pack xs )) +prop_minimum xs = (not (null xs)) ==> (minimum xs) == (L.minimum ( pack xs )) + +prop_replicate1 c = + forAll arbitrarySizedIntegral $ \(Positive n) -> + unpack (L.replicate (fromIntegral n) c) == replicate n c + +prop_replicate2 c = unpack (L.replicate 0 c) == replicate 0 c + +prop_take1 i xs = L.take (fromIntegral i) (pack xs) == pack (take i xs) +prop_drop1 i xs = L.drop (fromIntegral i) (pack xs) == pack (drop i xs) + +prop_splitAt i xs = --collect (i >= 0 && i < length xs) $ + L.splitAt (fromIntegral i) (pack xs) == let (a,b) = splitAt i xs in (pack a, pack b) + +prop_takeWhile f xs = L.takeWhile f (pack xs) == pack (takeWhile f xs) +prop_dropWhile f xs = L.dropWhile f (pack xs) == pack (dropWhile f xs) + +prop_break f xs = L.break f (pack xs) == + let (a,b) = break f xs in (pack a, pack b) + +prop_breakspan xs c = L.break (==c) xs == L.span (/=c) xs + +prop_span xs a = (span (/=a) xs) == (let (x,y) = L.span (/=a) (pack xs) in (unpack x, unpack y)) + +-- prop_breakByte xs c = L.break (== c) xs == L.breakByte c xs + +-- prop_spanByte c xs = (L.span (==c) xs) == L.spanByte c xs + +prop_split c xs = (map L.unpack . map checkInvariant . L.split c $ xs) + == (map P.unpack . P.split c . P.pack . L.unpack $ xs) + +prop_splitWith f xs = (l1 == l2 || l1 == l2+1) && + sum (map L.length splits) == L.length xs - l2 + where splits = L.splitWith f xs + 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] + +prop_index xs = + not (null xs) ==> + 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)) + +prop_count c xs = length (L.elemIndices c xs) == fromIntegral (L.count c xs) + +prop_findIndex xs f = (findIndex f xs) == fmap fromIntegral (L.findIndex f (pack xs)) +prop_findIndicies xs f = (findIndices f xs) == map fromIntegral (L.findIndices f (pack xs)) + +prop_elem xs c = (c `elem` xs) == (c `L.elem` (pack xs)) +prop_notElem xs c = (c `notElem` xs) == (L.notElem c (pack xs)) +prop_elem_notelem xs c = c `L.elem` xs == not (c `L.notElem` xs) + +-- prop_filterByte xs c = L.filterByte c xs == L.filter (==c) xs +-- prop_filterByte2 xs c = unpack (L.filterByte c xs) == filter (==c) (unpack xs) + +-- prop_filterNotByte xs c = L.filterNotByte c xs == L.filter (/=c) xs +-- prop_filterNotByte2 xs c = unpack (L.filterNotByte c xs) == filter (/=c) (unpack xs) + +prop_find p xs = find p xs == L.find p (pack xs) + +prop_find_findIndex p xs = + L.find p xs == case L.findIndex p xs of + Just n -> Just (xs `L.index` n) + _ -> Nothing + +prop_isPrefixOf xs ys = isPrefixOf xs ys == (pack xs `L.isPrefixOf` pack ys) + +{- +prop_sort1 xs = sort xs == (unpack . L.sort . pack) xs +prop_sort2 xs = (not (null xs)) ==> (L.head . L.sort . pack $ xs) == minimum xs +prop_sort3 xs = (not (null xs)) ==> (L.last . L.sort . pack $ xs) == maximum xs +prop_sort4 xs ys = + (not (null xs)) ==> + (not (null ys)) ==> + (L.head . L.sort) (L.append (pack xs) (pack ys)) == min (minimum xs) (minimum ys) + +prop_sort5 xs ys = + (not (null xs)) ==> + (not (null ys)) ==> + (L.last . L.sort) (L.append (pack xs) (pack ys)) == max (maximum xs) (maximum ys) + +-} + +------------------------------------------------------------------------ +-- Misc ByteString properties + +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 + +prop_lengthBB xs = P.length xs == length1 xs + where + length1 ys + | P.null ys = 0 + | otherwise = 1 + length1 (P.tail ys) + +prop_lengthSBB xs = length xs == P.length (P.pack xs) + +prop_indexBB xs = + not (null xs) ==> + forAll indices $ \i -> (xs !! i) == P.pack xs `P.index` i + where indices = choose (0, length xs -1) + +prop_unsafeIndexBB xs = + not (null xs) ==> + forAll indices $ \i -> (xs !! i) == P.pack xs `P.unsafeIndex` i + where indices = choose (0, length xs -1) + +prop_mapfusionBB f g xs = P.map f (P.map g xs) == P.map (f . g) xs + +prop_filterBB f xs = P.filter f (P.pack xs) == P.pack (filter f xs) + +prop_filterfusionBB f g xs = P.filter f (P.filter g xs) == P.filter (\c -> f c && g c) xs + +prop_elemSBB x xs = P.elem x (P.pack xs) == elem x xs + +prop_takeSBB i xs = P.take i (P.pack xs) == P.pack (take i xs) +prop_dropSBB i xs = P.drop i (P.pack xs) == P.pack (drop i xs) + +prop_splitAtSBB i xs = -- collect (i >= 0 && i < length xs) $ + P.splitAt i (P.pack xs) == + let (a,b) = splitAt i xs in (P.pack a, P.pack b) + +prop_foldlBB f c xs = P.foldl f c (P.pack xs) == foldl f c xs + where _ = c :: Char + +prop_scanlfoldlBB f z xs = not (P.null xs) ==> P.last (P.scanl f z xs) == P.foldl f z xs + +prop_foldrBB f c xs = P.foldl f c (P.pack xs) == foldl f c xs + where _ = c :: Char + +prop_takeWhileSBB f xs = P.takeWhile f (P.pack xs) == P.pack (takeWhile f xs) +prop_dropWhileSBB f xs = P.dropWhile f (P.pack xs) == P.pack (dropWhile f xs) + +prop_spanSBB f xs = P.span f (P.pack xs) == + let (a,b) = span f xs in (P.pack a, P.pack b) + +prop_breakSBB f xs = P.break f (P.pack xs) == + let (a,b) = break f xs in (P.pack a, P.pack b) + +prop_breakspan_1BB xs c = P.break (== c) xs == P.span (/= c) xs + +prop_linesSBB xs = C.lines (C.pack xs) == map C.pack (lines xs) + +prop_unlinesSBB xss = C.unlines (map C.pack xss) == C.pack (unlines xss) + +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 + where splits = P.splitWith f xs + l1 = length splits + l2 = P.length (P.filter f xs) + +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 + +prop_bijectionBB c = (P.w2c . P.c2w) c == id c +prop_bijectionBB' w = (P.c2w . P.w2c) w == id w + +prop_packunpackBB s = (P.unpack . P.pack) s == id s +prop_packunpackBB' s = (P.pack . P.unpack) s == id s + +prop_eq1BB xs = xs == (P.unpack . P.pack $ 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 +prop_compare2BB xs c = (P.pack (xs++[c]) `compare` P.pack xs) == GT +prop_compare3BB xs c = (P.pack xs `compare` P.pack (xs++[c])) == LT + +prop_compare4BB xs = (not (null xs)) ==> (P.pack xs `compare` P.empty) == GT +prop_compare5BB xs = (not (null xs)) ==> (P.empty `compare` P.pack xs) == LT +prop_compare6BB xs ys= (not (null ys)) ==> (P.pack (xs++ys) `compare` P.pack xs) == GT + +prop_compare7BB x y = x `compare` y == (C.singleton x `compare` C.singleton y) +prop_compare8BB xs ys = xs `compare` ys == (P.pack xs `compare` P.pack ys) + +prop_consBB c xs = P.unpack (P.cons c (P.pack xs)) == (c:xs) +prop_cons1BB xs = 'X' : xs == C.unpack ('X' `C.cons` (C.pack xs)) +prop_cons2BB xs c = c : xs == P.unpack (c `P.cons` (P.pack xs)) +prop_cons3BB c = C.unpack (C.singleton c) == (c:[]) +prop_cons4BB c = (c `P.cons` P.empty) == P.pack (c:[]) + +prop_snoc1BB xs c = xs ++ [c] == P.unpack ((P.pack xs) `P.snoc` c) + +prop_head1BB xs = (not (null xs)) ==> head xs == (P.head . P.pack) xs +prop_head2BB xs = (not (null xs)) ==> head xs == (P.unsafeHead . P.pack) xs +prop_head3BB xs = not (P.null xs) ==> P.head xs == head (P.unpack xs) + +prop_tailBB xs = (not (null xs)) ==> tail xs == (P.unpack . P.tail . P.pack) xs +prop_tail1BB xs = (not (null xs)) ==> tail xs == (P.unpack . P.unsafeTail. P.pack) xs + +prop_lastBB xs = (not (null xs)) ==> last xs == (P.last . P.pack) xs + +prop_initBB xs = + (not (null xs)) ==> + init xs == (P.unpack . P.init . P.pack) xs + +-- prop_null xs = (null xs) ==> null xs == (nullPS (pack xs)) + +prop_append1BB xs = (xs ++ xs) == (P.unpack $ P.pack xs `P.append` P.pack xs) +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 +-- prop_mapBB' f xs = P.map' f (P.pack xs) == P.pack (map f xs) + +prop_filter1BB xs = (filter (=='X') xs) == (C.unpack $ C.filter (=='X') (C.pack xs)) +prop_filter2BB p xs = (filter p xs) == (P.unpack $ P.filter p (P.pack xs)) + +prop_findBB p xs = find p xs == P.find p (P.pack xs) + +prop_find_findIndexBB p xs = + P.find p xs == case P.findIndex p xs of + Just n -> Just (xs `P.unsafeIndex` n) + _ -> Nothing + +prop_foldl1BB xs a = ((foldl (\x c -> if c == a then x else c:x) [] xs)) == + (P.unpack $ P.foldl (\x c -> if c == a then x else c `P.cons` x) P.empty (P.pack xs)) +prop_foldl2BB xs = P.foldl (\xs c -> c `P.cons` xs) P.empty (P.pack xs) == P.reverse (P.pack xs) + +prop_foldr1BB xs a = ((foldr (\c x -> if c == a then x else c:x) [] xs)) == + (P.unpack $ P.foldr (\c x -> if c == a then x else c `P.cons` x) + P.empty (P.pack xs)) + +prop_foldr2BB xs = P.foldr (\c xs -> c `P.cons` xs) P.empty (P.pack xs) == (P.pack xs) + +prop_foldl1_1BB xs = + (not . P.null) xs ==> + P.foldl1 (\x c -> if c > x then c else x) xs == + P.foldl (\x c -> if c > x then c else x) 0 xs + +prop_foldl1_2BB xs = + (not . P.null) xs ==> + P.foldl1 const xs == P.head xs + +prop_foldl1_3BB xs = + (not . P.null) xs ==> + P.foldl1 (flip const) xs == P.last xs + +prop_foldr1_1BB xs = + (not . P.null) xs ==> + P.foldr1 (\c x -> if c > x then c else x) xs == + P.foldr (\c x -> if c > x then c else x) 0 xs + +prop_foldr1_2BB xs = + (not . P.null) xs ==> + P.foldr1 (flip const) xs == P.last xs + +prop_foldr1_3BB xs = + (not . P.null) xs ==> + P.foldr1 const xs == P.head xs + +prop_takeWhileBB xs a = (takeWhile (/= a) xs) == (P.unpack . (P.takeWhile (/= a)) . P.pack) xs + +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 + +prop_splitAtBB i xs = -- collect (i >= 0 && i < length xs) $ + splitAt i xs == + let (x,y) = P.splitAt i (P.pack xs) in (P.unpack x, P.unpack y) + +prop_spanBB xs a = (span (/=a) xs) == (let (x,y) = P.span (/=a) (P.pack xs) + in (P.unpack x, P.unpack y)) + +prop_breakBB xs a = (break (/=a) xs) == (let (x,y) = P.break (/=a) (P.pack xs) + in (P.unpack x, P.unpack y)) + +prop_reverse1BB xs = (reverse xs) == (P.unpack . P.reverse . P.pack) xs +prop_reverse2BB xs = P.reverse (P.pack xs) == P.pack (reverse xs) +prop_reverse3BB xs = reverse (P.unpack xs) == (P.unpack . P.reverse) xs + +prop_elemBB xs a = (a `elem` xs) == (a `P.elem` (P.pack xs)) + +prop_notElemBB c xs = P.notElem c (P.pack xs) == notElem c xs + +-- should try to stress it +prop_concat1BB xs = (concat [xs,xs]) == (P.unpack $ P.concat [P.pack xs, P.pack xs]) +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)) +prop_allBB xs a = (all (== a) xs) == (P.all (== a) (P.pack xs)) + +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 +-- prop_wordstokensBB xs = C.words xs == C.tokens isSpace xs + +prop_unwordsBB xs = + (C.pack.unwords.words) xs == (C.unwords . C.words .C.pack) xs + +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_groupBy1CC 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_groupBy2CC 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))) + +prop_elemIndex1BB xs = (elemIndex 'X' xs) == (C.elemIndex 'X' (C.pack xs)) +prop_elemIndex2BB xs c = (elemIndex c xs) == (C.elemIndex c (C.pack xs)) + +-- prop_lineIndices1BB xs = C.elemIndices '\n' xs == C.lineIndices xs + +prop_countBB c xs = length (P.elemIndices c xs) == P.count c xs + +prop_elemIndexEnd1BB c xs = (P.elemIndexEnd c (P.pack xs)) == + (case P.elemIndex c (P.pack (reverse xs)) of + 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)) + +prop_elemIndicesBB xs c = elemIndices c xs == P.elemIndices c (P.pack xs) + +prop_findIndexBB xs a = (findIndex (==a) xs) == (P.findIndex (==a) (P.pack xs)) + +prop_findIndiciesBB xs c = (findIndices (==c) xs) == (P.findIndices (==c) (P.pack xs)) + +-- example properties from QuickCheck.Batch +prop_sort1BB xs = sort xs == (P.unpack . P.sort . P.pack) xs +prop_sort2BB xs = (not (null xs)) ==> (P.head . P.sort . P.pack $ xs) == minimum xs +prop_sort3BB xs = (not (null xs)) ==> (P.last . P.sort . P.pack $ xs) == maximum xs +prop_sort4BB xs ys = + (not (null xs)) ==> + (not (null ys)) ==> + (P.head . P.sort) (P.append (P.pack xs) (P.pack ys)) == min (minimum xs) (minimum ys) +prop_sort5BB xs ys = + (not (null xs)) ==> + (not (null ys)) ==> + (P.last . P.sort) (P.append (P.pack xs) (P.pack ys)) == max (maximum xs) (maximum ys) + +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_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 )) + +-- prop_dropSpaceBB xs = dropWhile isSpace xs == C.unpack (C.dropSpace (C.pack xs)) +-- prop_dropSpaceEndBB xs = (C.reverse . (C.dropWhile isSpace) . C.reverse) (C.pack xs) == +-- (C.dropSpaceEnd (C.pack xs)) + +-- prop_breakSpaceBB xs = +-- (let (x,y) = C.breakSpace (C.pack xs) +-- in (C.unpack x, C.unpack y)) == (break isSpace xs) + +prop_spanEndBB xs = + (C.spanEnd (not . isSpace) (C.pack xs)) == + (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 = + (break (==c) xs) == + (let (x,y) = C.breakChar c (C.pack xs) in (C.unpack x, C.unpack y)) + +prop_spanCharBB c xs = + (break (/=c) xs) == + (let (x,y) = C.spanChar c (C.pack xs) in (C.unpack x, C.unpack y)) + +prop_spanChar_1BB c xs = + (C.span (==c) xs) == C.spanChar c xs + +prop_wordsBB' xs = + (C.unpack . C.unwords . C.words' . C.pack) xs == + (map (\c -> if isSpace c then ' ' else c) xs) + +-- prop_linesBB' xs = (C.unpack . C.unlines' . C.lines' . C.pack) xs == (xs) +-} + +prop_unfoldrBB c = + forAll arbitrarySizedIntegral $ \n -> + (fst $ C.unfoldrN n fn c) == (C.pack $ take n $ unfoldr fn c) + where + fn x = Just (x, chr (ord x + 1)) + +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)) + +prop_tailsBB xs = tails xs == map P.unpack (P.tails (P.pack xs)) + +prop_findSubstringsBB s x l + = C.findSubstrings (C.pack p) (C.pack s) == naive_findSubstrings 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_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 c = forAll arbitrarySizedIntegral $ \n -> + P.unpack (P.replicate n c) == replicate n c +prop_replicate2BB c = forAll arbitrarySizedIntegral $ \n -> + P.replicate n c == fst (P.unfoldrN n (\u -> Just (u,u)) c) + +prop_replicate3BB c = P.unpack (P.replicate 0 c) == replicate 0 c + +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 + +prop_readintegerBB n = (fst . fromJust . C.readInteger . C.pack . show) n == (n :: Integer) +prop_readintegerLL n = (fst . fromJust . D.readInteger . D.pack . show) n == (n :: Integer) + +prop_readinteger2BB s = + let s' = filter (\c -> c `notElem` ['0'..'9']) s + in C.readInteger (C.pack s') == Nothing + +-- prop_filterChar1BB c xs = (filter (==c) xs) == ((C.unpack . C.filterChar c . C.pack) xs) +-- prop_filterChar2BB c xs = (C.filter (==c) (C.pack xs)) == (C.filterChar c (C.pack xs)) +-- prop_filterChar3BB c xs = C.filterChar c xs == C.replicate (C.count c xs) c + +-- prop_filterNotChar1BB c xs = (filter (/=c) xs) == ((C.unpack . C.filterNotChar c . C.pack) xs) +-- prop_filterNotChar2BB c xs = (C.filter (/=c) (C.pack xs)) == (C.filterNotChar c (C.pack xs)) + +-- 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 + +------------------------------------------------------------------------ +-- +-- 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) + where + _ = start1 :: Int + _ = start2 :: Int + +prop_looploop em1 em2 start1 start2 arr = + loopU em2 start2 (loopArr (loopU em1 start1 arr)) == + loopSndAcc (loopU (em1 `fuseEFL` em2) (start1 :*: start2) arr) + where + _ = start1 :: Int + _ = start2 :: Int + +------------------------------------------------------------------------ + +-- check associativity of sequence loops +prop_sequenceloops_assoc n m o x y z a1 a2 a3 xs = + + k ((f * g) * h) == k (f * (g * h)) -- associativity + + where + (*) = sequenceLoops + f = (sel n) x a1 + g = (sel m) y a2 + h = (sel o) z a3 + + _ = a1 :: Int; _ = a2 :: Int; _ = a3 :: Int + k g = loopArr (loopWrapper g xs) + +-- check wrapper elimination +prop_loop_loop_wrapper_elimination n m x y a1 a2 xs = + loopWrapper g (loopArr (loopWrapper f xs)) == + loopSndAcc (loopWrapper (sequenceLoops f g) xs) + where + f = (sel n) x a1 + g = (sel m) y a2 + _ = a1 :: Int; _ = a2 :: Int + +sel :: Bool + -> (acc -> Word8 -> PairS acc (MaybeS Word8)) + -> acc + -> Ptr Word8 + -> Ptr Word8 + -> Int + -> IO (PairS (PairS acc Int) Int) +sel False = doDownLoop +sel True = doUpLoop + +------------------------------------------------------------------------ +-- +-- Test fusion forms +-- + +prop_up_up_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doUpLoop f1 acc1) (doUpLoop f2 acc2)) == + k (doUpLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int; k g = loopWrapper g xs + +prop_down_down_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doDownLoop f1 acc1) (doDownLoop f2 acc2)) == + k (doDownLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int ; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_noAcc_noAcc_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doNoAccLoop f1 acc1) (doNoAccLoop f2 acc2)) == + k (doNoAccLoop (f1 `fuseNoAccNoAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int ; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_noAcc_up_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doNoAccLoop f1 acc1) (doUpLoop f2 acc2)) == + k (doUpLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int; k g = loopWrapper g xs + +prop_up_noAcc_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doUpLoop f1 acc1) (doNoAccLoop f2 acc2)) == + k (doUpLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int; k g = loopWrapper g xs + +prop_noAcc_down_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doNoAccLoop f1 acc1) (doDownLoop f2 acc2)) == + k (doDownLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_down_noAcc_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doDownLoop f1 acc1) (doNoAccLoop f2 acc2)) == + k (doDownLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int; k g = loopWrapper g xs + +prop_map_map_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doMapLoop f1 acc1) (doMapLoop f2 acc2)) == + k (doMapLoop (f1 `fuseMapMapEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_filter_filter_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doFilterLoop f1 acc1) (doFilterLoop f2 acc2)) == + k (doFilterLoop (f1 `fuseFilterFilterEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_map_filter_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doMapLoop f1 acc1) (doFilterLoop f2 acc2)) == + k (doNoAccLoop (f1 `fuseMapFilterEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_filter_map_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doFilterLoop f1 acc1) (doMapLoop f2 acc2)) == + k (doNoAccLoop (f1 `fuseFilterMapEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_map_noAcc_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doMapLoop f1 acc1) (doNoAccLoop f2 acc2)) == + k (doNoAccLoop (f1 `fuseMapNoAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_noAcc_map_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doNoAccLoop f1 acc1) (doMapLoop f2 acc2)) == + k (doNoAccLoop (f1 `fuseNoAccMapEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_map_up_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doMapLoop f1 acc1) (doUpLoop f2 acc2)) == + k (doUpLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_up_map_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doUpLoop f1 acc1) (doMapLoop f2 acc2)) == + k (doUpLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_map_down_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doMapLoop f1 acc1) (doDownLoop f2 acc2)) == + k (doDownLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_down_map_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doDownLoop f1 acc1) (doMapLoop f2 acc2)) == + k (doDownLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_filter_noAcc_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doFilterLoop f1 acc1) (doNoAccLoop f2 acc2)) == + k (doNoAccLoop (f1 `fuseFilterNoAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_noAcc_filter_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doNoAccLoop f1 acc1) (doFilterLoop f2 acc2)) == + k (doNoAccLoop (f1 `fuseNoAccFilterEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_filter_up_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doFilterLoop f1 acc1) (doUpLoop f2 acc2)) == + k (doUpLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_up_filter_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doUpLoop f1 acc1) (doFilterLoop f2 acc2)) == + k (doUpLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_filter_down_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doFilterLoop f1 acc1) (doDownLoop f2 acc2)) == + k (doDownLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +prop_down_filter_loop_fusion f1 f2 acc1 acc2 xs = + k (sequenceLoops (doDownLoop f1 acc1) (doFilterLoop f2 acc2)) == + k (doDownLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2)) + where _ = acc1 :: Int; _ = acc2 :: Int ; k g = loopWrapper g xs + +------------------------------------------------------------------------ + +{- +prop_length_loop_fusion_1 f1 acc1 xs = + P.length (loopArr (loopWrapper (doUpLoop f1 acc1) xs)) == + P.lengthU (loopArr (loopWrapper (doUpLoop f1 acc1) xs)) + where _ = acc1 :: Int + +prop_length_loop_fusion_2 f1 acc1 xs = + P.length (loopArr (loopWrapper (doDownLoop f1 acc1) xs)) == + P.lengthU (loopArr (loopWrapper (doDownLoop f1 acc1) xs)) + where _ = acc1 :: Int + +prop_length_loop_fusion_3 f1 acc1 xs = + P.length (loopArr (loopWrapper (doMapLoop f1 acc1) xs)) == + P.lengthU (loopArr (loopWrapper (doMapLoop f1 acc1) xs)) + where _ = acc1 :: Int + +prop_length_loop_fusion_4 f1 acc1 xs = + P.length (loopArr (loopWrapper (doFilterLoop f1 acc1) xs)) == + P.lengthU (loopArr (loopWrapper (doFilterLoop f1 acc1) xs)) + 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 + +-- prop_join_spec c s1 s2 = +-- P.join (P.singleton c) (s1 : s2 : []) == P.joinWithByte c s1 s2 + +-- prop_break_spec x s = +-- P.break ((==) x) s == P.breakByte x s + +-- prop_span_spec x s = +-- P.span ((==) x) s == P.spanByte x s + +------------------------------------------------------------------------ + +-- Test IsString, Show, Read, pack, unpack +prop_isstring x = C.unpack (fromString x :: C.ByteString) == x +prop_isstring_lc x = LC.unpack (fromString x :: LC.ByteString) == x + +prop_showP1 x = show x == show (C.unpack x) +prop_showL1 x = show x == show (LC.unpack x) + +prop_readP1 x = read (show x) == (x :: P.ByteString) +prop_readP2 x = read (show x) == C.pack (x :: String) + +prop_readL1 x = read (show x) == (x :: L.ByteString) +prop_readL2 x = read (show x) == LC.pack (x :: String) + +prop_packunpack_s x = (P.unpack . P.pack) x == x +prop_unpackpack_s x = (P.pack . P.unpack) x == x + +prop_packunpack_c x = (C.unpack . C.pack) x == x +prop_unpackpack_c x = (C.pack . C.unpack) x == x + +prop_packunpack_l x = (L.unpack . L.pack) x == x +prop_unpackpack_l x = (L.pack . L.unpack) x == x + +prop_packunpack_lc x = (LC.unpack . LC.pack) x == x +prop_unpackpack_lc x = (LC.pack . LC.unpack) x == x + +prop_toFromChunks x = (L.fromChunks . L.toChunks) x == x +prop_fromToChunks x = (L.toChunks . L.fromChunks) x == filter (not . P.null) x + +prop_toFromStrict x = (L.fromStrict . L.toStrict) x == x +prop_fromToStrict x = (L.toStrict . L.fromStrict) x == x + +prop_packUptoLenBytes cs = + forAll (choose (0, length cs + 1)) $ \n -> + let (bs, cs') = P.packUptoLenBytes n cs + in P.length bs == min n (length cs) + && take n cs == P.unpack bs + && P.pack (take n cs) == bs + && drop n cs == cs' + +prop_packUptoLenChars cs = + forAll (choose (0, length cs + 1)) $ \n -> + let (bs, cs') = P.packUptoLenChars n cs + in P.length bs == min n (length cs) + && take n cs == C.unpack bs + && C.pack (take n cs) == bs + && drop n cs == cs' + +prop_unpack_s cs = + forAll (choose (0, length cs)) $ \n -> + P.unpack (P.drop n $ P.pack cs) == drop n cs +prop_unpack_c cs = + forAll (choose (0, length cs)) $ \n -> + C.unpack (C.drop n $ C.pack cs) == drop n cs + +prop_unpack_l cs = + forAll (choose (0, length cs)) $ \n -> + L.unpack (L.drop (fromIntegral n) $ L.pack cs) == drop n cs +prop_unpack_lc cs = + forAll (choose (0, length cs)) $ \n -> + LC.unpack (L.drop (fromIntegral n) $ LC.pack cs) == drop n cs + +prop_unpackBytes cs = + forAll (choose (0, length cs)) $ \n -> + P.unpackBytes (P.drop n $ P.pack cs) == drop n cs +prop_unpackChars cs = + forAll (choose (0, length cs)) $ \n -> + P.unpackChars (P.drop n $ C.pack cs) == drop n cs + +prop_unpackBytes_l = + forAll (sized $ \n -> resize (n * 10) arbitrary) $ \cs -> + forAll (choose (0, length cs)) $ \n -> + L.unpackBytes (L.drop (fromIntegral n) $ L.pack cs) == drop n cs +prop_unpackChars_l = + forAll (sized $ \n -> resize (n * 10) arbitrary) $ \cs -> + forAll (choose (0, length cs)) $ \n -> + L.unpackChars (L.drop (fromIntegral n) $ LC.pack cs) == drop n cs + +prop_unpackAppendBytesLazy cs' = + forAll (sized $ \n -> resize (n * 10) arbitrary) $ \cs -> + forAll (choose (0, 2)) $ \n -> + P.unpackAppendBytesLazy (P.drop n $ P.pack cs) cs' == drop n cs ++ cs' +prop_unpackAppendCharsLazy cs' = + forAll (sized $ \n -> resize (n * 10) arbitrary) $ \cs -> + forAll (choose (0, 2)) $ \n -> + P.unpackAppendCharsLazy (P.drop n $ C.pack cs) cs' == drop n cs ++ cs' + +prop_unpackAppendBytesStrict cs cs' = + forAll (choose (0, length cs)) $ \n -> + P.unpackAppendBytesStrict (P.drop n $ P.pack cs) cs' == drop n cs ++ cs' + +prop_unpackAppendCharsStrict cs cs' = + forAll (choose (0, length cs)) $ \n -> + P.unpackAppendCharsStrict (P.drop n $ C.pack cs) cs' == drop n cs ++ cs' + +------------------------------------------------------------------------ +-- Unsafe functions + +-- Test unsafePackAddress +prop_unsafePackAddress (CByteString 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 = L.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 (CByteString x) = unsafePerformIO $ do + y <- P.useAsCString x $ P.unsafePackCString + return (y == x) + +prop_packCString_safe (CByteString 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 (CByteString 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 = + P.length x > 0 ==> + 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_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 = defaultMain tests + +-- +-- And now a list of all the properties to test. +-- + +tests = misc_tests + ++ bl_tests + ++ cc_tests + ++ bp_tests + ++ pl_tests + ++ bb_tests + ++ ll_tests + ++ io_tests + ++ rules + +-- +-- 'morally sound' IO +-- +io_tests = + [ testProperty "readFile.writeFile" prop_read_write_file_P + , testProperty "readFile.writeFile" prop_read_write_file_C + , testProperty "readFile.writeFile" prop_read_write_file_L + , testProperty "readFile.writeFile" prop_read_write_file_D + + , testProperty "appendFile " prop_append_file_P + , testProperty "appendFile " prop_append_file_C + , testProperty "appendFile " prop_append_file_L + , testProperty "appendFile " prop_append_file_D + + , testProperty "packAddress " prop_packAddress + + ] + +misc_tests = + [ testProperty "packunpack" prop_packunpack_s + , testProperty "unpackpack" prop_unpackpack_s + , testProperty "packunpack" prop_packunpack_c + , testProperty "unpackpack" prop_unpackpack_c + , testProperty "packunpack" prop_packunpack_l + , testProperty "unpackpack" prop_unpackpack_l + , testProperty "packunpack" prop_packunpack_lc + , testProperty "unpackpack" prop_unpackpack_lc + , testProperty "unpack" prop_unpack_s + , testProperty "unpack" prop_unpack_c + , testProperty "unpack" prop_unpack_l + , testProperty "unpack" prop_unpack_lc + , testProperty "packUptoLenBytes" prop_packUptoLenBytes + , testProperty "packUptoLenChars" prop_packUptoLenChars + , testProperty "unpackBytes" prop_unpackBytes + , testProperty "unpackChars" prop_unpackChars + , testProperty "unpackBytes" prop_unpackBytes_l + , testProperty "unpackChars" prop_unpackChars_l + , testProperty "unpackAppendBytesLazy" prop_unpackAppendBytesLazy + , testProperty "unpackAppendCharsLazy" prop_unpackAppendCharsLazy + , testProperty "unpackAppendBytesStrict"prop_unpackAppendBytesStrict + , testProperty "unpackAppendCharsStrict"prop_unpackAppendCharsStrict + , testProperty "toFromChunks" prop_toFromChunks + , testProperty "fromToChunks" prop_fromToChunks + , testProperty "toFromStrict" prop_toFromStrict + , testProperty "fromToStrict" prop_fromToStrict + + , testProperty "invariant" prop_invariant + , testProperty "unsafe pack address" prop_unsafePackAddress + , testProperty "unsafe pack address len"prop_unsafePackAddressLen + , testProperty "unsafeUseAsCString" prop_unsafeUseAsCString + , testProperty "unsafeUseAsCStringLen" prop_unsafeUseAsCStringLen + , testProperty "useAsCString" prop_useAsCString + , testProperty "packCString" prop_packCString + , testProperty "packCString safe" prop_packCString_safe + , testProperty "packCStringLen" prop_packCStringLen + , testProperty "packCStringLen safe" prop_packCStringLen_safe + , testProperty "packCStringFinaliser" prop_packCStringFinaliser + , testProperty "packMallocString" prop_packMallocCString + , testProperty "unsafeFinalise" prop_unsafeFinalize + , testProperty "invariant" prop_internal_invariant + , testProperty "show 1" prop_showP1 + , testProperty "show 2" prop_showL1 + , testProperty "read 1" prop_readP1 + , testProperty "read 2" prop_readP2 + , testProperty "read 3" prop_readL1 + , testProperty "read 4" prop_readL2 + , testProperty "fromForeignPtr" prop_fromForeignPtr + ] + +------------------------------------------------------------------------ +-- ByteString.Lazy <=> List + +bl_tests = + [ testProperty "all" prop_allBL + , testProperty "any" prop_anyBL + , testProperty "append" prop_appendBL + , testProperty "compare" prop_compareBL + , testProperty "concat" prop_concatBL + , testProperty "cons" prop_consBL + , testProperty "eq" prop_eqBL + , testProperty "filter" prop_filterBL + , testProperty "find" prop_findBL + , testProperty "findIndex" prop_findIndexBL + , testProperty "findIndices" prop_findIndicesBL + , testProperty "foldl" prop_foldlBL + , testProperty "foldl'" prop_foldlBL' + , testProperty "foldl1" prop_foldl1BL + , testProperty "foldl1'" prop_foldl1BL' + , testProperty "foldr" prop_foldrBL + , testProperty "foldr1" prop_foldr1BL + , testProperty "mapAccumL" prop_mapAccumLBL + , testProperty "mapAccumR" prop_mapAccumRBL + , testProperty "mapAccumR" prop_mapAccumRDL + , testProperty "mapAccumR" prop_mapAccumRCC + , testProperty "unfoldr" prop_unfoldrBL + , testProperty "unfoldr" prop_unfoldrLC + , testProperty "unfoldr" prop_cycleLC + , testProperty "iterate" prop_iterateLC + , testProperty "iterate" prop_iterateLC_2 + , testProperty "iterate" prop_iterateL + , testProperty "repeat" prop_repeatLC + , testProperty "repeat" prop_repeatL + , testProperty "head" prop_headBL + , testProperty "init" prop_initBL + , testProperty "isPrefixOf" prop_isPrefixOfBL + , testProperty "last" prop_lastBL + , testProperty "length" prop_lengthBL + , testProperty "map" prop_mapBL + , testProperty "maximum" prop_maximumBL + , testProperty "minimum" prop_minimumBL + , testProperty "null" prop_nullBL + , testProperty "reverse" prop_reverseBL + , testProperty "snoc" prop_snocBL + , testProperty "tail" prop_tailBL + , testProperty "transpose" prop_transposeBL + , testProperty "replicate" prop_replicateBL + , testProperty "take" prop_takeBL + , testProperty "drop" prop_dropBL + , testProperty "splitAt" prop_splitAtBL + , testProperty "takeWhile" prop_takeWhileBL + , testProperty "dropWhile" prop_dropWhileBL + , testProperty "break" prop_breakBL + , testProperty "span" prop_spanBL + , testProperty "group" prop_groupBL + , testProperty "groupBy" prop_groupByBL + , testProperty "inits" prop_initsBL + , testProperty "tails" prop_tailsBL + , testProperty "elem" prop_elemBL + , testProperty "notElem" prop_notElemBL + , testProperty "lines" prop_linesBL + , testProperty "elemIndex" prop_elemIndexBL + , testProperty "elemIndices" prop_elemIndicesBL + , testProperty "concatMap" prop_concatMapBL + ] + +------------------------------------------------------------------------ +-- ByteString.Lazy <=> ByteString + +cc_tests = + [ testProperty "prop_concatCC" prop_concatCC + , testProperty "prop_nullCC" prop_nullCC + , testProperty "prop_reverseCC" prop_reverseCC + , testProperty "prop_transposeCC" prop_transposeCC + , testProperty "prop_groupCC" prop_groupCC + , testProperty "prop_groupByCC" prop_groupByCC + , testProperty "prop_initsCC" prop_initsCC + , testProperty "prop_tailsCC" prop_tailsCC + , testProperty "prop_allCC" prop_allCC + , testProperty "prop_anyCC" prop_anyCC + , testProperty "prop_appendCC" prop_appendCC + , testProperty "prop_breakCC" prop_breakCC + , testProperty "prop_concatMapCC" prop_concatMapCC + , testProperty "prop_consCC" prop_consCC + , testProperty "prop_consCC'" prop_consCC' + , testProperty "prop_unconsCC" prop_unconsCC + , testProperty "prop_countCC" prop_countCC + , testProperty "prop_dropCC" prop_dropCC + , testProperty "prop_dropWhileCC" prop_dropWhileCC + , testProperty "prop_filterCC" prop_filterCC + , testProperty "prop_findCC" prop_findCC + , testProperty "prop_findIndexCC" prop_findIndexCC + , testProperty "prop_findIndicesCC" prop_findIndicesCC + , testProperty "prop_isPrefixOfCC" prop_isPrefixOfCC + , testProperty "prop_mapCC" prop_mapCC + , testProperty "prop_replicateCC" prop_replicateCC + , testProperty "prop_snocCC" prop_snocCC + , testProperty "prop_spanCC" prop_spanCC + , testProperty "prop_splitCC" prop_splitCC + , testProperty "prop_splitAtCC" prop_splitAtCC + , testProperty "prop_takeCC" prop_takeCC + , testProperty "prop_takeWhileCC" prop_takeWhileCC + , testProperty "prop_elemCC" prop_elemCC + , testProperty "prop_notElemCC" prop_notElemCC + , testProperty "prop_elemIndexCC" prop_elemIndexCC + , testProperty "prop_elemIndicesCC" prop_elemIndicesCC + , testProperty "prop_lengthCC" prop_lengthCC + , testProperty "prop_headCC" prop_headCC + , testProperty "prop_initCC" prop_initCC + , testProperty "prop_lastCC" prop_lastCC + , testProperty "prop_maximumCC" prop_maximumCC + , testProperty "prop_minimumCC" prop_minimumCC + , testProperty "prop_tailCC" prop_tailCC + , testProperty "prop_foldl1CC" prop_foldl1CC + , testProperty "prop_foldl1CC'" prop_foldl1CC' + , testProperty "prop_foldr1CC" prop_foldr1CC + , testProperty "prop_foldr1CC'" prop_foldr1CC' + , testProperty "prop_scanlCC" prop_scanlCC + , testProperty "prop_intersperseCC" prop_intersperseCC + + , testProperty "prop_foldlCC" prop_foldlCC + , testProperty "prop_foldlCC'" prop_foldlCC' + , testProperty "prop_foldrCC" prop_foldrCC + , testProperty "prop_foldrCC'" prop_foldrCC' + , testProperty "prop_mapAccumLCC" prop_mapAccumLCC +-- , testProperty "prop_mapIndexedCC" prop_mapIndexedCC +-- , testProperty "prop_mapIndexedPL" prop_mapIndexedPL + ] + +bp_tests = + [ testProperty "all" prop_allBP + , testProperty "any" prop_anyBP + , testProperty "append" prop_appendBP + , testProperty "compare" prop_compareBP + , testProperty "concat" prop_concatBP + , testProperty "cons" prop_consBP + , testProperty "cons'" prop_consBP' + , testProperty "uncons" prop_unconsBP + , testProperty "eq" prop_eqBP + , testProperty "filter" prop_filterBP + , testProperty "find" prop_findBP + , testProperty "findIndex" prop_findIndexBP + , testProperty "findIndices" prop_findIndicesBP + , testProperty "foldl" prop_foldlBP + , testProperty "foldl'" prop_foldlBP' + , testProperty "foldl1" prop_foldl1BP + , testProperty "foldl1'" prop_foldl1BP' + , testProperty "foldr" prop_foldrBP + , testProperty "foldr'" prop_foldrBP' + , testProperty "foldr1" prop_foldr1BP + , testProperty "foldr1'" prop_foldr1BP' + , testProperty "mapAccumL" prop_mapAccumLBP +-- , testProperty "mapAccumL" prop_mapAccumL_mapIndexedBP + , testProperty "unfoldr" prop_unfoldrBP + , testProperty "unfoldr 2" prop_unfoldr2BP + , testProperty "unfoldr 2" prop_unfoldr2CP + , testProperty "head" prop_headBP + , testProperty "init" prop_initBP + , testProperty "isPrefixOf" prop_isPrefixOfBP + , testProperty "last" prop_lastBP + , testProperty "length" prop_lengthBP + , testProperty "readInt" prop_readIntBP + , testProperty "lines" prop_linesBP + , testProperty "lines \\n" prop_linesNLBP + , testProperty "map" prop_mapBP + , testProperty "maximum " prop_maximumBP + , testProperty "minimum" prop_minimumBP + , testProperty "null" prop_nullBP + , testProperty "reverse" prop_reverseBP + , testProperty "snoc" prop_snocBP + , testProperty "tail" prop_tailBP + , testProperty "scanl" prop_scanlBP + , testProperty "transpose" prop_transposeBP + , testProperty "replicate" prop_replicateBP + , testProperty "take" prop_takeBP + , testProperty "drop" prop_dropBP + , testProperty "splitAt" prop_splitAtBP + , testProperty "takeWhile" prop_takeWhileBP + , testProperty "dropWhile" prop_dropWhileBP + , testProperty "break" prop_breakBP + , testProperty "span" prop_spanBP + , testProperty "split" prop_splitBP + , testProperty "count" prop_countBP + , testProperty "group" prop_groupBP + , testProperty "groupBy" prop_groupByBP + , testProperty "inits" prop_initsBP + , testProperty "tails" prop_tailsBP + , testProperty "elem" prop_elemBP + , testProperty "notElem" prop_notElemBP + , testProperty "elemIndex" prop_elemIndexBP + , testProperty "elemIndices" prop_elemIndicesBP + , testProperty "intersperse" prop_intersperseBP + , testProperty "concatMap" prop_concatMapBP + ] + +------------------------------------------------------------------------ +-- ByteString <=> List + +pl_tests = + [ testProperty "all" prop_allPL + , testProperty "any" prop_anyPL + , testProperty "append" prop_appendPL + , testProperty "compare" prop_comparePL + , testProperty "concat" prop_concatPL + , testProperty "cons" prop_consPL + , testProperty "eq" prop_eqPL + , testProperty "filter" prop_filterPL + , testProperty "filter rules"prop_filterPL_rule + , testProperty "filter rules"prop_filterLC_rule + , testProperty "partition" prop_partitionPL + , testProperty "partition" prop_partitionLL + , testProperty "find" prop_findPL + , testProperty "findIndex" prop_findIndexPL + , testProperty "findIndices" prop_findIndicesPL + , testProperty "foldl" prop_foldlPL + , testProperty "foldl'" prop_foldlPL' + , testProperty "foldl1" prop_foldl1PL + , testProperty "foldl1'" prop_foldl1PL' + , testProperty "foldr1" prop_foldr1PL + , testProperty "foldr" prop_foldrPL + , testProperty "mapAccumL" prop_mapAccumLPL + , testProperty "mapAccumR" prop_mapAccumRPL + , testProperty "unfoldr" prop_unfoldrPL + , testProperty "scanl" prop_scanlPL + , testProperty "scanl1" prop_scanl1PL + , testProperty "scanl1" prop_scanl1CL + , testProperty "scanr" prop_scanrCL + , testProperty "scanr" prop_scanrPL + , testProperty "scanr1" prop_scanr1PL + , testProperty "scanr1" prop_scanr1CL + , testProperty "head" prop_headPL + , testProperty "init" prop_initPL + , testProperty "last" prop_lastPL + , testProperty "maximum" prop_maximumPL + , testProperty "minimum" prop_minimumPL + , testProperty "tail" prop_tailPL + , testProperty "zip" prop_zipPL + , testProperty "zip" prop_zipLL + , testProperty "zip" prop_zipCL + , testProperty "unzip" prop_unzipPL + , testProperty "unzip" prop_unzipLL + , testProperty "unzip" prop_unzipCL + , testProperty "zipWith" prop_zipWithPL +-- , testProperty "zipWith" prop_zipWithCL + , testProperty "zipWith rules" prop_zipWithPL_rules +-- , testProperty "zipWith/zipWith'" prop_zipWithPL' + + , testProperty "isPrefixOf" prop_isPrefixOfPL + , testProperty "isInfixOf" prop_isInfixOfPL + , testProperty "length" prop_lengthPL + , testProperty "map" prop_mapPL + , testProperty "null" prop_nullPL + , testProperty "reverse" prop_reversePL + , testProperty "snoc" prop_snocPL + , testProperty "transpose" prop_transposePL + , testProperty "replicate" prop_replicatePL + , testProperty "take" prop_takePL + , testProperty "drop" prop_dropPL + , testProperty "splitAt" prop_splitAtPL + , testProperty "takeWhile" prop_takeWhilePL + , testProperty "dropWhile" prop_dropWhilePL + , testProperty "break" prop_breakPL + , testProperty "span" prop_spanPL + , testProperty "group" prop_groupPL + , testProperty "groupBy" prop_groupByPL + , testProperty "inits" prop_initsPL + , testProperty "tails" prop_tailsPL + , testProperty "elem" prop_elemPL + , testProperty "notElem" prop_notElemPL + , testProperty "lines" prop_linesPL + , testProperty "elemIndex" prop_elemIndexPL + , testProperty "elemIndex" prop_elemIndexCL + , testProperty "elemIndices" prop_elemIndicesPL + , testProperty "concatMap" prop_concatMapPL + , testProperty "IsString" prop_isstring + , testProperty "IsString LC" prop_isstring_lc + ] + +------------------------------------------------------------------------ +-- extra ByteString properties + +bb_tests = + [ testProperty "bijection" prop_bijectionBB + , testProperty "bijection'" prop_bijectionBB' + , testProperty "pack/unpack" prop_packunpackBB + , testProperty "unpack/pack" prop_packunpackBB' + , testProperty "eq 1" prop_eq1BB + , testProperty "eq 2" prop_eq2BB + , testProperty "eq 3" prop_eq3BB + , testProperty "compare 1" prop_compare1BB + , testProperty "compare 2" prop_compare2BB + , testProperty "compare 3" prop_compare3BB + , testProperty "compare 4" prop_compare4BB + , testProperty "compare 5" prop_compare5BB + , testProperty "compare 6" prop_compare6BB + , testProperty "compare 7" prop_compare7BB + , testProperty "compare 7" prop_compare7LL + , testProperty "compare 8" prop_compare8BB + , testProperty "empty 1" prop_nil1BB + , testProperty "empty 2" prop_nil2BB + , testProperty "empty 1 monoid" prop_nil1LL_monoid + , testProperty "empty 2 monoid" prop_nil2LL_monoid + , testProperty "empty 1 monoid" prop_nil1BB_monoid + , testProperty "empty 2 monoid" prop_nil2BB_monoid + + , testProperty "null" prop_nullBB + , testProperty "length 1" prop_lengthBB + , testProperty "length 2" prop_lengthSBB + , testProperty "cons 1" prop_consBB + , testProperty "cons 2" prop_cons1BB + , testProperty "cons 3" prop_cons2BB + , testProperty "cons 4" prop_cons3BB + , testProperty "cons 5" prop_cons4BB + , testProperty "snoc" prop_snoc1BB + , testProperty "head 1" prop_head1BB + , testProperty "head 2" prop_head2BB + , testProperty "head 3" prop_head3BB + , testProperty "tail" prop_tailBB + , testProperty "tail 1" prop_tail1BB + , testProperty "last" prop_lastBB + , testProperty "init" prop_initBB + , testProperty "append 1" prop_append1BB + , testProperty "append 2" prop_append2BB + , testProperty "append 3" prop_append3BB + , testProperty "mappend 1" prop_append1BB_monoid + , testProperty "mappend 2" prop_append2BB_monoid + , testProperty "mappend 3" prop_append3BB_monoid + + , testProperty "map 1" prop_map1BB + , testProperty "map 2" prop_map2BB + , testProperty "map 3" prop_map3BB + , testProperty "filter1" prop_filter1BB + , testProperty "filter2" prop_filter2BB + , testProperty "map fusion" prop_mapfusionBB + , testProperty "filter fusion" prop_filterfusionBB + , testProperty "reverse 1" prop_reverse1BB + , testProperty "reverse 2" prop_reverse2BB + , testProperty "reverse 3" prop_reverse3BB + , testProperty "foldl 1" prop_foldl1BB + , testProperty "foldl 2" prop_foldl2BB + , testProperty "foldr 1" prop_foldr1BB + , testProperty "foldr 2" prop_foldr2BB + , testProperty "foldl1 1" prop_foldl1_1BB + , testProperty "foldl1 2" prop_foldl1_2BB + , testProperty "foldl1 3" prop_foldl1_3BB + , testProperty "foldr1 1" prop_foldr1_1BB + , testProperty "foldr1 2" prop_foldr1_2BB + , testProperty "foldr1 3" prop_foldr1_3BB + , testProperty "scanl/foldl" prop_scanlfoldlBB + , testProperty "all" prop_allBB + , testProperty "any" prop_anyBB + , testProperty "take" prop_takeBB + , testProperty "drop" prop_dropBB + , testProperty "takeWhile" prop_takeWhileBB + , testProperty "dropWhile" prop_dropWhileBB + , testProperty "dropWhile" prop_dropWhileCC_isSpace + , testProperty "splitAt" prop_splitAtBB + , testProperty "span" prop_spanBB + , testProperty "break" prop_breakBB + , testProperty "elem" prop_elemBB + , testProperty "notElem" prop_notElemBB + + , testProperty "concat 1" prop_concat1BB + , testProperty "concat 2" prop_concat2BB + , testProperty "concat 3" prop_concatBB + , testProperty "mconcat 1" prop_concat1BB_monoid + , testProperty "mconcat 2" prop_concat2BB_monoid + , testProperty "mconcat 3" prop_concatBB_monoid + + , testProperty "mconcat 1" prop_concat1LL_monoid + , testProperty "mconcat 2" prop_concat2LL_monoid + , testProperty "mconcat 3" prop_concatLL_monoid + + , testProperty "lines" prop_linesBB + , testProperty "unlines" prop_unlinesBB + , testProperty "unlines" prop_unlinesLC + , testProperty "words" prop_wordsBB + , testProperty "words" prop_wordsLC + , testProperty "unwords" prop_unwordsBB + , testProperty "group" prop_groupBB + , testProperty "groupBy 0" prop_groupByBB + , testProperty "groupBy 1" prop_groupBy1CC + , testProperty "groupBy 2" prop_groupBy1BB + , testProperty "groupBy 3" prop_groupBy2CC + , testProperty "join" prop_joinBB + , testProperty "elemIndex 1" prop_elemIndex1BB + , testProperty "elemIndex 2" prop_elemIndex2BB + , testProperty "findIndex" prop_findIndexBB + , testProperty "findIndicies" prop_findIndiciesBB + , testProperty "elemIndices" prop_elemIndicesBB + , testProperty "find" prop_findBB + , testProperty "find/findIndex" prop_find_findIndexBB + , testProperty "sort 1" prop_sort1BB + , testProperty "sort 2" prop_sort2BB + , testProperty "sort 3" prop_sort3BB + , testProperty "sort 4" prop_sort4BB + , testProperty "sort 5" prop_sort5BB + , testProperty "intersperse" prop_intersperseBB + , testProperty "maximum" prop_maximumBB + , testProperty "minimum" prop_minimumBB +-- , testProperty "breakChar" prop_breakCharBB +-- , testProperty "spanChar 1" prop_spanCharBB +-- , testProperty "spanChar 2" prop_spanChar_1BB +-- , testProperty "breakSpace" prop_breakSpaceBB +-- , testProperty "dropSpace" prop_dropSpaceBB + , testProperty "spanEnd" prop_spanEndBB + , testProperty "breakEnd" prop_breakEndBB + , testProperty "breakEnd" prop_breakEndCC + , testProperty "elemIndexEnd 1" prop_elemIndexEnd1BB + , testProperty "elemIndexEnd 1" prop_elemIndexEnd1CC + , testProperty "elemIndexEnd 2" prop_elemIndexEnd2BB +-- , testProperty "words'" prop_wordsBB' +-- , testProperty "lines'" prop_linesBB' +-- , testProperty "dropSpaceEnd" prop_dropSpaceEndBB + , testProperty "unfoldr" prop_unfoldrBB + , testProperty "prefix" prop_prefixBB + , testProperty "suffix" prop_suffixBB + , testProperty "suffix" prop_suffixLL + , testProperty "copy" prop_copyBB + , testProperty "copy" prop_copyLL + , testProperty "inits" prop_initsBB + , testProperty "tails" prop_tailsBB + , testProperty "findSubstrings "prop_findSubstringsBB + , testProperty "findSubstring "prop_findSubstringBB + , testProperty "breakSubstring 1"prop_breakSubstringBB + , testProperty "breakSubstring 2"prop_breakSubstring_findSubstring + , testProperty "breakSubstring 3"prop_breakSubstring_isInfixOf + + , testProperty "replicate1" prop_replicate1BB + , testProperty "replicate2" prop_replicate2BB + , testProperty "replicate3" prop_replicate3BB + , testProperty "readInt" prop_readintBB + , testProperty "readInt 2" prop_readint2BB + , testProperty "readInteger" prop_readintegerBB + , testProperty "readInteger 2" prop_readinteger2BB + , testProperty "read" prop_readLL + , testProperty "read" prop_readBB + , testProperty "Lazy.readInt" prop_readintLL + , testProperty "Lazy.readInt" prop_readintLL + , testProperty "Lazy.readInteger" prop_readintegerLL + , testProperty "mconcat 1" prop_append1LL_monoid + , testProperty "mconcat 2" prop_append2LL_monoid + , testProperty "mconcat 3" prop_append3LL_monoid +-- , testProperty "filterChar1" prop_filterChar1BB +-- , testProperty "filterChar2" prop_filterChar2BB +-- , testProperty "filterChar3" prop_filterChar3BB +-- , testProperty "filterNotChar1" prop_filterNotChar1BB +-- , testProperty "filterNotChar2" prop_filterNotChar2BB + , testProperty "tail" prop_tailSBB + , testProperty "index" prop_indexBB + , testProperty "unsafeIndex" prop_unsafeIndexBB +-- , testProperty "map'" prop_mapBB' + , testProperty "filter" prop_filterBB + , testProperty "elem" prop_elemSBB + , testProperty "take" prop_takeSBB + , testProperty "drop" prop_dropSBB + , testProperty "splitAt" prop_splitAtSBB + , testProperty "foldl" prop_foldlBB + , testProperty "foldr" prop_foldrBB + , testProperty "takeWhile " prop_takeWhileSBB + , testProperty "dropWhile " prop_dropWhileSBB + , testProperty "span " prop_spanSBB + , testProperty "break " prop_breakSBB + , testProperty "breakspan" prop_breakspan_1BB + , testProperty "lines " prop_linesSBB + , testProperty "unlines " prop_unlinesSBB + , testProperty "words " prop_wordsSBB + , testProperty "unwords " prop_unwordsSBB + , testProperty "unwords " prop_unwordsSLC +-- , testProperty "wordstokens" prop_wordstokensBB + , testProperty "splitWith" prop_splitWithBB + , testProperty "joinsplit" prop_joinsplitBB + , testProperty "intercalate" prop_intercalatePL +-- , testProperty "lineIndices" prop_lineIndices1BB + , testProperty "count" prop_countBB +-- , testProperty "linessplit" prop_linessplit2BB + , testProperty "splitsplitWith" prop_splitsplitWithBB +-- , testProperty "joinjoinpath" prop_joinjoinpathBB + , testProperty "zip" prop_zipBB + , testProperty "zip" prop_zipLC + , testProperty "zip1" prop_zip1BB + , testProperty "zipWith" prop_zipWithBB + , testProperty "zipWith" prop_zipWithCC + , testProperty "zipWith" prop_zipWithLC +-- , testProperty "zipWith'" prop_zipWith'BB + , testProperty "unzip" prop_unzipBB + , testProperty "concatMap" prop_concatMapBB +-- , testProperty "join/joinByte" prop_join_spec +-- , testProperty "span/spanByte" prop_span_spec +-- , testProperty "break/breakByte"prop_break_spec + ] + +------------------------------------------------------------------------ +-- Fusion rules + +{- +fusion_tests = +-- v1 fusion + [ ("lazy loop/loop fusion" prop_lazylooploop + , ("loop/loop fusion" prop_looploop + +-- v2 fusion + , testProperty "loop/loop wrapper elim" prop_loop_loop_wrapper_elimination + , testProperty "sequence association" prop_sequenceloops_assoc + + , testProperty "up/up loop fusion" prop_up_up_loop_fusion + , testProperty "down/down loop fusion" prop_down_down_loop_fusion + , testProperty "noAcc/noAcc loop fusion" prop_noAcc_noAcc_loop_fusion + , testProperty "noAcc/up loop fusion" prop_noAcc_up_loop_fusion + , testProperty "up/noAcc loop fusion" prop_up_noAcc_loop_fusion + , testProperty "noAcc/down loop fusion" prop_noAcc_down_loop_fusion + , testProperty "down/noAcc loop fusion" prop_down_noAcc_loop_fusion + , testProperty "map/map loop fusion" prop_map_map_loop_fusion + , testProperty "filter/filter loop fusion" prop_filter_filter_loop_fusion + , testProperty "map/filter loop fusion" prop_map_filter_loop_fusion + , testProperty "filter/map loop fusion" prop_filter_map_loop_fusion + , testProperty "map/noAcc loop fusion" prop_map_noAcc_loop_fusion + , testProperty "noAcc/map loop fusion" prop_noAcc_map_loop_fusion + , testProperty "map/up loop fusion" prop_map_up_loop_fusion + , testProperty "up/map loop fusion" prop_up_map_loop_fusion + , testProperty "map/down loop fusion" prop_map_down_fusion + , testProperty "down/map loop fusion" prop_down_map_loop_fusion + , testProperty "filter/noAcc loop fusion" prop_filter_noAcc_loop_fusion + , testProperty "noAcc/filter loop fusion" prop_noAcc_filter_loop_fusion + , testProperty "filter/up loop fusion" prop_filter_up_loop_fusion + , testProperty "up/filter loop fusion" prop_up_filter_loop_fusion + , testProperty "filter/down loop fusion" prop_filter_down_fusion + , testProperty "down/filter loop fusion" prop_down_filter_loop_fusion + +{- + , testProperty "length/loop fusion" prop_length_loop_fusion_1 + , testProperty "length/loop fusion" prop_length_loop_fusion_2 + , testProperty "length/loop fusion" prop_length_loop_fusion_3 + , testProperty "length/loop fusion" prop_length_loop_fusion_4 +-} + +-- , testProperty "zipwith/spec" prop_zipwith_spec + ] + +-} + + +------------------------------------------------------------------------ +-- Extra lazy properties + +ll_tests = + [ testProperty "eq 1" prop_eq1 + , testProperty "eq 2" prop_eq2 + , testProperty "eq 3" prop_eq3 + , testProperty "eq refl" prop_eq_refl + , testProperty "eq symm" prop_eq_symm + , testProperty "compare 1" prop_compare1 + , testProperty "compare 2" prop_compare2 + , testProperty "compare 3" prop_compare3 + , testProperty "compare 4" prop_compare4 + , testProperty "compare 5" prop_compare5 + , testProperty "compare 6" prop_compare6 + , testProperty "compare 7" prop_compare7 + , testProperty "compare 8" prop_compare8 + , testProperty "empty 1" prop_empty1 + , testProperty "empty 2" prop_empty2 + , testProperty "pack/unpack" prop_packunpack + , testProperty "unpack/pack" prop_unpackpack + , testProperty "null" prop_null + , testProperty "length 1" prop_length1 + , testProperty "length 2" prop_length2 + , testProperty "cons 1" prop_cons1 + , testProperty "cons 2" prop_cons2 + , testProperty "cons 3" prop_cons3 + , testProperty "cons 4" prop_cons4 + , testProperty "snoc" prop_snoc1 + , testProperty "head/pack" prop_head + , testProperty "head/unpack" prop_head1 + , testProperty "tail/pack" prop_tail + , testProperty "tail/unpack" prop_tail1 + , testProperty "last" prop_last + , testProperty "init" prop_init + , testProperty "append 1" prop_append1 + , testProperty "append 2" prop_append2 + , testProperty "append 3" prop_append3 + , testProperty "map 1" prop_map1 + , testProperty "map 2" prop_map2 + , testProperty "map 3" prop_map3 + , testProperty "filter 1" prop_filter1 + , testProperty "filter 2" prop_filter2 + , testProperty "reverse" prop_reverse + , testProperty "reverse1" prop_reverse1 + , testProperty "reverse2" prop_reverse2 + , testProperty "transpose" prop_transpose + , testProperty "foldl" prop_foldl + , testProperty "foldl/reverse" prop_foldl_1 + , testProperty "foldr" prop_foldr + , testProperty "foldr/id" prop_foldr_1 + , testProperty "foldl1/foldl" prop_foldl1_1 + , testProperty "foldl1/head" prop_foldl1_2 + , testProperty "foldl1/tail" prop_foldl1_3 + , testProperty "foldr1/foldr" prop_foldr1_1 + , testProperty "foldr1/last" prop_foldr1_2 + , testProperty "foldr1/head" prop_foldr1_3 + , testProperty "concat 1" prop_concat1 + , testProperty "concat 2" prop_concat2 + , testProperty "concat/pack" prop_concat3 + , testProperty "any" prop_any + , testProperty "all" prop_all + , testProperty "maximum" prop_maximum + , testProperty "minimum" prop_minimum + , testProperty "replicate 1" prop_replicate1 + , testProperty "replicate 2" prop_replicate2 + , testProperty "take" prop_take1 + , testProperty "drop" prop_drop1 + , testProperty "splitAt" prop_drop1 + , testProperty "takeWhile" prop_takeWhile + , testProperty "dropWhile" prop_dropWhile + , testProperty "break" prop_break + , testProperty "span" prop_span + , testProperty "splitAt" prop_splitAt + , testProperty "break/span" prop_breakspan +-- , testProperty "break/breakByte" prop_breakByte +-- , testProperty "span/spanByte" prop_spanByte + , testProperty "split" prop_split + , testProperty "splitWith" prop_splitWith + , testProperty "splitWith" prop_splitWith_D + , testProperty "splitWith" prop_splitWith_C + , testProperty "join.split/id" prop_joinsplit +-- , testProperty "join/joinByte" prop_joinjoinByte + , testProperty "group" prop_group + , testProperty "groupBy" prop_groupBy + , testProperty "groupBy" prop_groupBy_LC + , testProperty "index" prop_index + , testProperty "index" prop_index_D + , testProperty "index" prop_index_C + , testProperty "elemIndex" prop_elemIndex + , testProperty "elemIndices" prop_elemIndices + , testProperty "count/elemIndices" prop_count + , testProperty "findIndex" prop_findIndex + , testProperty "findIndices" prop_findIndicies + , testProperty "find" prop_find + , testProperty "find/findIndex" prop_find_findIndex + , testProperty "elem" prop_elem + , testProperty "notElem" prop_notElem + , testProperty "elem/notElem" prop_elem_notelem +-- , testProperty "filterByte 1" prop_filterByte +-- , testProperty "filterByte 2" prop_filterByte2 +-- , testProperty "filterNotByte 1" prop_filterNotByte +-- , testProperty "filterNotByte 2" prop_filterNotByte2 + , testProperty "isPrefixOf" prop_isPrefixOf + , testProperty "concatMap" prop_concatMap + , testProperty "isSpace" prop_isSpaceWord8 ] diff --git a/tests/builder/TestSuite.hs b/tests/builder/TestSuite.hs new file mode 100644 --- /dev/null +++ b/tests/builder/TestSuite.hs @@ -0,0 +1,21 @@ +module Main where + +--import Test.Framework (defaultMain, Test, testGroup) + +import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Tests +import qualified Data.ByteString.Lazy.Builder.Tests +import TestFramework + + +main :: IO () +main = defaultMain tests + +tests :: [Test] +tests = + [ testGroup "Data.ByteString.Lazy.Builder" + Data.ByteString.Lazy.Builder.Tests.tests + + , testGroup "Data.ByteString.Lazy.Builder.BasicEncoding" + Data.ByteString.Lazy.Builder.BasicEncoding.Tests.tests + ] +