{-# LANGUAGE CPP, 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 utilities for comparing -- for an example on how to use the functions provided here. -- module Data.ByteString.Builder.Prim.TestUtils ( -- * Showing evalF , evalB , showF , showB -- * Testing 'FixedPrim's , testF , testBoundedF , testFixedBoundF , compareImpls -- * Testing 'BoundedPrim'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.Builder.Prim import qualified Data.ByteString as S import qualified Data.ByteString.Internal as S import qualified Data.ByteString.Builder.Prim.Internal as I 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 #if defined(HAVE_TEST_FRAMEWORK) import Test.HUnit (assertBool) import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 #else import TestFramework #endif 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 name p , testCase (name ++ " minBound") $ assertBool "minBound" (p (minBound :: a)) , testCase (name ++ " maxBound") $ assertBool "minBound" (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) ------------------------------------------------------------------------------ -- Testing encodings ------------------------------------------------------------------------------ -- | /For testing use only./ Evaluate a 'FixedPrim' on a given value. evalF :: FixedPrim a -> a -> [Word8] evalF fe = S.unpack . S.unsafeCreate (I.size fe) . I.runF fe -- | /For testing use only./ Evaluate a 'BoundedPrim' on a given value. evalB :: BoundedPrim a -> a -> [Word8] evalB be x = S.unpack $ unsafePerformIO $ S.createAndTrim (I.sizeBound be) $ \op -> do op' <- I.runB be x op return (op' `minusPtr` op) -- | /For testing use only./ Show the result of a 'FixedPrim' of a given -- value as a 'String' by interpreting the resulting bytes as Unicode -- codepoints. showF :: FixedPrim a -> a -> String showF fe = map (chr . fromIntegral) . evalF fe -- | /For testing use only./ Show the result of a 'BoundedPrim' of a given -- value as a 'String' by interpreting the resulting bytes as Unicode -- codepoints. showB :: BoundedPrim a -> a -> String showB be = map (chr . fromIntegral) . evalB be -- FixedPrim ---------------- -- 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 'FixedPrim' against a reference implementation. testF :: (Arbitrary a, Show a) => String -> (a -> [Word8]) -> FixedPrim 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 'FixedPrim' 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]) -> FixedPrim a -> Test testBoundedF name ref fe = testBoundedProperty name $ \x -> evalF fe x == ref x -- FixedPrim derived from a bound on a given value. testFixedBoundF :: (Arbitrary a, Show a, Integral a) => String -> (a -> a -> [Word8]) -> (a -> FixedPrim 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 -- BoundedPrim ------------------ -- | Test a 'BoundedPrim' 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]) -> BoundedPrim 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 -- | Convert a 'Float' to a 'Word32'. {-# NOINLINE coerceFloatToWord32 #-} coerceFloatToWord32 :: Float -> Word32 coerceFloatToWord32 x = unsafePerformIO (with x (peek . castPtr)) -- | Convert a 'Double' to a 'Word64'. {-# NOINLINE coerceDoubleToWord64 #-} coerceDoubleToWord64 :: Double -> Word64 coerceDoubleToWord64 x = unsafePerformIO (with x (peek . castPtr)) -- | 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)