TestUtils.hs

{-# LANGUAGE CPP #-}

-- |
-- 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
  , coerceWord32ToFloat
  , coerceWord64ToDouble

  ) 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           System.IO.Unsafe (unsafePerformIO)

import           Test.Tasty
import           Test.Tasty.QuickCheck (Arbitrary(..), testProperty)

#include <ghcautoconf.h>

-- 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
  , testProperty (name ++ " minBound") (p (minBound :: a))
  , testProperty (name ++ " maxBound") (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]

-- See https://gitlab.haskell.org/ghc/ghc/-/issues/20338
-- and https://gitlab.haskell.org/ghc/ghc/-/issues/18445
hostEndian_list :: (Storable a, Bits a, Integral a) => a -> [Word8]
#if defined(WORDS_BIGENDIAN)
hostEndian_list = bigEndian_list
#else
hostEndian_list = littleEndian_list
#endif

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))

-- | Convert a 'Word32' to a 'Float'.
{-# NOINLINE coerceWord32ToFloat #-}
coerceWord32ToFloat :: Word32 -> Float
coerceWord32ToFloat x = unsafePerformIO (with x (peek . castPtr))

-- | Convert a 'Word64' to a 'Double'.
{-# NOINLINE coerceWord64ToDouble #-}
coerceWord64ToDouble :: Word64 -> Double
coerceWord64ToDouble 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)