diff --git a/Data/ByteString.hs b/Data/ByteString.hs --- a/Data/ByteString.hs +++ b/Data/ByteString.hs @@ -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 diff --git a/Data/ByteString/Internal.hs b/Data/ByteString/Internal.hs --- a/Data/ByteString/Internal.hs +++ b/Data/ByteString/Internal.hs @@ -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 diff --git a/bytestring.cabal b/bytestring.cabal --- a/bytestring.cabal +++ b/bytestring.cabal @@ -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 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 diff --git a/include/fpstring.h b/include/fpstring.h --- a/include/fpstring.h +++ b/include/fpstring.h @@ -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); } - - diff --git a/tests/QuickCheckUtils.hs b/tests/QuickCheckUtils.hs new file mode 100644 --- /dev/null +++ b/tests/QuickCheckUtils.hs @@ -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 diff --git a/tests/Rules.hs b/tests/Rules.hs new file mode 100644 --- /dev/null +++ b/tests/Rules.hs @@ -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 + ] diff --git a/tests/TestFramework.hs b/tests/TestFramework.hs new file mode 100644 --- /dev/null +++ b/tests/TestFramework.hs @@ -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!" diff --git a/tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/TestUtils.hs b/tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/TestUtils.hs new file mode 100644 --- /dev/null +++ b/tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/TestUtils.hs @@ -0,0 +1,344 @@ +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- 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) + + diff --git a/tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/Tests.hs b/tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/builder/Data/ByteString/Lazy/Builder/BasicEncoding/Tests.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- 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)) + + + + + + diff --git a/tests/builder/Data/ByteString/Lazy/Builder/Tests.hs b/tests/builder/Data/ByteString/Lazy/Builder/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/builder/Data/ByteString/Lazy/Builder/Tests.hs @@ -0,0 +1,636 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Copyright : (c) 2011 Simon Meier +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Simon Meier +-- 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 + ]