diff --git a/binary.cabal b/binary.cabal index a282ea0eab453b5f7621a9ccc1f219c6775157b2..555b2d66abd73dc94f3d08a5740a7f806a2c6dc1 100644 --- a/binary.cabal +++ b/binary.cabal @@ -31,7 +31,7 @@ source-repository head location: git://github.com/kolmodin/binary.git library - build-depends: base >= 4.5.0.0 && < 5, bytestring >= 0.10.2, containers, array + build-depends: base >= 4.5.0.0 && < 5, bytestring >= 0.10.2, containers, array, reinterpret-cast hs-source-dirs: src exposed-modules: Data.Binary, Data.Binary.Put, @@ -69,7 +69,8 @@ test-suite qc random>=1.0.1.0, test-framework, test-framework-quickcheck2 >= 0.3, - QuickCheck>=2.8 + QuickCheck>=2.8, + reinterpret-cast -- build dependencies from using binary source rather than depending on the library build-depends: array, containers @@ -89,7 +90,8 @@ test-suite read-write-file Cabal, directory, filepath, - HUnit + HUnit, + reinterpret-cast -- build dependencies from using binary source rather than depending on the library build-depends: array, containers diff --git a/src/Data/Binary/Get.hs b/src/Data/Binary/Get.hs index 40e3e70ff68c148a5d9d826b4d36c025d6ae3a30..3488f66eeb71344693b9dfc766333b718286fd82 100644 --- a/src/Data/Binary/Get.hs +++ b/src/Data/Binary/Get.hs @@ -205,6 +205,14 @@ module Data.Binary.Get ( , getInt32host , getInt64host + -- ** Decoding Floats/Doubles + , getFloatbe + , getFloatle + , getFloathost + , getDoublebe + , getDoublele + , getDoublehost + -- * Deprecated functions , runGetState -- DEPRECATED , remaining -- DEPRECATED @@ -229,6 +237,9 @@ import GHC.Base import GHC.Word #endif +-- needed for casting words to float/double +import Data.ReinterpretCast (wordToFloat, wordToDouble) + -- $lazyinterface -- The lazy interface consumes a single lazy 'L.ByteString'. It's the easiest -- interface to get started with, but it doesn't support interleaving I\/O and @@ -608,6 +619,39 @@ getInt64host = getPtr (sizeOf (undefined :: Int64)) {-# INLINE getInt64host #-} +------------------------------------------------------------------------ +-- Double/Float reads + +-- | Read a 'Float' in big endian format. +getFloatbe :: Get Float +getFloatbe = wordToFloat <$> getWord32be +{-# INLINE getFloatbe #-} + +-- | Read a 'Float' in little endian format. +getFloatle :: Get Float +getFloatle = wordToFloat <$> getWord32le +{-# INLINE getFloatle #-} + +-- | Read a 'Float' in native host order and host endianess. +getFloathost :: Get Float +getFloathost = wordToFloat <$> getWord32host +{-# INLINE getFloathost #-} + +-- | Read a 'Double' in big endian format. +getDoublebe :: Get Double +getDoublebe = wordToDouble <$> getWord64be +{-# INLINE getDoublebe #-} + +-- | Read a 'Double' in little endian format. +getDoublele :: Get Double +getDoublele = wordToDouble <$> getWord64le +{-# INLINE getDoublele #-} + +-- | Read a 'Double' in native host order and host endianess. +getDoublehost :: Get Double +getDoublehost = wordToDouble <$> getWord64host +{-# INLINE getDoublehost #-} + ------------------------------------------------------------------------ -- Unchecked shifts diff --git a/src/Data/Binary/Put.hs b/src/Data/Binary/Put.hs index 9af7c110d2fcf52b640c4829cd9d606823dfdba1..286161cbb6b290cd5ee269a99041cda56857e788 100644 --- a/src/Data/Binary/Put.hs +++ b/src/Data/Binary/Put.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Safe #-} +-- {-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} #if MIN_VERSION_base(4,9,0) #define HAS_SEMIGROUP @@ -49,6 +50,8 @@ module Data.Binary.Put ( , putInt16be , putInt32be , putInt64be + , putFloatbe + , putDoublebe -- * Little-endian primitives , putWord16le @@ -57,6 +60,8 @@ module Data.Binary.Put ( , putInt16le , putInt32le , putInt64le + , putFloatle + , putDoublele -- * Host-endian, unaligned writes , putWordhost -- :: Word -> Put @@ -67,6 +72,8 @@ module Data.Binary.Put ( , putInt16host -- :: Int16 -> Put , putInt32host -- :: Int32 -> Put , putInt64host -- :: Int64 -> Put + , putFloathost + , putDoublehost -- * Unicode , putCharUtf8 @@ -93,6 +100,8 @@ import Data.Semigroup import Control.Applicative import Prelude -- Silence AMP warning. +-- needed for casting Floats/Doubles to words. +import Data.ReinterpretCast (floatToWord, doubleToWord) ------------------------------------------------------------------------ @@ -346,6 +355,38 @@ putInt64host :: Int64 -> Put putInt64host = tell . B.putInt64host {-# INLINE putInt64host #-} +------------------------------------------------------------------------ +-- Floats/Doubles + +-- | Write a 'Float' in big endian format. +putFloatbe :: Float -> Put +putFloatbe = putWord32be . floatToWord +{-# INLINE putFloatbe #-} + +-- | Write a 'Float' in little endian format. +putFloatle :: Float -> Put +putFloatle = putWord32le . floatToWord +{-# INLINE putFloatle #-} + +-- | Write a 'Float' in native host order and host endianness. +putFloathost :: Float -> Put +putFloathost = putWord32host . floatToWord +{-# INLINE putFloathost #-} + +-- | Write a 'Double' in big endian format. +putDoublebe :: Double -> Put +putDoublebe = putWord64be . doubleToWord +{-# INLINE putDoublebe #-} + +-- | Write a 'Double' in little endian format. +putDoublele :: Double -> Put +putDoublele = putWord64le . doubleToWord +{-# INLINE putDoublele #-} + +-- | Write a 'Double' in native host order and host endianness. +putDoublehost :: Double -> Put +putDoublehost = putWord64host . doubleToWord +{-# INLINE putDoublehost #-} ------------------------------------------------------------------------ -- Unicode diff --git a/tests/QC.hs b/tests/QC.hs index 3bda2bd0343be9abfa229a0d7f4cdd10b9836e0a..650d32b5437ca337bc7a53577ec8f95fe6596ac5 100644 --- a/tests/QC.hs +++ b/tests/QC.hs @@ -131,6 +131,26 @@ prop_Int64host = roundTripWith putInt64host getInt64host prop_Inthost :: Int -> Property prop_Inthost = roundTripWith putInthost getInthost +-- Floats and Doubles + +prop_Floatbe :: Float -> Property +prop_Floatbe = roundTripWith putFloatbe getFloatbe + +prop_Floatle :: Float -> Property +prop_Floatle = roundTripWith putFloatle getFloatle + +prop_Floathost :: Float -> Property +prop_Floathost = roundTripWith putFloathost getFloathost + +prop_Doublebe :: Double -> Property +prop_Doublebe = roundTripWith putDoublebe getDoublebe + +prop_Doublele :: Double -> Property +prop_Doublele = roundTripWith putDoublele getDoublele + +prop_Doublehost :: Double -> Property +prop_Doublehost = roundTripWith putDoublehost getDoublehost + -- done, partial and fail @@ -552,6 +572,13 @@ tests = , testProperty "Int64le" (p prop_Int64le) , testProperty "Int64host" (p prop_Int64host) , testProperty "Inthost" (p prop_Inthost) + -- Float/Double + , testProperty "Floatbe" (p prop_Floatbe) + , testProperty "Floatle" (p prop_Floatle) + , testProperty "Floathost" (p prop_Floathost) + , testProperty "Doublebe" (p prop_Doublebe) + , testProperty "Doublele" (p prop_Doublele) + , testProperty "Doublehost" (p prop_Doublehost) ] , testGroup "String utils"