bytestring 0.10.0.0 → 0.10.0.1
raw patch · 10 files changed
+1648/−59 lines, 10 filesdep +randomdep ~QuickCheckdep ~basedep ~deepseq
Dependencies added: random
Dependency ranges changed: QuickCheck, base, deepseq, directory, mtl
Files
- Data/ByteString.hs +4/−3
- Data/ByteString/Internal.hs +0/−11
- bytestring.cabal +25/−33
- include/fpstring.h +0/−12
- tests/QuickCheckUtils.hs +203/−0
- tests/Rules.hs +32/−0
- tests/TestFramework.hs +67/−0
- tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/TestUtils.hs +344/−0
- tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/Tests.hs +337/−0
- tests/builder/Data/ByteString/Lazy/Builder/Tests.hs +636/−0
Data/ByteString.hs view
@@ -809,7 +809,7 @@ -- -- The following equation relates 'unfoldrN' and 'unfoldr': ----- > snd (unfoldrN n f s) == take n (unfoldr f s)+-- > fst (unfoldrN n f s) == take n (unfoldr f s) -- unfoldrN :: Int -> (a -> Maybe (Word8, a)) -> a -> (ByteString, Maybe a) unfoldrN i f x0@@ -1489,6 +1489,7 @@ zipWith f ps qs | null ps || null qs = [] | otherwise = f (unsafeHead ps) (unsafeHead qs) : zipWith f (unsafeTail ps) (unsafeTail qs)+{-# NOINLINE [1] zipWith #-} -- -- | A specialised version of zipWith for the common case of a@@ -1774,6 +1775,7 @@ memcpy_ptr_baoff p buf (fromIntegral start) (fromIntegral len) return () +memcpy_ptr_baoff dst src src_off sz = memcpy dst (src+src_off) sz #endif mkBigPS :: Int -> [ByteString] -> IO ByteString@@ -1796,13 +1798,12 @@ -- Note: on Windows and with Haskell implementation other than GHC, this -- function does not work correctly; it behaves identically to 'hPut'. ---#if defined(__GLASGOW_HASKELL__) hPutNonBlocking :: Handle -> ByteString -> IO ByteString+#if defined(__GLASGOW_HASKELL__) hPutNonBlocking h bs@(PS ps s l) = do bytesWritten <- withForeignPtr ps $ \p-> hPutBufNonBlocking h (p `plusPtr` s) l return $! drop bytesWritten bs #else-hPutNonBlocking :: Handle -> B.ByteString -> IO Int hPutNonBlocking h bs = hPut h bs >> return empty #endif
Data/ByteString/Internal.hs view
@@ -63,10 +63,6 @@ c_maximum, -- :: Ptr Word8 -> CInt -> IO Word8 c_minimum, -- :: Ptr Word8 -> CInt -> IO Word8 c_count, -- :: Ptr Word8 -> CInt -> Word8 -> IO CInt-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 611- -- * Internal GHC magic- memcpy_ptr_baoff, -- :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ())-#endif -- * Chars w2c, c2w, isSpaceWord8, isSpaceChar8@@ -584,10 +580,3 @@ foreign import ccall unsafe "static fpstring.h fps_count" c_count :: Ptr Word8 -> CULong -> Word8 -> IO CULong --- ------------------------------------------------------------------------ Internal GHC Haskell magic--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 611-foreign import ccall unsafe "__hscore_memcpy_src_off"- memcpy_ptr_baoff :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ())-#endif
bytestring.cabal view
@@ -1,5 +1,5 @@ Name: bytestring-Version: 0.10.0.0+Version: 0.10.0.1 Synopsis: Fast, compact, strict and lazy byte strings with a list interface Description: An efficient compact, immutable byte string type (both strict and lazy)@@ -36,7 +36,7 @@ License-file: LICENSE Category: Data Copyright: Copyright (c) Don Stewart 2005-2009,- (c) Duncan Coutts 2006-2011,+ (c) Duncan Coutts 2006-2012, (c) David Roundy 2003-2005, (c) Jasper Van der Jeugt 2010, (c) Simon Meier 2010-2011.@@ -47,8 +47,7 @@ Duncan Coutts <duncan@community.haskell.org> 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+Tested-With: GHC==7.6.1, GHC==7.4.1, GHC==7.0.4, GHC==6.12.3 Build-Type: Simple Cabal-Version: >= 1.8 extra-source-files: README TODO@@ -58,10 +57,7 @@ location: http://darcs.haskell.org/bytestring/ library- build-depends: base >= 3 && < 5, deepseq-- if impl(ghc >= 6.10)- build-depends: ghc-prim, base >= 4+ build-depends: base >= 4.2 && < 5, ghc-prim, deepseq exposed-modules: Data.ByteString Data.ByteString.Char8@@ -92,23 +88,19 @@ extensions: CPP, ForeignFunctionInterface, BangPatterns-- if impl(ghc)- extensions: UnliftedFFITypes,- MagicHash,- UnboxedTuples,- DeriveDataTypeable- ScopedTypeVariables- Rank2Types- if impl(ghc >= 6.11)- extensions: NamedFieldPuns+ UnliftedFFITypes,+ MagicHash,+ UnboxedTuples,+ DeriveDataTypeable+ ScopedTypeVariables+ Rank2Types+ NamedFieldPuns ghc-options: -Wall -O2 -fmax-simplifier-iterations=10 -fdicts-cheap- if impl(ghc >= 6.10)- ghc-options: -fspec-constr-count=6+ -fspec-constr-count=6 c-sources: cbits/fpstring.c cbits/itoa.c@@ -116,38 +108,38 @@ includes: fpstring.h install-includes: fpstring.h - nhc98-options: -K4M -K3M -- QC properties, with GHC RULES disabled test-suite prop-compiled type: exitcode-stdio-1.0 main-is: Properties.hs+ other-modules: Rules+ QuickCheckUtils+ TestFramework hs-source-dirs: . tests- build-depends: base, deepseq, random, directory,+ build-depends: base, ghc-prim, 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+ -fno-enable-rewrite-rules extensions: BangPatterns- if impl(ghc)- extensions: UnliftedFFITypes,+ UnliftedFFITypes, MagicHash, UnboxedTuples, DeriveDataTypeable ScopedTypeVariables- if impl(ghc >= 6.11)- extensions: NamedFieldPuns+ NamedFieldPuns test-suite test-builder type: exitcode-stdio-1.0 hs-source-dirs: . tests tests/builder main-is: TestSuite.hs+ other-modules: Data.ByteString.Lazy.Builder.Tests+ Data.ByteString.Lazy.Builder.BasicEncoding.Tests+ Data.ByteString.Lazy.Builder.BasicEncoding.TestUtils+ Data.ByteString.Lazy.Builder.BasicEncoding.Extras+ TestFramework build-depends: base, ghc-prim, deepseq,@@ -155,7 +147,7 @@ byteorder == 1.0.*, dlist == 0.5.*, directory >= 1.0 && < 1.2,- mtl == 2.0.*+ mtl >= 2.0 && < 2.2 ghc-options: -Wall -fwarn-tabs
include/fpstring.h view
@@ -7,15 +7,3 @@ 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); }--
+ tests/QuickCheckUtils.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE CPP, MultiParamTypeClasses,+ FlexibleInstances, TypeSynonymInstances #-}+--+-- Uses multi-param type classes+--+module QuickCheckUtils where++import Test.QuickCheck+import Text.Show.Functions++import Control.Monad ( liftM2 )+import Control.Monad.Instances+import Data.Char+import Data.List+import Data.Word+import Data.Int+import System.Random+import System.IO+import Foreign.C (CChar)++import qualified Data.ByteString as P+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Internal as L (checkInvariant,ByteString(..))++import qualified Data.ByteString.Char8 as PC+import qualified Data.ByteString.Lazy.Char8 as LC++------------------------------------------------------------------------++adjustSize :: Testable prop => (Int -> Int) -> prop -> Property+adjustSize f p = sized $ \sz -> resize (f sz) (property p)++------------------------------------------------------------------------++{-++-- HUGS needs: ++instance Functor ((->) r) where+ fmap = (.)++instance (Arbitrary a) => Arbitrary (Maybe a) where+ arbitrary = sized arbMaybe+ where+ arbMaybe 0 = return Nothing+ arbMaybe n = fmap Just (resize (n-1) arbitrary)+ coarbitrary Nothing = variant 0+ coarbitrary (Just x) = variant 1 . coarbitrary x++instance Monad ((->) r) where+ return = const+ f >>= k = \ r -> k (f r) r++instance Functor ((,) a) where+ fmap f (x,y) = (x, f y)++instance Functor (Either a) where+ fmap _ (Left x) = Left x+ fmap f (Right y) = Right (f y)++-}++------------------------------------------------------------------------++integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)+integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,+ fromIntegral b :: Integer) g of+ (x,g) -> (fromIntegral x, g)++instance Arbitrary L.ByteString where+ arbitrary = return . L.checkInvariant+ . L.fromChunks+ . filter (not. P.null) -- maintain the invariant.+ =<< arbitrary++instance CoArbitrary L.ByteString where+ coarbitrary s = coarbitrary (L.unpack s)++instance Arbitrary P.ByteString where+ arbitrary = do+ bs <- P.pack `fmap` arbitrary+ n <- choose (0, 2)+ return (P.drop n bs) -- to give us some with non-0 offset++instance CoArbitrary P.ByteString where+ coarbitrary s = coarbitrary (P.unpack s)+++newtype CByteString = CByteString P.ByteString+ deriving Show++instance Arbitrary CByteString where+ arbitrary = fmap (CByteString . P.pack . map fromCChar) arbitrary+ where+ fromCChar :: CChar -> Word8+ fromCChar = fromIntegral++instance Arbitrary CChar where+ arbitrary = fmap (fromIntegral :: Int -> CChar)+ $ oneof [choose (-128,-1), choose (1,127)]++------------------------------------------------------------------------+--+-- We're doing two forms of testing here. Firstly, model based testing.+-- For our Lazy and strict bytestring types, we have model types:+--+-- i.e. Lazy == Byte+-- \\ //+-- List +--+-- That is, the Lazy type can be modeled by functions in both the Byte+-- and List type. For each of the 3 models, we have a set of tests that+-- check those types match.+--+-- The Model class connects a type and its model type, via a conversion+-- function. +--+--+class Model a b where+ model :: a -> b -- get the abstract vale from a concrete value++--+-- Connecting our Lazy and Strict types to their models. We also check+-- the data invariant on Lazy types.+--+-- These instances represent the arrows in the above diagram+--+instance Model B P where model = abstr . checkInvariant+instance Model P [W] where model = P.unpack+instance Model P [Char] where model = PC.unpack+instance Model B [W] where model = L.unpack . checkInvariant+instance Model B [Char] where model = LC.unpack . checkInvariant+instance Model Char Word8 where model = fromIntegral . ord++-- Types are trivially modeled by themselves+instance Model Bool Bool where model = id+instance Model Int Int where model = id+instance Model P P where model = id+instance Model B B where model = id+instance Model Int64 Int64 where model = id+instance Model Word8 Word8 where model = id+instance Model Ordering Ordering where model = id+instance Model Char Char where model = id++-- More structured types are modeled recursively, using the NatTrans class from Gofer.+class (Functor f, Functor g) => NatTrans f g where+ eta :: f a -> g a++-- The transformation of the same type is identity+instance NatTrans [] [] where eta = id+instance NatTrans Maybe Maybe where eta = id+instance NatTrans ((->) X) ((->) X) where eta = id+instance NatTrans ((->) Char) ((->) Char) where eta = id++instance NatTrans ((->) W) ((->) W) where eta = id++-- We have a transformation of pairs, if the pairs are in Model+instance Model f g => NatTrans ((,) f) ((,) g) where eta (f,a) = (model f, a)++-- And finally, we can take any (m a) to (n b), if we can Model m n, and a b+instance (NatTrans m n, Model a b) => Model (m a) (n b) where model x = fmap model (eta x)++------------------------------------------------------------------------++-- In a form more useful for QC testing (and it's lazy)+checkInvariant :: L.ByteString -> L.ByteString+checkInvariant = L.checkInvariant++abstr :: L.ByteString -> P.ByteString+abstr = P.concat . L.toChunks ++-- Some short hand.+type X = Int+type W = Word8+type P = P.ByteString+type B = L.ByteString++------------------------------------------------------------------------+--+-- These comparison functions handle wrapping and equality.+--+-- A single class for these would be nice, but note that they differe in+-- the number of arguments, and those argument types, so we'd need HList+-- tricks. See here: http://okmij.org/ftp/Haskell/vararg-fn.lhs+--++eq1 f g = \a ->+ model (f a) == g (model a)+eq2 f g = \a b ->+ model (f a b) == g (model a) (model b)+eq3 f g = \a b c ->+ model (f a b c) == g (model a) (model b) (model c)++--+-- And for functions that take non-null input+--+eqnotnull1 f g = \x -> (not (isNull x)) ==> eq1 f g x+eqnotnull2 f g = \x y -> (not (isNull y)) ==> eq2 f g x y+eqnotnull3 f g = \x y z -> (not (isNull z)) ==> eq3 f g x y z++class IsNull t where isNull :: t -> Bool+instance IsNull L.ByteString where isNull = L.null+instance IsNull P.ByteString where isNull = P.null
+ tests/Rules.hs view
@@ -0,0 +1,32 @@+module Rules where+--+-- Tests to ensure rules are firing.+--++import qualified Data.ByteString.Char8 as C+import qualified Data.ByteString as P+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as D+import Data.List+import Data.Char++import QuickCheckUtils+import TestFramework+++prop_break_C x = C.break ((==) x) `eq1` break ((==) x)+prop_break_P x = P.break ((==) x) `eq1` break ((==) x)+prop_intercalate_P c = (\s1 s2 -> P.intercalate (P.singleton c) (s1 : s2 : []))+ `eq2`+ (\s1 s2 -> intercalate [c] (s1 : s2 : []))++prop_break_isSpace_C = C.break isSpace `eq1` break isSpace+prop_dropWhile_isSpace_C = C.dropWhile isSpace `eq1` dropWhile isSpace++rules =+ [ testProperty "break (==)" prop_break_C+ , testProperty "break (==)" prop_break_P+ , testProperty "break isSpace" prop_break_isSpace_C+ , testProperty "dropWhile isSpace" prop_dropWhile_isSpace_C+ , testProperty "intercalate" prop_intercalate_P+ ]
+ tests/TestFramework.hs view
@@ -0,0 +1,67 @@+-- |+-- Copyright : (c) 2011 Duncan Coutts+-- +-- test-framework stub API+--+-- Currently we cannot use the nice test-framework package for this testsuite+-- since test-framework indirectly depends on bytestring and this makes cabal+-- think we've got a circular dependency.+--+-- On the other hand, it's very nice to have the testsuite run automatically+-- rather than being a totally separate package (which would fix).+--+-- So until we can fix that we implement our own trivial layer.+--+module TestFramework where++import Test.QuickCheck (Testable(..))+import Test.QuickCheck.Test++import Text.Printf+import System.Environment+import Control.Monad+import Control.Exception++-- Ideally we'd be using:++--import Test.Framework+--import Test.Framework.Providers.QuickCheck2++type TestName = String+type Test = [(TestName, Int -> IO (Bool, Int))]++testGroup :: String -> [Test] -> Test+testGroup _ = concat++testProperty :: Testable a => String -> a -> Test+testProperty name p = [(name, runQcTest)]+ where+ runQcTest n = do+ result <- quickCheckWithResult testArgs p+ case result of+ Success {} -> return (True, numTests result)+ _ -> return (False, numTests result)+ where+ testArgs = stdArgs {+ maxSuccess = n+ --chatty = ... if we want to increase verbosity+ }++testCase :: String -> Bool -> Test+testCase name tst = [(name, runPlainTest)]+ where+ runPlainTest _ = do+ r <- evaluate tst+ putStrLn "+++ OK, passed test."+ return (r, 1)++defaultMain :: [Test] -> IO ()+defaultMain = runTests . concat++runTests :: [(String, Int -> IO (Bool,Int))] -> IO ()+runTests 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!"
+ tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/TestUtils.hs view
@@ -0,0 +1,344 @@+-- |+-- Copyright : (c) 2011 Simon Meier+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Simon Meier <iridcode@gmail.com>+-- Stability : experimental+-- Portability : tested on GHC only+--+-- Testing utilities for comparing+-- for an example on how to use the functions provided here.+--+module Data.ByteString.Lazy.Builder.BasicEncoding.TestUtils (++ -- * Testing 'FixedEncoding's+ testF+ , testBoundedF++ , testFixedBoundF++ , compareImpls++ -- * Testing 'BoundedEncoding's+ , testBoundedB++ -- * Encoding reference implementations++ , charUtf8_list+ , char8_list++ -- ** ASCII-based encodings+ , encodeASCII+ , encodeForcedASCII+ , char7_list+ , dec_list+ , hex_list+ , wordHexFixed_list+ , int8HexFixed_list+ , int16HexFixed_list+ , int32HexFixed_list+ , int64HexFixed_list+ , floatHexFixed_list+ , doubleHexFixed_list++ -- ** Binary+ , parseVar++ , bigEndian_list+ , littleEndian_list+ , hostEndian_list+ , float_list+ , double_list+ , coerceFloatToWord32+ , coerceDoubleToWord64++ ) where++import Control.Arrow (first)++import Data.ByteString.Lazy.Builder.BasicEncoding+import Data.Char (chr, ord)++import Numeric (showHex)++#if MIN_VERSION_base(4,4,0)+import Foreign hiding (unsafePerformIO)+import System.IO.Unsafe (unsafePerformIO)+#else+import Foreign+#endif++import System.ByteOrder+import Unsafe.Coerce (unsafeCoerce)++import TestFramework+import Test.QuickCheck (Arbitrary(..))++-- Helper functions+-------------------++-- | Quickcheck test that includes a check that the property holds on the+-- bounds of a bounded value.+testBoundedProperty :: forall a. (Arbitrary a, Show a, Bounded a)+ => String -> (a -> Bool) -> Test+testBoundedProperty name p = testGroup name+ [ testProperty "arbitrary" p+ , testCase "bounds" $ p (minBound :: a)+ && p (maxBound :: a)+ ]++-- | Quote a 'String' nicely.+quote :: String -> String+quote cs = '`' : cs ++ "'"++-- | Quote a @[Word8]@ list as as 'String'.+quoteWord8s :: [Word8] -> String+quoteWord8s = quote . map (chr . fromIntegral)+++-- FixedEncoding+----------------++-- TODO: Port code that checks for low-level properties of basic encodings (no+-- overwrites, all bytes written, etc.) from old 'system-io-write' library++-- | Test a 'FixedEncoding' against a reference implementation.+testF :: (Arbitrary a, Show a)+ => String+ -> (a -> [Word8])+ -> FixedEncoding a+ -> Test+testF name ref fe =+ testProperty name prop+ where+ prop x+ | y == y' = True+ | otherwise = error $ unlines $+ [ "testF: results disagree for " ++ quote (show x)+ , " fixed encoding: " ++ show y ++ " " ++ quoteWord8s y+ , " reference: " ++ show y'++ " " ++ quoteWord8s y'+ ]+ where+ y = evalF fe x+ y' = ref x++-- | Test a 'FixedEncoding' of a bounded value against a reference implementation+-- and ensure that the bounds are always included as testcases.+testBoundedF :: (Arbitrary a, Bounded a, Show a)+ => String+ -> (a -> [Word8])+ -> FixedEncoding a+ -> Test+testBoundedF name ref fe =+ testBoundedProperty name $ \x -> evalF fe x == ref x++-- FixedEncoding derived from a bound on a given value.++testFixedBoundF :: (Arbitrary a, Show a, Integral a)+ => String+ -> (a -> a -> [Word8])+ -> (a -> FixedEncoding a)+ -> Test+testFixedBoundF name ref bfe =+ testProperty name prop+ where+ prop (b, x0)+ | y == y' = True+ | otherwise = error $ unlines $+ [ "testF: results disagree for " ++ quote (show (b, x))+ , " fixed encoding: " ++ show y ++ " " ++ quoteWord8s y+ , " reference: " ++ show y'++ " " ++ quoteWord8s y'+ ]+ where+ x | b == 0 = 0+ | otherwise = x0 `mod` b+ y = evalF (bfe b) x+ y' = ref b x+++-- BoundedEncoding+------------------++-- | Test a 'BoundedEncoding' of a bounded value against a reference implementation+-- and ensure that the bounds are always included as testcases.+testBoundedB :: (Arbitrary a, Bounded a, Show a)+ => String+ -> (a -> [Word8])+ -> BoundedEncoding a+ -> Test+testBoundedB name ref fe =+ testBoundedProperty name check+ where+ check x+ | y == y' = True+ | otherwise = error $ unlines $+ [ "testBoundedB: results disagree for " ++ quote (show x)+ , " fixed encoding: " ++ show y ++ " " ++ quoteWord8s y+ , " reference: " ++ show y'++ " " ++ quoteWord8s y'+ ]+ where+ y = evalB fe x+ y' = ref x++-- | Compare two implementations of a function.+compareImpls :: (Arbitrary a, Show a, Show b, Eq b)+ => TestName -> (a -> b) -> (a -> b) -> Test+compareImpls name f1 f2 =+ testProperty name check+ where+ check x+ | y1 == y2 = True+ | otherwise = error $ unlines $+ [ "compareImpls: results disagree for " ++ quote (show x)+ , " f1: " ++ show y1+ , " f2: " ++ show y2+ ]+ where+ y1 = f1 x+ y2 = f2 x++++------------------------------------------------------------------------------+-- Encoding reference implementations+------------------------------------------------------------------------------++-- | Char8 encoding: truncate Unicode codepoint to 8-bits.+char8_list :: Char -> [Word8]+char8_list = return . fromIntegral . ord++-- | Encode a Haskell String to a list of Word8 values, in UTF8 format.+--+-- Copied from 'utf8-string-0.3.6' to make tests self-contained.+-- Copyright (c) 2007, Galois Inc. All rights reserved.+--+charUtf8_list :: Char -> [Word8]+charUtf8_list =+ map fromIntegral . encode . ord+ where+ encode oc+ | oc <= 0x7f = [oc]++ | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6)+ , 0x80 + oc .&. 0x3f+ ]++ | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12)+ , 0x80 + ((oc `shiftR` 6) .&. 0x3f)+ , 0x80 + oc .&. 0x3f+ ]+ | otherwise = [ 0xf0 + (oc `shiftR` 18)+ , 0x80 + ((oc `shiftR` 12) .&. 0x3f)+ , 0x80 + ((oc `shiftR` 6) .&. 0x3f)+ , 0x80 + oc .&. 0x3f+ ]++-- ASCII-based encodings+------------------------++-- | Encode a 'String' of only ASCII characters using the ASCII encoding.+encodeASCII :: String -> [Word8]+encodeASCII =+ map encode+ where+ encode c+ | c < '\x7f' = fromIntegral $ ord c+ | otherwise = error $ "encodeASCII: non-ASCII character '" ++ [c] ++ "'"++-- | Encode an arbitrary 'String' by truncating its characters to the least+-- significant 7-bits.+encodeForcedASCII :: String -> [Word8]+encodeForcedASCII = map ((.&. 0x7f) . fromIntegral . ord)++char7_list :: Char -> [Word8]+char7_list = encodeForcedASCII . return++dec_list :: Show a => a -> [Word8]+dec_list = encodeASCII . show++hex_list :: (Integral a, Show a) => a -> [Word8]+hex_list = encodeASCII . (\x -> showHex x "")++wordHexFixed_list :: (Storable a, Integral a, Show a) => a -> [Word8]+wordHexFixed_list x =+ encodeASCII $ pad (2 * sizeOf x) $ showHex x ""+ where+ pad n cs = replicate (n - length cs) '0' ++ cs++int8HexFixed_list :: Int8 -> [Word8]+int8HexFixed_list = wordHexFixed_list . (fromIntegral :: Int8 -> Word8 )++int16HexFixed_list :: Int16 -> [Word8]+int16HexFixed_list = wordHexFixed_list . (fromIntegral :: Int16 -> Word16)++int32HexFixed_list :: Int32 -> [Word8]+int32HexFixed_list = wordHexFixed_list . (fromIntegral :: Int32 -> Word32)++int64HexFixed_list :: Int64 -> [Word8]+int64HexFixed_list = wordHexFixed_list . (fromIntegral :: Int64 -> Word64)++floatHexFixed_list :: Float -> [Word8]+floatHexFixed_list = float_list wordHexFixed_list++doubleHexFixed_list :: Double -> [Word8]+doubleHexFixed_list = double_list wordHexFixed_list++-- Binary+---------++bigEndian_list :: (Storable a, Bits a, Integral a) => a -> [Word8]+bigEndian_list = reverse . littleEndian_list++littleEndian_list :: (Storable a, Bits a, Integral a) => a -> [Word8]+littleEndian_list x =+ map (fromIntegral . (x `shiftR`) . (8*)) $ [0..sizeOf x - 1]++hostEndian_list :: (Storable a, Bits a, Integral a) => a -> [Word8]+hostEndian_list = case byteOrder of+ LittleEndian -> littleEndian_list+ BigEndian -> bigEndian_list+ _ -> error $+ "bounded-encoding: unsupported byteorder '" ++ show byteOrder ++ "'"+++float_list :: (Word32 -> [Word8]) -> Float -> [Word8]+float_list f = f . coerceFloatToWord32++double_list :: (Word64 -> [Word8]) -> Double -> [Word8]+double_list f = f . coerceDoubleToWord64++-- Note that the following use of unsafeCoerce is not guaranteed to be+-- safe on GHC 7.0 and less. The reason is probably the following ticket:+--+-- http://hackage.haskell.org/trac/ghc/ticket/4092+--+-- However, that only applies if the value is loaded in a register. We+-- avoid this by coercing only boxed values and ensuring that they+-- remain boxed using a NOINLINE pragma.+--++-- | Super unsafe coerce a 'Float' to a 'Word32'. We have to explicitly mask+-- out the higher bits in case we are working on a 64-bit machine.+{-# NOINLINE coerceFloatToWord32 #-}+coerceFloatToWord32 :: Float -> Word32+coerceFloatToWord32 = (.&. maxBound) . unsafeCoerce++-- | Super unsafe coerce a 'Double' to a 'Word64'. Currently, there are no+-- > 64 bit machines supported by GHC. But we just play it safe.+{-# NOINLINE coerceDoubleToWord64 #-}+coerceDoubleToWord64 :: Double -> Word64+coerceDoubleToWord64 = (.&. maxBound) . unsafeCoerce++-- | Parse a variable length encoding+parseVar :: (Num a, Bits a) => [Word8] -> (a, [Word8])+parseVar =+ go+ where+ go [] = error "parseVar: unterminated variable length int"+ go (w:ws)+ | w .&. 0x80 == 0 = (fromIntegral w, ws)+ | otherwise = first add (go ws)+ where+ add x = (x `shiftL` 7) .|. (fromIntegral w .&. 0x7f)++
+ tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/Tests.hs view
@@ -0,0 +1,337 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Copyright : (c) 2011 Simon Meier+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Simon Meier <iridcode@gmail.com>+-- Stability : experimental+-- Portability : tested on GHC only+--+-- Testing all encodings provided by this library.++module Data.ByteString.Lazy.Builder.BasicEncoding.Tests (tests) where++import Control.Arrow (first)++import Data.Char (ord)+import qualified Data.ByteString.Lazy as L+import Data.ByteString.Lazy.Builder+import qualified Data.ByteString.Lazy.Builder.BasicEncoding as BE+import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Extras as BE+import Data.ByteString.Lazy.Builder.BasicEncoding.TestUtils++import Numeric (showHex)++import Foreign++import TestFramework+import Test.QuickCheck (Arbitrary)+++tests :: [Test]+tests = concat [ testsBinary, testsASCII, testsChar8, testsUtf8+ , testsCombinatorsB ]+++------------------------------------------------------------------------------+-- Binary+------------------------------------------------------------------------------++testsBinary :: [Test]+testsBinary =+ [ testBoundedF "word8" bigEndian_list BE.word8+ , testBoundedF "int8" bigEndian_list BE.int8++ -- big-endian+ , testBoundedF "int16BE" bigEndian_list BE.int16BE+ , testBoundedF "int32BE" bigEndian_list BE.int32BE+ , testBoundedF "int64BE" bigEndian_list BE.int64BE++ , testBoundedF "word16BE" bigEndian_list BE.word16BE+ , testBoundedF "word32BE" bigEndian_list BE.word32BE+ , testBoundedF "word64BE" bigEndian_list BE.word64BE++ , testF "floatLE" (float_list littleEndian_list) BE.floatLE+ , testF "doubleLE" (double_list littleEndian_list) BE.doubleLE++ -- little-endian+ , testBoundedF "int16LE" littleEndian_list BE.int16LE+ , testBoundedF "int32LE" littleEndian_list BE.int32LE+ , testBoundedF "int64LE" littleEndian_list BE.int64LE++ , testBoundedF "word16LE" littleEndian_list BE.word16LE+ , testBoundedF "word32LE" littleEndian_list BE.word32LE+ , testBoundedF "word64LE" littleEndian_list BE.word64LE++ , testF "floatBE" (float_list bigEndian_list) BE.floatBE+ , testF "doubleBE" (double_list bigEndian_list) BE.doubleBE++ -- host dependent+ , testBoundedF "int16Host" hostEndian_list BE.int16Host+ , testBoundedF "int32Host" hostEndian_list BE.int32Host+ , testBoundedF "int64Host" hostEndian_list BE.int64Host+ , testBoundedF "intHost" hostEndian_list BE.intHost++ , testBoundedF "word16Host" hostEndian_list BE.word16Host+ , testBoundedF "word32Host" hostEndian_list BE.word32Host+ , testBoundedF "word64Host" hostEndian_list BE.word64Host+ , testBoundedF "wordHost" hostEndian_list BE.wordHost++ , testF "floatHost" (float_list hostEndian_list) BE.floatHost+ , testF "doubleHost" (double_list hostEndian_list) BE.doubleHost++ , testBoundedB "word8Var" genVar_list BE.word8Var+ , testBoundedB "word16Var" genVar_list BE.word16Var+ , testBoundedB "word32Var" genVar_list BE.word32Var+ , testBoundedB "word64Var" genVar_list BE.word64Var+ , testBoundedB "wordVar" genVar_list BE.wordVar++ , testBoundedB "int8Var" int8Var_list BE.int8Var+ , testBoundedB "int16Var" int16Var_list BE.int16Var+ , testBoundedB "int32Var" int32Var_list BE.int32Var+ , testBoundedB "int64Var" int64Var_list BE.int64Var+ , testBoundedB "intVar" intVar_list BE.intVar++ , testBoundedB "int8VarSigned" (int8Var_list . zigZag) BE.int8VarSigned+ , testBoundedB "int16VarSigned" (int16Var_list . zigZag) BE.int16VarSigned+ , testBoundedB "int32VarSigned" (int32Var_list . zigZag) BE.int32VarSigned+ , testBoundedB "int64VarSigned" (int64Var_list . zigZag) BE.int64VarSigned+ , testBoundedB "intVarSigned" (intVar_list . zigZag) BE.intVarSigned++ , testGroup "parseable"+ [ prop_zigZag_parseable "int8VarSigned" unZigZagInt8 BE.int8VarSigned+ , prop_zigZag_parseable "int16VarSigned" unZigZagInt16 BE.int16VarSigned+ , prop_zigZag_parseable "int32VarSigned" unZigZagInt32 BE.int32VarSigned+ , prop_zigZag_parseable "int64VarSigned" unZigZagInt64 BE.int64VarSigned+ , prop_zigZag_parseable "intVarSigned" unZigZagInt BE.intVarSigned+ ]++ , testFixedBoundF "wordVarFixedBound" wordVarFixedBound_list BE.wordVarFixedBound+ , testFixedBoundF "word64VarFixedBound" word64VarFixedBound_list BE.word64VarFixedBound++ ]+++-- Variable length encodings+----------------------------++-- | Variable length encoding.+genVar_list :: (Ord a, Num a, Bits a, Integral a) => a -> [Word8]+genVar_list x+ | x <= 0x7f = sevenBits : []+ | otherwise = (sevenBits .|. 0x80) : genVar_list (x `shiftR` 7)+ where+ sevenBits = fromIntegral x .&. 0x7f++int8Var_list :: Int8 -> [Word8]+int8Var_list = genVar_list . (fromIntegral :: Int8 -> Word8)++int16Var_list :: Int16 -> [Word8]+int16Var_list = genVar_list . (fromIntegral :: Int16 -> Word16)++int32Var_list :: Int32 -> [Word8]+int32Var_list = genVar_list . (fromIntegral :: Int32 -> Word32)++int64Var_list :: Int64 -> [Word8]+int64Var_list = genVar_list . (fromIntegral :: Int64 -> Word64)++intVar_list :: Int -> [Word8]+intVar_list = genVar_list . (fromIntegral :: Int -> Word)+++-- | The so-called \"zig-zag\" encoding from Google's protocol buffers.+-- It maps integers of small magnitude to naturals of small+-- magnitude by encoding negative integers as odd naturals and positive+-- integers as even naturals.+--+-- For example: @0 -> 0, -1 -> 1, 1 -> 2, -2 -> 3, 2 -> 4, ...@+--+-- PRE: 'a' must be a signed integer type.+zigZag :: (Storable a, Bits a) => a -> a+zigZag x = (x `shiftL` 1) `xor` (x `shiftR` (8 * sizeOf x - 1))+++-- | Reversing the zigZag encoding.+--+-- PRE: 'a' must be an unsigned integer type.+--+-- forall x. fromIntegral x ==+-- unZigZag ((fromIntegral :: IntX -> WordX) (zigZag x))+--+unZigZag :: (Storable a, Num a, Bits a) => a -> a+unZigZag x = (x `shiftR` 1) `xor` negate (x .&. 1)++unZigZagInt8 :: Int8 -> Int8+unZigZagInt8 = (fromIntegral :: Word8 -> Int8) . unZigZag . fromIntegral++unZigZagInt16 :: Int16 -> Int16+unZigZagInt16 = (fromIntegral :: Word16 -> Int16) . unZigZag . fromIntegral++unZigZagInt32 :: Int32 -> Int32+unZigZagInt32 = (fromIntegral :: Word32 -> Int32) . unZigZag . fromIntegral++unZigZagInt64 :: Int64 -> Int64+unZigZagInt64 = (fromIntegral :: Word64 -> Int64) . unZigZag . fromIntegral++unZigZagInt :: Int -> Int+unZigZagInt = (fromIntegral :: Word -> Int) . unZigZag . fromIntegral++-- | Check that the 'intVarSigned' encodings are parseable.+prop_zigZag_parseable :: (Arbitrary t, Num b, Bits b, Show t, Eq t)+ => String -> (b -> t) -> BE.BoundedEncoding t -> Test+prop_zigZag_parseable name unZig be =+ compareImpls name (\x -> (x, [])) (first unZig . parseVar . BE.evalB be)++-- | Variable length encoding to a fixed number of bytes (pad / truncate).+genVarFixedBound_list :: (Ord a, Num a, Bits a, Integral a)+ => Int+ -> a -> [Word8]+genVarFixedBound_list n x+ | n <= 1 = sevenBits : []+ | otherwise = (sevenBits .|. 0x80) : genVarFixedBound_list (n - 1) (x `shiftR` 7)+ where+ sevenBits = fromIntegral x .&. 0x7f++wordVarFixedBound_list :: Word -> Word -> [Word8]+wordVarFixedBound_list bound = genVarFixedBound_list (length $ genVar_list bound)++word64VarFixedBound_list :: Word64 -> Word64 -> [Word8]+word64VarFixedBound_list bound = genVarFixedBound_list (length $ genVar_list bound)++-- Somehow this function doesn't really make sense, as the bound must be+-- greater when interpreted as an unsigned integer.+--+-- intVarFixedBound_list :: Int -> Int -> [Word8]+-- intVarFixedBound_list bound = wordVarFixedBound_list (fromIntegral bound) . fromIntegral+++------------------------------------------------------------------------------+-- Latin-1 aka Char8+------------------------------------------------------------------------------++testsChar8 :: [Test]+testsChar8 =+ [ testBoundedF "char8" char8_list BE.char8 ]+++------------------------------------------------------------------------------+-- ASCII+------------------------------------------------------------------------------++testsASCII :: [Test]+testsASCII =+ [ testBoundedF "char7" char7_list BE.char7++ , testBoundedB "int8Dec" dec_list BE.int8Dec+ , testBoundedB "int16Dec" dec_list BE.int16Dec+ , testBoundedB "int32Dec" dec_list BE.int32Dec+ , testBoundedB "int64Dec" dec_list BE.int64Dec+ , testBoundedB "intDec" dec_list BE.intDec++ , testBoundedB "word8Dec" dec_list BE.word8Dec+ , testBoundedB "word16Dec" dec_list BE.word16Dec+ , testBoundedB "word32Dec" dec_list BE.word32Dec+ , testBoundedB "word64Dec" dec_list BE.word64Dec+ , testBoundedB "wordDec" dec_list BE.wordDec++ , testBoundedB "word8Hex" hex_list BE.word8Hex+ , testBoundedB "word16Hex" hex_list BE.word16Hex+ , testBoundedB "word32Hex" hex_list BE.word32Hex+ , testBoundedB "word64Hex" hex_list BE.word64Hex+ , testBoundedB "wordHex" hex_list BE.wordHex++ , testBoundedF "word8HexFixed" wordHexFixed_list BE.word8HexFixed+ , testBoundedF "word16HexFixed" wordHexFixed_list BE.word16HexFixed+ , testBoundedF "word32HexFixed" wordHexFixed_list BE.word32HexFixed+ , testBoundedF "word64HexFixed" wordHexFixed_list BE.word64HexFixed++ , testBoundedF "int8HexFixed" int8HexFixed_list BE.int8HexFixed+ , testBoundedF "int16HexFixed" int16HexFixed_list BE.int16HexFixed+ , testBoundedF "int32HexFixed" int32HexFixed_list BE.int32HexFixed+ , testBoundedF "int64HexFixed" int64HexFixed_list BE.int64HexFixed++ , testF "floatHexFixed" floatHexFixed_list BE.floatHexFixed+ , testF "doubleHexFixed" doubleHexFixed_list BE.doubleHexFixed++ , testFixedBoundF "wordDecFixedBound"+ (genDecFixedBound_list 'x') (BE.wordDecFixedBound 'x')++ , testFixedBoundF "word64DecFixedBound"+ (genDecFixedBound_list 'x') (BE.word64DecFixedBound 'x')++ , testFixedBoundF "wordHexFixedBound"+ (genHexFixedBound_list 'x') (BE.wordHexFixedBound 'x')++ , testFixedBoundF "word64HexFixedBound"+ (genHexFixedBound_list 'x') (BE.word64HexFixedBound 'x')+ ]++-- | PRE: positive bound and value.+genDecFixedBound_list :: (Show a, Integral a)+ => Char -- ^ Padding character.+ -> a -- ^ Max value to be encoded.+ -> a -- ^ Value to encode.+ -> [Word8]+genDecFixedBound_list padChar bound =+ encodeASCII . pad . show+ where+ n = length $ show bound+ pad cs = replicate (n - length cs) padChar ++ cs++-- | PRE: positive bound and value.+genHexFixedBound_list :: (Show a, Integral a)+ => Char -- ^ Padding character.+ -> a -- ^ Max value to be encoded.+ -> a -- ^ Value to encode.+ -> [Word8]+genHexFixedBound_list padChar bound =+ encodeASCII . pad . (`showHex` "")+ where+ n = length $ (`showHex` "") bound+ pad cs = replicate (n - length cs) padChar ++ cs+++------------------------------------------------------------------------------+-- UTF-8+------------------------------------------------------------------------------++testsUtf8 :: [Test]+testsUtf8 =+ [ testBoundedB "charUtf8" charUtf8_list BE.charUtf8 ]+++------------------------------------------------------------------------------+-- BoundedEncoding combinators+------------------------------------------------------------------------------++maybeB :: BE.BoundedEncoding () -> BE.BoundedEncoding a -> BE.BoundedEncoding (Maybe a)+maybeB nothing just = maybe (Left ()) Right BE.>$< BE.eitherB nothing just++testsCombinatorsB :: [Test]+testsCombinatorsB =+ [ compareImpls "mapMaybe (via BoundedEncoding)"+ (L.pack . concatMap encChar)+ (toLazyByteString . encViaBuilder)++ , compareImpls "filter (via BoundedEncoding)"+ (L.pack . filter (< 32))+ (toLazyByteString . BE.encodeListWithB (BE.ifB (< 32) (BE.fromF BE.word8) BE.emptyB))++ , compareImpls "pairB"+ (L.pack . concatMap (\(c,w) -> charUtf8_list c ++ [w]))+ (toLazyByteString . BE.encodeListWithB+ ((\(c,w) -> (c,(w,undefined))) BE.>$<+ BE.charUtf8 BE.>*< (BE.fromF BE.word8) BE.>*< (BE.fromF BE.emptyF)))+ ]+ where+ encChar = maybe [112] (hostEndian_list . ord)++ encViaBuilder = BE.encodeListWithB $ maybeB (BE.fromF $ (\_ -> 112) BE.>$< BE.word8)+ (ord BE.>$< (BE.fromF $ BE.intHost))++++++
+ tests/builder/Data/ByteString/Lazy/Builder/Tests.hs view
@@ -0,0 +1,636 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+-- Copyright : (c) 2011 Simon Meier+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Simon Meier <iridcode@gmail.com>+-- Stability : experimental+-- Portability : tested on GHC only+--+-- Testing composition of 'Builders'.++module Data.ByteString.Lazy.Builder.Tests (tests) where+++import Control.Applicative+import Control.Monad.State+import Control.Monad.Writer++import Foreign (Word, Word8, Word64, minusPtr)+import System.IO.Unsafe (unsafePerformIO)++import Data.Char (ord, chr)+import qualified Data.DList as D+import Data.Foldable (asum, 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.ASCII+import Data.ByteString.Lazy.Builder.Internal (Put, putBuilder, fromPut)+import qualified Data.ByteString.Lazy.Builder.Internal as BI+import qualified Data.ByteString.Lazy.Builder.BasicEncoding as BE+import qualified Data.ByteString.Lazy.Builder.BasicEncoding.Extras as BE+import Data.ByteString.Lazy.Builder.BasicEncoding.TestUtils++import Numeric (readHex)++import Control.Exception (evaluate)+import System.IO (openTempFile, hPutStr, hClose, hSetBinaryMode)+#if MIN_VERSION_base(4,2,0)+import System.IO (hSetEncoding, utf8)+#endif+import System.Directory++import TestFramework+import Test.QuickCheck+ ( Arbitrary(..), oneof, choose, listOf, elements )+import Test.QuickCheck.Property (printTestCase)+++tests :: [Test]+tests =+ [ testBuilderRecipe+#if MIN_VERSION_base(4,2,0)+ , testHandlePutBuilder+#endif+ , testHandlePutBuilderChar8+ , testPut+ ] +++ testsEncodingToBuilder +++ testsBinary +++ testsASCII +++ testsChar8 +++ testsUtf8+++------------------------------------------------------------------------------+-- Testing 'Builder' execution+------------------------------------------------------------------------------++testBuilderRecipe :: Test+testBuilderRecipe =+ testProperty "toLazyByteStringWith" $ testRecipe <$> arbitrary+ where+ testRecipe r =+ printTestCase msg $ x1 == x2+ where+ x1 = renderRecipe r+ x2 = buildRecipe r+ toString = map (chr . fromIntegral)+ msg = unlines+ [ "recipe: " ++ show r+ , "render: " ++ toString x1+ , "build : " ++ toString x2+ , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2)+ ]++#if MIN_VERSION_base(4,2,0)+testHandlePutBuilder :: Test+testHandlePutBuilder =+ testProperty "hPutBuilder" testRecipe+ where+ testRecipe :: (String, String, String, Recipe) -> Bool+ testRecipe args@(before, between, after, recipe) = unsafePerformIO $ do+ tempDir <- getTemporaryDirectory+ (tempFile, tempH) <- openTempFile tempDir "TestBuilder"+ -- switch to UTF-8 encoding+ hSetEncoding tempH utf8+ -- output recipe with intermediate direct writing to handle+ let b = fst $ recipeComponents recipe+ hPutStr tempH before+ hPutBuilder tempH b+ hPutStr tempH between+ hPutBuilder tempH b+ hPutStr tempH after+ hClose tempH+ -- read file+ lbs <- L.readFile tempFile+ _ <- evaluate (L.length $ lbs)+ removeFile tempFile+ -- compare to pure builder implementation+ let lbsRef = toLazyByteString $ mconcat+ [stringUtf8 before, b, stringUtf8 between, b, stringUtf8 after]+ -- report+ let msg = unlines+ [ "task: " ++ show args+ , "via file: " ++ show lbs+ , "direct : " ++ show lbsRef+ -- , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2)+ ]+ success = lbs == lbsRef+ unless success (error msg)+ return success+#endif++testHandlePutBuilderChar8 :: Test+testHandlePutBuilderChar8 =+ testProperty "char8 hPutBuilder" testRecipe+ where+ testRecipe :: (String, String, String, Recipe) -> Bool+ testRecipe args@(before, between, after, recipe) = unsafePerformIO $ do+ tempDir <- getTemporaryDirectory+ (tempFile, tempH) <- openTempFile tempDir "TestBuilder"+ -- switch to binary / latin1 encoding+ hSetBinaryMode tempH True+ -- output recipe with intermediate direct writing to handle+ let b = fst $ recipeComponents recipe+ hPutStr tempH before+ hPutBuilder tempH b+ hPutStr tempH between+ hPutBuilder tempH b+ hPutStr tempH after+ hClose tempH+ -- read file+ lbs <- L.readFile tempFile+ _ <- evaluate (L.length $ lbs)+ removeFile tempFile+ -- compare to pure builder implementation+ let lbsRef = toLazyByteString $ mconcat+ [string8 before, b, string8 between, b, string8 after]+ -- report+ let msg = unlines+ [ "task: " ++ show args+ , "via file: " ++ show lbs+ , "direct : " ++ show lbsRef+ -- , "diff : " ++ show (dropWhile (uncurry (==)) $ zip x1 x2)+ ]+ success = lbs == lbsRef+ unless success (error msg)+ return success+++-- Recipes with which to test the builder functions+---------------------------------------------------++data Mode =+ Threshold Int+ | Insert+ | Copy+ | Smart+ | Hex+ deriving( Eq, Ord, Show )++data Action =+ SBS Mode S.ByteString+ | LBS Mode L.ByteString+ | W8 Word8+ | W8S [Word8]+ | String String+ | FDec Float+ | DDec Double+ | Flush+ | EnsureFree Word+ | ModState Int+ deriving( Eq, Ord, Show )++data Strategy = Safe | Untrimmed+ deriving( Eq, Ord, Show )++data Recipe = Recipe Strategy Int Int L.ByteString [Action]+ deriving( Eq, Ord, Show )++renderRecipe :: Recipe -> [Word8]+renderRecipe (Recipe _ firstSize _ cont as) =+ D.toList $ execWriter (evalStateT (mapM_ renderAction as) firstSize)+ `mappend` renderLBS cont+ where+ renderAction (SBS Hex bs) = tell $ foldMap hexWord8 $ S.unpack bs+ renderAction (SBS _ bs) = tell $ D.fromList $ S.unpack bs+ renderAction (LBS Hex lbs) = tell $ foldMap hexWord8 $ L.unpack lbs+ renderAction (LBS _ lbs) = tell $ renderLBS lbs+ renderAction (W8 w) = tell $ return w+ renderAction (W8S ws) = tell $ D.fromList ws+ renderAction (String cs) = tell $ foldMap (D.fromList . charUtf8_list) cs+ renderAction Flush = tell $ mempty+ renderAction (EnsureFree _) = tell $ mempty+ renderAction (FDec f) = tell $ D.fromList $ encodeASCII $ show f+ renderAction (DDec d) = tell $ D.fromList $ encodeASCII $ show d+ renderAction (ModState i) = do+ s <- get+ tell (D.fromList $ encodeASCII $ show s)+ put (s - i)+++ renderLBS = D.fromList . L.unpack+ hexWord8 = D.fromList . wordHexFixed_list++buildAction :: Action -> StateT Int Put ()+buildAction (SBS Hex bs) = lift $ putBuilder $ byteStringHexFixed bs+buildAction (SBS Smart bs) = lift $ putBuilder $ byteString bs+buildAction (SBS Copy bs) = lift $ putBuilder $ byteStringCopy bs+buildAction (SBS Insert bs) = lift $ putBuilder $ byteStringInsert bs+buildAction (SBS (Threshold i) bs) = lift $ putBuilder $ byteStringThreshold i bs+buildAction (LBS Hex lbs) = lift $ putBuilder $ lazyByteStringHexFixed lbs+buildAction (LBS Smart lbs) = lift $ putBuilder $ lazyByteString lbs+buildAction (LBS Copy lbs) = lift $ putBuilder $ lazyByteStringCopy lbs+buildAction (LBS Insert lbs) = lift $ putBuilder $ lazyByteStringInsert lbs+buildAction (LBS (Threshold i) lbs) = lift $ putBuilder $ lazyByteStringThreshold i lbs+buildAction (W8 w) = lift $ putBuilder $ word8 w+buildAction (W8S ws) = lift $ putBuilder $ BE.encodeListWithF BE.word8 ws+buildAction (String cs) = lift $ putBuilder $ stringUtf8 cs+buildAction (FDec f) = lift $ putBuilder $ floatDec f+buildAction (DDec d) = lift $ putBuilder $ doubleDec d+buildAction Flush = lift $ putBuilder $ flush+buildAction (EnsureFree minFree) = lift $ putBuilder $ ensureFree $ fromIntegral minFree+buildAction (ModState i) = do+ s <- get+ lift $ putBuilder $ intDec s+ put (s - i)++buildRecipe :: Recipe -> [Word8]+buildRecipe recipe =+ L.unpack $ toLBS b+ where+ (b, toLBS) = recipeComponents recipe+++recipeComponents :: Recipe -> (Builder, Builder -> L.ByteString)+recipeComponents (Recipe how firstSize otherSize cont as) =+ (b, toLBS)+ where+ toLBS = toLazyByteStringWith (strategy how firstSize otherSize) cont+ where+ strategy Safe = safeStrategy+ strategy Untrimmed = untrimmedStrategy++ b = fromPut $ evalStateT (mapM_ buildAction as) firstSize+++-- 'Arbitary' instances+-----------------------++instance Arbitrary L.ByteString where+ arbitrary = L.fromChunks <$> listOf arbitrary+ shrink lbs+ | L.null lbs = []+ | otherwise = pure $ L.take (L.length lbs `div` 2) lbs++instance Arbitrary S.ByteString where+ arbitrary =+ trim S.drop =<< trim S.take =<< S.pack <$> listOf arbitrary+ where+ trim f bs = oneof [pure bs, f <$> choose (0, S.length bs) <*> pure bs]++ shrink bs+ | S.null bs = []+ | otherwise = pure $ S.take (S.length bs `div` 2) bs++instance Arbitrary Mode where+ arbitrary = oneof+ [Threshold <$> arbitrary, pure Smart, pure Insert, pure Copy, pure Hex]++ shrink (Threshold i) = Threshold <$> shrink i+ shrink _ = []++instance Arbitrary Action where+ arbitrary = oneof+ [ SBS <$> arbitrary <*> arbitrary+ , LBS <$> arbitrary <*> arbitrary+ , W8 <$> arbitrary+ , W8S <$> listOf arbitrary+ -- ensure that larger character codes are also tested+ , String <$> listOf ((\c -> chr (ord c * ord c)) <$> arbitrary)+ , pure Flush+ -- never request more than 64kb free space+ , (EnsureFree . (`mod` 0xffff)) <$> arbitrary+ , FDec <$> arbitrary+ , DDec <$> arbitrary+ , ModState <$> arbitrary+ ]+ where++ shrink (SBS m bs) =+ (SBS <$> shrink m <*> pure bs) <|>+ (SBS <$> pure m <*> shrink bs)+ shrink (LBS m lbs) =+ (LBS <$> shrink m <*> pure lbs) <|>+ (LBS <$> pure m <*> shrink lbs)+ shrink (W8 w) = W8 <$> shrink w+ shrink (W8S ws) = W8S <$> shrink ws+ shrink (String cs) = String <$> shrink cs+ shrink Flush = []+ shrink (EnsureFree i) = EnsureFree <$> shrink i+ shrink (FDec f) = FDec <$> shrink f+ shrink (DDec d) = DDec <$> shrink d+ shrink (ModState i) = ModState <$> shrink i++instance Arbitrary Strategy where+ arbitrary = elements [Safe, Untrimmed]+ shrink _ = []++instance Arbitrary Recipe where+ arbitrary =+ Recipe <$> arbitrary+ <*> ((`mod` 33333) <$> arbitrary) -- bound max chunk-sizes+ <*> ((`mod` 33337) <$> arbitrary)+ <*> arbitrary+ <*> listOf arbitrary++ -- shrinking the actions first is desirable+ shrink (Recipe a b c d e) = asum+ [ (\x -> Recipe a b c d x) <$> shrink e+ , (\x -> Recipe a b c x e) <$> shrink d+ , (\x -> Recipe a b x d e) <$> shrink c+ , (\x -> Recipe a x c d e) <$> shrink b+ , (\x -> Recipe x b c d e) <$> shrink a+ ]+++------------------------------------------------------------------------------+-- Creating Builders from basic encodings+------------------------------------------------------------------------------++testsEncodingToBuilder :: [Test]+testsEncodingToBuilder =+ [ test_encodeUnfoldrF+ , test_encodeUnfoldrB++ , compareImpls "encodeSize/Chunked/Size/Chunked (recipe)"+ (testBuilder id)+ (+ parseChunks parseHexLen .+ parseSizePrefix parseHexLen .+ parseChunks parseVar .+ parseSizePrefix parseHexLen .+ testBuilder (+ prefixHexSize .+ encodeVar .+ prefixHexSize .+ encodeHex+ )+ )++ ]+++-- Unfoldr fused with encoding+------------------------------++test_encodeUnfoldrF :: Test+test_encodeUnfoldrF =+ compareImpls "encodeUnfoldrF word8" id encode+ where+ toLBS = toLazyByteStringWith (safeStrategy 23 101) L.empty+ encode =+ L.unpack . toLBS . BE.encodeUnfoldrWithF BE.word8 go+ where+ go [] = Nothing+ go (w:ws) = Just (w, ws)+++test_encodeUnfoldrB :: Test+test_encodeUnfoldrB =+ compareImpls "encodeUnfoldrB charUtf8" (concatMap charUtf8_list) encode+ where+ toLBS = toLazyByteStringWith (safeStrategy 23 101) L.empty+ encode =+ L.unpack . toLBS . BE.encodeUnfoldrWithB BE.charUtf8 go+ where+ go [] = Nothing+ go (c:cs) = Just (c, cs)+++-- Chunked encoding and size prefix+-----------------------------------++testBuilder :: (Builder -> Builder) -> Recipe -> L.ByteString+testBuilder f recipe =+ toLBS (f b)+ where+ (b, toLBS) = recipeComponents $ clearTail recipe+ -- need to remove tail of recipe to have a tighter+ -- check on encodeWithSize+ clearTail (Recipe how firstSize otherSize _ as) =+ Recipe how firstSize otherSize L.empty as++-- | Chunked encoding using base-128, variable-length encoding for the+-- chunk-size.+encodeVar :: Builder -> Builder+encodeVar =+ (`mappend` BE.encodeWithF BE.word8 0)+ . (BE.encodeChunked 5 BE.word64VarFixedBound BE.emptyB)++-- | Chunked encoding using 0-padded, space-terminated hexadecimal numbers+-- for encoding the chunk-size.+encodeHex :: Builder -> Builder+encodeHex =+ (`mappend` BE.encodeWithF (hexLen 0) 0)+ . (BE.encodeChunked 7 hexLen BE.emptyB)++hexLen :: Word64 -> BE.FixedEncoding Word64+hexLen bound =+ (\x -> (x, ' ')) BE.>$< (BE.word64HexFixedBound '0' bound BE.>*< BE.char8)++parseHexLen :: [Word8] -> (Int, [Word8])+parseHexLen ws = case span (/= 32) ws of+ (lenWS, 32:ws') -> case readHex (map (chr . fromIntegral) lenWS) of+ [(len, [])] -> (len, ws')+ _ -> error $ "hex parse failed: " ++ show ws+ (_, _) -> error $ "unterminated hex-length:" ++ show ws++parseChunks :: ([Word8] -> (Int, [Word8])) -> L.ByteString -> L.ByteString+parseChunks parseLen =+ L.pack . go . L.unpack+ where+ go ws+ | chunkLen == 0 = rest+ | chunkLen <= length ws' = chunk ++ go rest+ | otherwise = error $ "too few bytes: " ++ show ws+ where+ (chunkLen, ws') = parseLen ws+ (chunk, rest) = splitAt chunkLen ws'+++-- | Prefix with size. We use an inner buffer size of 77 (almost primes are good) to+-- get several buffer full signals.+prefixHexSize :: Builder -> Builder+prefixHexSize = BE.encodeWithSize 77 hexLen++parseSizePrefix :: ([Word8] -> (Int, [Word8])) -> L.ByteString -> L.ByteString+parseSizePrefix parseLen =+ L.pack . go . L.unpack+ where+ go ws+ | len <= length ws' = take len ws'+ | otherwise = error $ "too few bytes: " ++ show (len, ws, ws')+ where+ (len, ws') = parseLen ws+++------------------------------------------------------------------------------+-- Testing the Put monad+------------------------------------------------------------------------------++testPut :: Test+testPut = testGroup "Put monad"+ [ testLaw "identity" (\v -> (pure id <*> putInt v) `eqPut` (putInt v))++ , testLaw "composition" $ \(u, v, w) ->+ (pure (.) <*> minusInt u <*> minusInt v <*> putInt w) `eqPut`+ (minusInt u <*> (minusInt v <*> putInt w))++ , testLaw "homomorphism" $ \(f, x) ->+ (pure (f -) <*> pure x) `eqPut` (pure (f - x))++ , testLaw "interchange" $ \(u, y) ->+ (minusInt u <*> pure y) `eqPut` (pure ($ y) <*> minusInt u)++ , testLaw "ignore left value" $ \(u, v) ->+ (putInt u *> putInt v) `eqPut` (pure (const id) <*> putInt u <*> putInt v)++ , testLaw "ignore right value" $ \(u, v) ->+ (putInt u <* putInt v) `eqPut` (pure const <*> putInt u <*> putInt v)++ , testLaw "functor" $ \(f, x) ->+ (fmap (f -) (putInt x)) `eqPut` (pure (f -) <*> putInt x)++ ]+ where+ putInt i = putBuilder (integerDec i) >> return i+ minusInt i = (-) <$> putInt i+ run p = toLazyByteString $ fromPut (do i <- p; _ <- putInt i; return ())+ eqPut p1 p2 = (run p1, run p2)++ testLaw name f = compareImpls name (fst . f) (snd . f)+++------------------------------------------------------------------------------+-- Testing the Driver <-> Builder protocol+------------------------------------------------------------------------------++-- | Ensure that there are at least 'n' free bytes for the following 'Builder'.+{-# INLINE ensureFree #-}+ensureFree :: Int -> Builder+ensureFree minFree =+ BI.builder step+ where+ step k br@(BI.BufferRange op ope)+ | ope `minusPtr` op < minFree = return $ BI.bufferFull minFree op next+ | otherwise = k br+ where+ next br'@(BI.BufferRange op' ope')+ | freeSpace < minFree =+ error $ "ensureFree: requested " ++ show minFree ++ " bytes, " +++ "but got only " ++ show freeSpace ++ " bytes"+ | otherwise = k br'+ where+ freeSpace = ope' `minusPtr` op'+++------------------------------------------------------------------------------+-- Testing the pre-defined builders+------------------------------------------------------------------------------++testBuilderConstr :: (Arbitrary a, Show a)+ => TestName -> (a -> [Word8]) -> (a -> Builder) -> Test+testBuilderConstr name ref mkBuilder =+ testProperty name check+ where+ check x =+ (ws ++ ws) ==+ (L.unpack $ toLazyByteString $ mkBuilder x `mappend` mkBuilder x)+ where+ ws = ref x+++testsBinary :: [Test]+testsBinary =+ [ testBuilderConstr "word8" bigEndian_list word8+ , testBuilderConstr "int8" bigEndian_list int8++ -- big-endian+ , testBuilderConstr "int16BE" bigEndian_list int16BE+ , testBuilderConstr "int32BE" bigEndian_list int32BE+ , testBuilderConstr "int64BE" bigEndian_list int64BE++ , testBuilderConstr "word16BE" bigEndian_list word16BE+ , testBuilderConstr "word32BE" bigEndian_list word32BE+ , testBuilderConstr "word64BE" bigEndian_list word64BE++ , testBuilderConstr "floatLE" (float_list littleEndian_list) floatLE+ , testBuilderConstr "doubleLE" (double_list littleEndian_list) doubleLE++ -- little-endian+ , testBuilderConstr "int16LE" littleEndian_list int16LE+ , testBuilderConstr "int32LE" littleEndian_list int32LE+ , testBuilderConstr "int64LE" littleEndian_list int64LE++ , testBuilderConstr "word16LE" littleEndian_list word16LE+ , testBuilderConstr "word32LE" littleEndian_list word32LE+ , testBuilderConstr "word64LE" littleEndian_list word64LE++ , testBuilderConstr "floatBE" (float_list bigEndian_list) floatBE+ , testBuilderConstr "doubleBE" (double_list bigEndian_list) doubleBE++ -- host dependent+ , testBuilderConstr "int16Host" hostEndian_list int16Host+ , testBuilderConstr "int32Host" hostEndian_list int32Host+ , testBuilderConstr "int64Host" hostEndian_list int64Host+ , testBuilderConstr "intHost" hostEndian_list intHost++ , testBuilderConstr "word16Host" hostEndian_list word16Host+ , testBuilderConstr "word32Host" hostEndian_list word32Host+ , testBuilderConstr "word64Host" hostEndian_list word64Host+ , testBuilderConstr "wordHost" hostEndian_list wordHost++ , testBuilderConstr "floatHost" (float_list hostEndian_list) floatHost+ , testBuilderConstr "doubleHost" (double_list hostEndian_list) doubleHost+ ]++testsASCII :: [Test]+testsASCII =+ [ testBuilderConstr "char7" char7_list char7+ , testBuilderConstr "string7" (concatMap char7_list) string7++ , testBuilderConstr "int8Dec" dec_list int8Dec+ , testBuilderConstr "int16Dec" dec_list int16Dec+ , testBuilderConstr "int32Dec" dec_list int32Dec+ , testBuilderConstr "int64Dec" dec_list int64Dec+ , testBuilderConstr "intDec" dec_list intDec++ , testBuilderConstr "word8Dec" dec_list word8Dec+ , testBuilderConstr "word16Dec" dec_list word16Dec+ , testBuilderConstr "word32Dec" dec_list word32Dec+ , testBuilderConstr "word64Dec" dec_list word64Dec+ , testBuilderConstr "wordDec" dec_list wordDec++ , testBuilderConstr "integerDec" dec_list integerDec+ , testBuilderConstr "floatDec" dec_list floatDec+ , testBuilderConstr "doubleDec" dec_list doubleDec++ , testBuilderConstr "word8Hex" hex_list word8Hex+ , testBuilderConstr "word16Hex" hex_list word16Hex+ , testBuilderConstr "word32Hex" hex_list word32Hex+ , testBuilderConstr "word64Hex" hex_list word64Hex+ , testBuilderConstr "wordHex" hex_list wordHex++ , testBuilderConstr "word8HexFixed" wordHexFixed_list word8HexFixed+ , testBuilderConstr "word16HexFixed" wordHexFixed_list word16HexFixed+ , testBuilderConstr "word32HexFixed" wordHexFixed_list word32HexFixed+ , testBuilderConstr "word64HexFixed" wordHexFixed_list word64HexFixed++ , testBuilderConstr "int8HexFixed" int8HexFixed_list int8HexFixed+ , testBuilderConstr "int16HexFixed" int16HexFixed_list int16HexFixed+ , testBuilderConstr "int32HexFixed" int32HexFixed_list int32HexFixed+ , testBuilderConstr "int64HexFixed" int64HexFixed_list int64HexFixed++ , testBuilderConstr "floatHexFixed" floatHexFixed_list floatHexFixed+ , testBuilderConstr "doubleHexFixed" doubleHexFixed_list doubleHexFixed+ ]++testsChar8 :: [Test]+testsChar8 =+ [ testBuilderConstr "charChar8" char8_list char8+ , testBuilderConstr "stringChar8" (concatMap char8_list) string8+ ]++testsUtf8 :: [Test]+testsUtf8 =+ [ testBuilderConstr "charUtf8" charUtf8_list charUtf8+ , testBuilderConstr "stringUtf8" (concatMap charUtf8_list) stringUtf8+ ]