-----------------------------------------------------------------------------
-- |
-- Module: Tests
-- Copyright: 2010 John Millikin
-- License: MIT
--
-- Maintainer: jmillikin@gmail.com
-- Portability: portable
--
-----------------------------------------------------------------------------
module Main (tests, main) where
import qualified Data.ByteString.Lazy as B
import Data.Word (Word8)
import Data.Binary.Get (Get, runGetState)
import Data.Binary.Put (Put, runPut)
import Test.Chell
import Test.Chell.QuickCheck
import Test.QuickCheck hiding (label, property)
import Data.Binary.IEEE754
tests :: [Suite]
tests =
[ test_Parsing
, test_Serialising
, test_Passthrough
, test_Passthrough_NaN
]
main :: IO ()
main = Test.Chell.defaultMain tests
test_Parsing :: Suite
test_Parsing = suite "parsing"
(props_GetFloat16 "16")
(props_GetFloat32 "32")
(props_GetFloat64 "64")
test_Serialising :: Suite
test_Serialising = suite "serialising"
(props_PutFloat32 "32")
(props_PutFloat64 "64")
test_Passthrough :: Suite
test_Passthrough = suite "passthrough"
(testPassthrough "32-le" putFloat32le getFloat32le)
(testPassthrough "32-be" putFloat32be getFloat32be)
(testPassthrough "64-le" putFloat64le getFloat64le)
(testPassthrough "64-be" putFloat64be getFloat64be)
test_Passthrough_NaN :: Suite
test_Passthrough_NaN = suite "passthrough-nan"
(testPassthroughNaN "32-le" putFloat32le getFloat32le)
(testPassthroughNaN "32-be" putFloat32be getFloat32be)
(testPassthroughNaN "64-le" putFloat64le getFloat64le)
(testPassthroughNaN "64-be" putFloat64be getFloat64be)
props_GetFloat16 :: String -> Suite
props_GetFloat16 label =
let check = checkGet getFloat16be getFloat16le in
suite label
(check [0, 0] ((== 0.0) .&& (not . isNegativeZero)))
(check [0x80, 0] isNegativeZero)
-- Normalised
(check [0x3C, 0] (== 1.0))
(check [0xBC, 0] (== -1.0))
-- Denormalised
(check [0x03, 0xFF] (== 6.097555e-5))
(check [0x83, 0xFF] (== -6.097555e-5))
-- Infinity
(check [0x7C, 0] (== inf32))
(check [0xFC, 0] (== -inf32))
-- NaN
(check [0x7E, 0] (isNaN .&& (not . isNegativeNaN)))
(check [0xFE, 0] isNegativeNaN)
props_GetFloat32 :: String -> Suite
props_GetFloat32 label =
let check = checkGet getFloat32be getFloat32le in
suite label
(check [0, 0, 0, 0] ((== 0.0) .&& (not . isNegativeZero)))
(check [0x80, 0, 0, 0] isNegativeZero)
-- Normalised
(check [0x3F, 0x80, 0, 0] (== 1.0))
(check [0xBF, 0x80, 0, 0] (== -1.0))
-- Denormalised
(check [0x00, 0x7F, 0xFF, 0xFF] (== 1.1754942106924411e-38))
(check [0x80, 0x7F, 0xFF, 0xFF] (== -1.1754942106924411e-38))
-- Infinity
(check [0x7F, 0x80, 0, 0] (== inf32))
(check [0xFF, 0x80, 0, 0] (== -inf32))
-- NaN and negative NaN
(check [0x7F, 0xC0, 0, 0] (isNaN .&& (not . isNegativeNaN)))
(check [0xFF, 0xC0, 0, 0] isNegativeNaN)
props_GetFloat64 :: String -> Suite
props_GetFloat64 label =
let check = checkGet getFloat64be getFloat64le in
suite label
(check [0, 0, 0, 0, 0, 0, 0, 0] ((== 0.0) .&& (not . isNegativeZero)))
(check [0x80, 0, 0, 0, 0, 0, 0, 0] isNegativeZero)
-- Normalised
(check [0x3F, 0xF0, 0, 0, 0, 0, 0, 0] (== 1.0))
(check [0xBF, 0xF0, 0, 0, 0, 0, 0, 0] (== -1.0))
-- Denormalised
(check [0x00, 0x0F, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF] (== 2.2250738585072009e-308))
(check [0x80, 0x0F, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF] (== -2.2250738585072009e-308))
-- Infinity
(check [0x7F, 0xF0, 0, 0, 0, 0, 0, 0] (== inf64))
(check [0xFF, 0xF0, 0, 0, 0, 0, 0, 0] (== -inf64))
-- NaN
(check [0x7F, 0xF8, 0, 0, 0, 0, 0, 0] (isNaN .&& (not . isNegativeNaN)))
(check [0xFF, 0xF8, 0, 0, 0, 0, 0, 0] isNegativeNaN)
props_PutFloat32 :: String -> Suite
props_PutFloat32 label =
let check = checkPut putFloat32be putFloat32le in
suite label
(check [0, 0, 0, 0] 0.0)
(check [0x80, 0, 0, 0] (-0.0))
-- Normalised
(check [0x3F, 0x80, 0, 0] 1.0)
(check [0xBF, 0x80, 0, 0] (-1.0))
-- Denormalised
(check [0x00, 0x7F, 0xFF, 0xFF] 1.1754942106924411e-38)
(check [0x80, 0x7F, 0xFF, 0xFF] (-1.1754942106924411e-38))
-- Infinity
(check [0x7F, 0x80, 0, 0] inf32)
(check [0xFF, 0x80, 0, 0] (-inf32))
-- NaN
(check [0x7F, 0xC0, 0, 0] nan32)
(check [0xFF, 0xC0, 0, 0] (-nan32))
props_PutFloat64 :: String -> Suite
props_PutFloat64 label =
let check = checkPut putFloat64be putFloat64le in
suite label
(check [0, 0, 0, 0, 0, 0, 0, 0] 0.0)
(check [0x80, 0, 0, 0, 0, 0, 0, 0] (-0.0))
-- Normalised
(check [0x3F, 0xF0, 0, 0, 0, 0, 0, 0] 1.0)
(check [0xBF, 0xF0, 0, 0, 0, 0, 0, 0] (-1.0))
-- Denormalised
(check [0x00, 0x0F, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF] 2.2250738585072009e-308)
(check [0x80, 0x0F, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF] (-2.2250738585072009e-308))
-- Infinity
(check [0x7F, 0xF0, 0, 0, 0, 0, 0, 0] inf64)
(check [0xFF, 0xF0, 0, 0, 0, 0, 0, 0] (-inf64))
-- NaN
(check [0x7F, 0xF8, 0, 0, 0, 0, 0, 0] nan64)
(check [0xFF, 0xF8, 0, 0, 0, 0, 0, 0] (-nan64))
checkGet :: (Show a, Eq a, RealFloat a)
=> Get a -- ^ big endian
-> Get a -- ^ little endian
-> [Word8] -- ^ big-endian bytes
-> (a -> Bool) -- ^ verify result
-> Test
checkGet getBE getLE bytes f = property "get" $ forAll (return bytes) (const valid) where
valid = B.null remainingBE && B.null remainingLE && f xBE && f xLE
(xBE, remainingBE, _) = runGetState getBE (B.pack bytes) 0
(xLE, remainingLE, _) = runGetState getLE (B.pack (reverse bytes)) 0
checkPut :: Show a
=> (a -> Put) -- ^ big endian
-> (a -> Put) -- ^ little endian
-> [Word8] -- ^ expected big-endian bytes
-> a
-> Test
checkPut putBE putLE bytes x = property "put" $ forAll (return x) (const valid) where
valid = sameResult && bytes == B.unpack bytesBE
sameResult = bytesBE == B.reverse bytesLE
bytesBE = runPut (putBE x)
bytesLE = runPut (putLE x)
(.&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
(.&&) f g x = f x && g x
isNegativeNaN :: RealFloat a => a -> Bool
isNegativeNaN x = isNaN x && frac < 0 where
(frac, _) = decodeFloat x
-- Verify that the given put and get functions are inverses.
testPassthrough :: (Arbitrary a, Show a, Eq a)
=> String
-> (a -> Put)
-> Get a
-> Test
testPassthrough name put get = property name $ \x -> let
bytes = runPut (put x)
(x', remaining, _) = runGetState get bytes 0
in x == x' && B.null remaining
testPassthroughNaN :: (Arbitrary a, RealFloat a, Read a)
=> String
-> (a -> Put)
-> Get a
-> Test
testPassthroughNaN name put get = property name valid where
nan = read "NaN"
check x = decodeFloat x == decodeFloat x' && B.null remaining where
bytes = runPut (put x)
(x', remaining, _) = runGetState get bytes 0
valid = check nan && check (- nan)
-- Pseudo-literals for special values
inf32 :: Float
inf32 = read "Infinity"
inf64 :: Double
inf64 = read "Infinity"
nan32 :: Float
nan32 = - (read "NaN")
nan64 :: Double
nan64 = - (read "NaN")