diff --git a/Data/Binary/IEEE754.hs b/Data/Binary/IEEE754.hs deleted file mode 100644 --- a/Data/Binary/IEEE754.hs +++ /dev/null @@ -1,119 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module: Data.Binary.IEEE754 --- Copyright: 2010 John Millikin --- License: MIT --- --- Maintainer: jmillikin@gmail.com --- Portability: portable --- ------------------------------------------------------------------------------ -module Data.Binary.IEEE754 ( - -- * Parsing - getFloat16be, getFloat16le - , getFloat32be, getFloat32le - , getFloat64be, getFloat64le - - -- * Serializing - , putFloat32be, putFloat32le - , putFloat64be, putFloat64le - - -- * Float <-> Word conversion - , floatToWord, wordToFloat - , doubleToWord, wordToDouble -) where - -import Prelude hiding (exp) -import Data.Bits (shiftL, shiftR, (.|.), (.&.)) -import qualified Data.Binary.Get as G -import qualified Data.Binary.Put as P -import qualified Foreign as F - -getFloat16be :: G.Get Float -getFloat16be = fmap toFloat16 G.getWord16be - -getFloat16le :: G.Get Float -getFloat16le = fmap toFloat16 G.getWord16le - -getFloat32be :: G.Get Float -getFloat32be = fmap toFloat G.getWord32be - -getFloat32le :: G.Get Float -getFloat32le = fmap toFloat G.getWord32le - -getFloat64be :: G.Get Double -getFloat64be = fmap toFloat G.getWord64be - -getFloat64le :: G.Get Double -getFloat64le = fmap toFloat G.getWord64le - -putFloat32be :: Float -> P.Put -putFloat32be = P.putWord32be . fromFloat - -putFloat32le :: Float -> P.Put -putFloat32le = P.putWord32le . fromFloat - -putFloat64be :: Double -> P.Put -putFloat64be = P.putWord64be . fromFloat - -putFloat64le :: Double -> P.Put -putFloat64le = P.putWord64le . fromFloat - -floatToWord :: Float -> F.Word32 -floatToWord = fromFloat - -wordToFloat :: F.Word32 -> Float -wordToFloat = toFloat - -doubleToWord :: Double -> F.Word64 -doubleToWord = fromFloat - -wordToDouble :: F.Word64 -> Double -wordToDouble = toFloat - -toFloat :: (F.Storable word, F.Storable float) => word -> float -toFloat word = F.unsafePerformIO $ F.alloca $ \buf -> do - F.poke (F.castPtr buf) word - F.peek buf - -fromFloat :: (F.Storable word, F.Storable float) => float -> word -fromFloat float = F.unsafePerformIO $ F.alloca $ \buf -> do - F.poke (F.castPtr buf) float - F.peek buf - -toFloat16 :: F.Word16 -> Float -toFloat16 word16 = toFloat (sign32 .|. word32) where - sign16 = word16 .&. 0x8000 - exp16 = word16 .&. 0x7C00 - frac16 = word16 .&. 0x3FF - - sign32 = if sign16 > 0 - then 0x80000000 -- -0.0 - else 0 - - word32 :: F.Word32 - word32 | word16 .&. 0x7FFF == 0 = 0 - | exp16 == 0x7C00 = special - | otherwise = shiftL exp32 23 .|. shiftL frac32 13 - - special = if frac16 == 0 - -- Infinity - then 0x7F800000 - - -- NaN; signals are maintained in lower 10 bits - else 0x7FC00000 .|. fromIntegral frac16 - - (exp32, frac32) = if exp16 > 0 - then normalised - else denormalised - - normalised = (exp, frac) where - exp = (fromIntegral exp16 `shiftR` 10) - 15 + 127 - frac = fromIntegral frac16 - - denormalised = (exp, frac) where - exp = (fromIntegral exp16 `shiftR` 10) - 15 + 127 - e - (e, frac ) = step 0 (shiftL frac16 1) where - step acc x = if x .&. 0x400 == 0 - then step (acc + 1) (shiftL x 1) - else (acc, fromIntegral x .&. 0x3FF) diff --git a/License.txt b/License.txt deleted file mode 100644 --- a/License.txt +++ /dev/null @@ -1,22 +0,0 @@ -Copyright (c) 2010 John Millikin - -Permission is hereby granted, free of charge, to any person -obtaining a copy of this software and associated documentation -files (the "Software"), to deal in the Software without -restriction, including without limitation the rights to use, -copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the -Software is furnished to do so, subject to the following -conditions: - -The above copyright notice and this permission notice shall be -included in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES -OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT -HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, -WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR -OTHER DEALINGS IN THE SOFTWARE. diff --git a/Tests.hs b/Tests.hs deleted file mode 100644 --- a/Tests.hs +++ /dev/null @@ -1,241 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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") diff --git a/data-binary-ieee754.cabal b/data-binary-ieee754.cabal --- a/data-binary-ieee754.cabal +++ b/data-binary-ieee754.cabal @@ -1,48 +1,40 @@ name: data-binary-ieee754 -version: 0.4.2.1 -synopsis: Parser/Serialiser for IEEE-754 floating-point values -description: Convert Float and Decimal values to/from raw octets. +version: 0.4.3 license: MIT -license-file: License.txt -author: John Millikin -maintainer: jmillikin@gmail.com +license-file: license.txt +author: John Millikin +maintainer: John Millikin build-type: Simple -cabal-version: >=1.6 +cabal-version: >= 1.6 category: Data stability: experimental +homepage: https://john-millikin.com/software/data-binary-ieee754/ bug-reports: mailto:jmillikin@gmail.com -homepage: http://john-millikin.com/software/data-binary-ieee754/ -tested-with: GHC==6.12.1 +synopsis: Parser/Serialiser for IEEE-754 floating-point values +description: + Convert Float and Decimal values to/from raw octets. + +extra-source-files: + tests/*.hs + tests/tests.cabal + source-repository head type: bazaar - location: http://john-millikin.com/software/data-binary-ieee754/ + location: https://john-millikin.com/branches/data-binary-ieee754/0.4/ -flag test - default: False +source-repository this + type: bazaar + location: https://john-millikin.com/branches/data-binary-ieee754/0.4/ + tag: data-binary-ieee754_0.4.3 library - if true - ghc-options: -Wall - - if impl(ghc >= 6.11) - ghc-options: -fno-warn-unused-do-bind + ghc-options: -Wall -O2 + hs-source-dirs: lib build-depends: - base >= 3.0 && < 5 - , binary >= 0.4 && < 0.6 + base >= 4.1 && < 5.0 + , binary >= 0.4 exposed-modules: Data.Binary.IEEE754 - -executable data-binary-ieee754_tests - main-is: Tests.hs - - if flag(test) - build-depends: - QuickCheck >= 2.2 && < 2.4 - , test-framework >= 0.2 && < 0.4 - , test-framework-quickcheck2 >= 0.2 && < 0.3 - , bytestring >= 0.9 && < 0.10 - else - buildable: False diff --git a/lib/Data/Binary/IEEE754.hs b/lib/Data/Binary/IEEE754.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Binary/IEEE754.hs @@ -0,0 +1,119 @@ +----------------------------------------------------------------------------- +-- | +-- Module: Data.Binary.IEEE754 +-- Copyright: 2010 John Millikin +-- License: MIT +-- +-- Maintainer: jmillikin@gmail.com +-- Portability: portable +-- +----------------------------------------------------------------------------- +module Data.Binary.IEEE754 ( + -- * Parsing + getFloat16be, getFloat16le + , getFloat32be, getFloat32le + , getFloat64be, getFloat64le + + -- * Serializing + , putFloat32be, putFloat32le + , putFloat64be, putFloat64le + + -- * Float <-> Word conversion + , floatToWord, wordToFloat + , doubleToWord, wordToDouble +) where + +import Prelude hiding (exp) +import Data.Bits (shiftL, shiftR, (.|.), (.&.)) +import qualified Data.Binary.Get as G +import qualified Data.Binary.Put as P +import qualified Foreign as F + +getFloat16be :: G.Get Float +getFloat16be = fmap toFloat16 G.getWord16be + +getFloat16le :: G.Get Float +getFloat16le = fmap toFloat16 G.getWord16le + +getFloat32be :: G.Get Float +getFloat32be = fmap toFloat G.getWord32be + +getFloat32le :: G.Get Float +getFloat32le = fmap toFloat G.getWord32le + +getFloat64be :: G.Get Double +getFloat64be = fmap toFloat G.getWord64be + +getFloat64le :: G.Get Double +getFloat64le = fmap toFloat G.getWord64le + +putFloat32be :: Float -> P.Put +putFloat32be = P.putWord32be . fromFloat + +putFloat32le :: Float -> P.Put +putFloat32le = P.putWord32le . fromFloat + +putFloat64be :: Double -> P.Put +putFloat64be = P.putWord64be . fromFloat + +putFloat64le :: Double -> P.Put +putFloat64le = P.putWord64le . fromFloat + +floatToWord :: Float -> F.Word32 +floatToWord = fromFloat + +wordToFloat :: F.Word32 -> Float +wordToFloat = toFloat + +doubleToWord :: Double -> F.Word64 +doubleToWord = fromFloat + +wordToDouble :: F.Word64 -> Double +wordToDouble = toFloat + +toFloat :: (F.Storable word, F.Storable float) => word -> float +toFloat word = F.unsafePerformIO $ F.alloca $ \buf -> do + F.poke (F.castPtr buf) word + F.peek buf + +fromFloat :: (F.Storable word, F.Storable float) => float -> word +fromFloat float = F.unsafePerformIO $ F.alloca $ \buf -> do + F.poke (F.castPtr buf) float + F.peek buf + +toFloat16 :: F.Word16 -> Float +toFloat16 word16 = toFloat (sign32 .|. word32) where + sign16 = word16 .&. 0x8000 + exp16 = word16 .&. 0x7C00 + frac16 = word16 .&. 0x3FF + + sign32 = if sign16 > 0 + then 0x80000000 -- -0.0 + else 0 + + word32 :: F.Word32 + word32 | word16 .&. 0x7FFF == 0 = 0 + | exp16 == 0x7C00 = special + | otherwise = shiftL exp32 23 .|. shiftL frac32 13 + + special = if frac16 == 0 + -- Infinity + then 0x7F800000 + + -- NaN; signals are maintained in lower 10 bits + else 0x7FC00000 .|. fromIntegral frac16 + + (exp32, frac32) = if exp16 > 0 + then normalised + else denormalised + + normalised = (exp, frac) where + exp = (fromIntegral exp16 `shiftR` 10) - 15 + 127 + frac = fromIntegral frac16 + + denormalised = (exp, frac) where + exp = (fromIntegral exp16 `shiftR` 10) - 15 + 127 - e + (e, frac ) = step 0 (shiftL frac16 1) where + step acc x = if x .&. 0x400 == 0 + then step (acc + 1) (shiftL x 1) + else (acc, fromIntegral x .&. 0x3FF) diff --git a/license.txt b/license.txt new file mode 100644 --- /dev/null +++ b/license.txt @@ -0,0 +1,22 @@ +Copyright (c) 2010 John Millikin + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,244 @@ +----------------------------------------------------------------------------- +-- | +-- 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") diff --git a/tests/tests.cabal b/tests/tests.cabal new file mode 100644 --- /dev/null +++ b/tests/tests.cabal @@ -0,0 +1,24 @@ +name: tests +version: 0 +build-type: Simple +cabal-version: >= 1.6 + +flag coverage + default: False + manual: True + +executable data-binary-ieee754-tests + main-is: Tests.hs + ghc-options: -Wall -fcontext-stack=50 + + if flag(coverage) + ghc-options: -fhpc + + build-depends: + base >= 4.1 && < 5.0 + , binary + , bytestring >= 0.9 + , chell >= 0.3 && < 0.4 + , chell-quickcheck >= 0.2 && < 0.3 + , data-binary-ieee754 + , QuickCheck