-----------------------------------------------------------------------------
-- |
-- Module: Tests
-- Copyright: 2010 John Millikin
-- License: MIT
--
-- Maintainer: jmillikin@gmail.com
-- Portability: portable
--
-----------------------------------------------------------------------------
module Main (tests, main) where

import Test.QuickCheck
import qualified Test.Framework as F
import Test.Framework.Providers.QuickCheck2 (testProperty)

import qualified Data.ByteString.Lazy as B
import Data.Word (Word8)
import Data.Binary.Get (Get, runGetState)
import Data.Binary.Put (Put, runPut)

import Data.Binary.IEEE754

tests :: [F.Test]
tests =
	[ F.testGroup "parsing"
		[ props_GetFloat16 "16"
		, props_GetFloat32 "32"
		, props_GetFloat64 "64"
		]
	, F.testGroup "serialising"
		[ props_PutFloat32 "32"
		, props_PutFloat64 "64"
		]
	, F.testGroup "passthrough"
		[ testPassthrough "32-le" putFloat32le getFloat32le
		, testPassthrough "32-be" putFloat32be getFloat32be
		, testPassthrough "64-le" putFloat64le getFloat64le
		, testPassthrough "64-be" putFloat64be getFloat64be
		]
	, F.testGroup "passthrough NaN"
		[ testPassthroughNaN "32-le" putFloat32le getFloat32le
		, testPassthroughNaN "32-be" putFloat32be getFloat32be
		, testPassthroughNaN "64-le" putFloat64le getFloat64le
		, testPassthroughNaN "64-be" putFloat64be getFloat64be
		]
	]

main :: IO ()
main = F.defaultMain tests

props_GetFloat16 :: String -> F.Test
props_GetFloat16 label =
	let check = checkGet getFloat16be getFloat16le in
	F.testGroup 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 -> F.Test
props_GetFloat32 label =
	let check = checkGet getFloat32be getFloat32le in
	F.testGroup 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 -> F.Test
props_GetFloat64 label =
	let check = checkGet getFloat64be getFloat64le in
	F.testGroup 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 -> F.Test
props_PutFloat32 label =
	let check = checkPut putFloat32be putFloat32le in
	F.testGroup 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 -> F.Test
props_PutFloat64 label =
	let check = checkPut putFloat64be putFloat64le in
	F.testGroup 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
         -> F.Test
checkGet getBE getLE bytes f = testProperty "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
         -> F.Test
checkPut putBE putLE bytes x = testProperty "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)
                => F.TestName
                -> (a -> Put)
                -> Get a
                -> F.Test
testPassthrough name put get = testProperty 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)
                    => F.TestName
                    -> (a -> Put)
                    -> Get a
                    -> F.Test
testPassthroughNaN name put get = testProperty name valid where
	nan = read "NaN"
	test x = decodeFloat x == decodeFloat x' && B.null remaining where
		bytes = runPut (put x)
		(x', remaining, _) = runGetState get bytes 0
	valid = test nan && test (- 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")