TestUtils.hs

{-# 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 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.Bits (Bits(..))
import           Data.Char (chr, ord)
import           Data.Int
import           Data.Word
import           Foreign (Storable(..), castPtr, minusPtr, with)
import           Numeric (showHex)
import           GHC.ByteOrder
import           System.IO.Unsafe (unsafePerformIO)

import           Test.Tasty
import           Test.Tasty.HUnit (assertBool, testCase)
import           Test.Tasty.QuickCheck (Arbitrary(..), testProperty)

-- 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) -> TestTree
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
      -> TestTree
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
             -> TestTree
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)
                -> TestTree
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
             -> TestTree
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) -> TestTree
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 targetByteOrder of
    LittleEndian -> littleEndian_list
    BigEndian    -> bigEndian_list

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)