data-binary-ieee754 0.4.2.1 → 0.4.3
raw patch · 8 files changed
+432/−413 lines, 8 filesdep −QuickCheckdep −bytestringdep −test-frameworkdep ~basedep ~binaryPVP ok
version bump matches the API change (PVP)
Dependencies removed: QuickCheck, bytestring, test-framework, test-framework-quickcheck2
Dependency ranges changed: base, binary
API changes (from Hackage documentation)
Files
- Data/Binary/IEEE754.hs +0/−119
- License.txt +0/−22
- Tests.hs +0/−241
- data-binary-ieee754.cabal +23/−31
- lib/Data/Binary/IEEE754.hs +119/−0
- license.txt +22/−0
- tests/Tests.hs +244/−0
- tests/tests.cabal +24/−0
− Data/Binary/IEEE754.hs
@@ -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)
− License.txt
@@ -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.
− Tests.hs
@@ -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")
data-binary-ieee754.cabal view
@@ -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 <jmillikin@gmail.com>+maintainer: John Millikin <jmillikin@gmail.com> 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
+ lib/Data/Binary/IEEE754.hs view
@@ -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)
+ license.txt view
@@ -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.
+ tests/Tests.hs view
@@ -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")
+ tests/tests.cabal view
@@ -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