{-# 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.Builder.Prim.Tests (tests) where import Control.Arrow (first) import Data.Char (ord) import qualified Data.ByteString.Lazy as L import Data.ByteString.Builder import qualified Data.ByteString.Builder.Prim as BP import qualified Data.ByteString.Builder.Prim.Extra as BP import Data.ByteString.Builder.Prim.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 BP.word8 , testBoundedF "int8" bigEndian_list BP.int8 -- big-endian , testBoundedF "int16BE" bigEndian_list BP.int16BE , testBoundedF "int32BE" bigEndian_list BP.int32BE , testBoundedF "int64BE" bigEndian_list BP.int64BE , testBoundedF "word16BE" bigEndian_list BP.word16BE , testBoundedF "word32BE" bigEndian_list BP.word32BE , testBoundedF "word64BE" bigEndian_list BP.word64BE , testF "floatLE" (float_list littleEndian_list) BP.floatLE , testF "doubleLE" (double_list littleEndian_list) BP.doubleLE -- little-endian , testBoundedF "int16LE" littleEndian_list BP.int16LE , testBoundedF "int32LE" littleEndian_list BP.int32LE , testBoundedF "int64LE" littleEndian_list BP.int64LE , testBoundedF "word16LE" littleEndian_list BP.word16LE , testBoundedF "word32LE" littleEndian_list BP.word32LE , testBoundedF "word64LE" littleEndian_list BP.word64LE , testF "floatBE" (float_list bigEndian_list) BP.floatBE , testF "doubleBE" (double_list bigEndian_list) BP.doubleBE -- host dependent , testBoundedF "int16Host" hostEndian_list BP.int16Host , testBoundedF "int32Host" hostEndian_list BP.int32Host , testBoundedF "int64Host" hostEndian_list BP.int64Host , testBoundedF "intHost" hostEndian_list BP.intHost , testBoundedF "word16Host" hostEndian_list BP.word16Host , testBoundedF "word32Host" hostEndian_list BP.word32Host , testBoundedF "word64Host" hostEndian_list BP.word64Host , testBoundedF "wordHost" hostEndian_list BP.wordHost , testF "floatHost" (float_list hostEndian_list) BP.floatHost , testF "doubleHost" (double_list hostEndian_list) BP.doubleHost , testBoundedB "word8Var" genVar_list BP.word8Var , testBoundedB "word16Var" genVar_list BP.word16Var , testBoundedB "word32Var" genVar_list BP.word32Var , testBoundedB "word64Var" genVar_list BP.word64Var , testBoundedB "wordVar" genVar_list BP.wordVar , testBoundedB "int8Var" int8Var_list BP.int8Var , testBoundedB "int16Var" int16Var_list BP.int16Var , testBoundedB "int32Var" int32Var_list BP.int32Var , testBoundedB "int64Var" int64Var_list BP.int64Var , testBoundedB "intVar" intVar_list BP.intVar , testBoundedB "int8VarSigned" (int8Var_list . zigZag) BP.int8VarSigned , testBoundedB "int16VarSigned" (int16Var_list . zigZag) BP.int16VarSigned , testBoundedB "int32VarSigned" (int32Var_list . zigZag) BP.int32VarSigned , testBoundedB "int64VarSigned" (int64Var_list . zigZag) BP.int64VarSigned , testBoundedB "intVarSigned" (intVar_list . zigZag) BP.intVarSigned , testGroup "parseable" [ prop_zigZag_parseable "int8VarSigned" unZigZagInt8 BP.int8VarSigned , prop_zigZag_parseable "int16VarSigned" unZigZagInt16 BP.int16VarSigned , prop_zigZag_parseable "int32VarSigned" unZigZagInt32 BP.int32VarSigned , prop_zigZag_parseable "int64VarSigned" unZigZagInt64 BP.int64VarSigned , prop_zigZag_parseable "intVarSigned" unZigZagInt BP.intVarSigned ] , testFixedBoundF "wordVarFixedBound" wordVarFixedBound_list BP.wordVarFixedBound , testFixedBoundF "word64VarFixedBound" word64VarFixedBound_list BP.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) -> BP.BoundedPrim t -> Test prop_zigZag_parseable name unZig be = compareImpls name (\x -> (x, [])) (first unZig . parseVar . 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 BP.char8 ] ------------------------------------------------------------------------------ -- ASCII ------------------------------------------------------------------------------ testsASCII :: [Test] testsASCII = [ testBoundedF "char7" char7_list BP.char7 , testBoundedB "int8Dec" dec_list BP.int8Dec , testBoundedB "int16Dec" dec_list BP.int16Dec , testBoundedB "int32Dec" dec_list BP.int32Dec , testBoundedB "int64Dec" dec_list BP.int64Dec , testBoundedB "intDec" dec_list BP.intDec , testBoundedB "word8Dec" dec_list BP.word8Dec , testBoundedB "word16Dec" dec_list BP.word16Dec , testBoundedB "word32Dec" dec_list BP.word32Dec , testBoundedB "word64Dec" dec_list BP.word64Dec , testBoundedB "wordDec" dec_list BP.wordDec , testBoundedB "word8Hex" hex_list BP.word8Hex , testBoundedB "word16Hex" hex_list BP.word16Hex , testBoundedB "word32Hex" hex_list BP.word32Hex , testBoundedB "word64Hex" hex_list BP.word64Hex , testBoundedB "wordHex" hex_list BP.wordHex , testBoundedF "word8HexFixed" wordHexFixed_list BP.word8HexFixed , testBoundedF "word16HexFixed" wordHexFixed_list BP.word16HexFixed , testBoundedF "word32HexFixed" wordHexFixed_list BP.word32HexFixed , testBoundedF "word64HexFixed" wordHexFixed_list BP.word64HexFixed , testBoundedF "int8HexFixed" int8HexFixed_list BP.int8HexFixed , testBoundedF "int16HexFixed" int16HexFixed_list BP.int16HexFixed , testBoundedF "int32HexFixed" int32HexFixed_list BP.int32HexFixed , testBoundedF "int64HexFixed" int64HexFixed_list BP.int64HexFixed , testF "floatHexFixed" floatHexFixed_list BP.floatHexFixed , testF "doubleHexFixed" doubleHexFixed_list BP.doubleHexFixed , testFixedBoundF "wordDecFixedBound" (genDecFixedBound_list 'x') (BP.wordDecFixedBound 'x') , testFixedBoundF "word64DecFixedBound" (genDecFixedBound_list 'x') (BP.word64DecFixedBound 'x') , testFixedBoundF "wordHexFixedBound" (genHexFixedBound_list 'x') (BP.wordHexFixedBound 'x') , testFixedBoundF "word64HexFixedBound" (genHexFixedBound_list 'x') (BP.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 BP.charUtf8 ] ------------------------------------------------------------------------------ -- BoundedPrim combinators ------------------------------------------------------------------------------ maybeB :: BP.BoundedPrim () -> BP.BoundedPrim a -> BP.BoundedPrim (Maybe a) maybeB nothing just = maybe (Left ()) Right BP.>$< BP.eitherB nothing just testsCombinatorsB :: [Test] testsCombinatorsB = [ compareImpls "mapMaybe (via BoundedPrim)" (L.pack . concatMap encChar) (toLazyByteString . encViaBuilder) , compareImpls "filter (via BoundedPrim)" (L.pack . filter (< 32)) (toLazyByteString . BP.primMapListBounded (BP.condB (< 32) (BP.liftFixedToBounded BP.word8) BP.emptyB)) , compareImpls "pairB" (L.pack . concatMap (\(c,w) -> charUtf8_list c ++ [w])) (toLazyByteString . BP.primMapListBounded ((\(c,w) -> (c,(w,undefined))) BP.>$< BP.charUtf8 BP.>*< (BP.liftFixedToBounded BP.word8) BP.>*< (BP.liftFixedToBounded BP.emptyF))) ] where encChar = maybe [112] (hostEndian_list . ord) encViaBuilder = BP.primMapListBounded $ maybeB (BP.liftFixedToBounded $ (\_ -> 112) BP.>$< BP.word8) (ord BP.>$< (BP.liftFixedToBounded $ BP.intHost))