diff --git a/binary.cabal b/binary.cabal
index 70161c4067ff6afff8ead3fd6dac813c56821fa8..a08de8d098aa48ac57d39cd43fa25459beff6d22 100644
--- a/binary.cabal
+++ b/binary.cabal
@@ -41,7 +41,8 @@ library
other-modules: Data.Binary.Class,
Data.Binary.Internal,
- Data.Binary.Generic
+ Data.Binary.Generic,
+ Data.Binary.FloatCast
if impl(ghc <= 7.6)
-- prior to ghc-7.4 generics lived in ghc-prim
build-depends: ghc-prim
@@ -168,6 +169,7 @@ benchmark generics-bench
unordered-containers,
zlib,
criterion
+
other-modules:
GenericsBenchCache
GenericsBenchTypes
diff --git a/src/Data/Binary/FloatCast.hs b/src/Data/Binary/FloatCast.hs
new file mode 100644
index 0000000000000000000000000000000000000000..2eb86f0aa987143b21c0cd93346ff56ac915479a
--- /dev/null
+++ b/src/Data/Binary/FloatCast.hs
@@ -0,0 +1,45 @@
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE Trustworthy #-}
+
+-- | This module was written based on
+-- <http://hackage.haskell.org/package/reinterpret-cast-0.1.0/docs/src/Data-ReinterpretCast-Internal-ImplArray.html>.
+--
+-- Implements casting via a 1-elemnt STUArray, as described in
+-- <http://stackoverflow.com/a/7002812/263061>.
+module Data.Binary.FloatCast
+ ( floatToWord
+ , wordToFloat
+ , doubleToWord
+ , wordToDouble
+ ) where
+
+import Data.Word (Word32, Word64)
+import Data.Array.ST (newArray, readArray, MArray, STUArray)
+import Data.Array.Unsafe (castSTUArray)
+import GHC.ST (runST, ST)
+
+-- | Reinterpret-casts a `Float` to a `Word32`.
+floatToWord :: Float -> Word32
+floatToWord x = runST (cast x)
+{-# INLINE floatToWord #-}
+
+-- | Reinterpret-casts a `Word32` to a `Float`.
+wordToFloat :: Word32 -> Float
+wordToFloat x = runST (cast x)
+{-# INLINE wordToFloat #-}
+
+-- | Reinterpret-casts a `Double` to a `Word64`.
+doubleToWord :: Double -> Word64
+doubleToWord x = runST (cast x)
+{-# INLINE doubleToWord #-}
+
+-- | Reinterpret-casts a `Word64` to a `Double`.
+wordToDouble :: Word64 -> Double
+wordToDouble x = runST (cast x)
+{-# INLINE wordToDouble #-}
+
+cast :: (MArray (STUArray s) a (ST s),
+ MArray (STUArray s) b (ST s)) => a -> ST s b
+cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0
+{-# INLINE cast #-}
diff --git a/src/Data/Binary/Get.hs b/src/Data/Binary/Get.hs
index 40e3e70ff68c148a5d9d826b4d36c025d6ae3a30..62207594e68367836cf912165f817be2509343b9 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.Binary.FloatCast (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
@@ -529,33 +540,33 @@ word64le = \s ->
{-# INLINE word64le #-}
--- | Read an Int16 in big endian format
+-- | Read an Int16 in big endian format.
getInt16be :: Get Int16
getInt16be = fromIntegral <$> getWord16be
{-# INLINE getInt16be #-}
--- | Read an Int32 in big endian format
+-- | Read an Int32 in big endian format.
getInt32be :: Get Int32
getInt32be = fromIntegral <$> getWord32be
{-# INLINE getInt32be #-}
--- | Read an Int64 in big endian format
+-- | Read an Int64 in big endian format.
getInt64be :: Get Int64
getInt64be = fromIntegral <$> getWord64be
{-# INLINE getInt64be #-}
--- | Read an Int16 in little endian format
+-- | Read an Int16 in little endian format.
getInt16le :: Get Int16
getInt16le = fromIntegral <$> getWord16le
{-# INLINE getInt16le #-}
--- | Read an Int32 in little endian format
+-- | Read an Int32 in little endian format.
getInt32le :: Get Int32
getInt32le = fromIntegral <$> getWord32le
{-# INLINE getInt32le #-}
--- | Read an Int64 in little endian format
+-- | Read an Int64 in little endian format.
getInt64le :: Get Int64
getInt64le = fromIntegral <$> getWord64le
{-# INLINE getInt64le #-}
@@ -608,6 +619,39 @@ getInt64host = getPtr (sizeOf (undefined :: Int64))
{-# INLINE getInt64host #-}
+------------------------------------------------------------------------
+-- Double/Float reads
+
+-- | Read a 'Float' in big endian IEEE-754 format.
+getFloatbe :: Get Float
+getFloatbe = wordToFloat <$> getWord32be
+{-# INLINE getFloatbe #-}
+
+-- | Read a 'Float' in little endian IEEE-754 format.
+getFloatle :: Get Float
+getFloatle = wordToFloat <$> getWord32le
+{-# INLINE getFloatle #-}
+
+-- | Read a 'Float' in IEEE-754 format and host endian.
+getFloathost :: Get Float
+getFloathost = wordToFloat <$> getWord32host
+{-# INLINE getFloathost #-}
+
+-- | Read a 'Double' in big endian IEEE-754 format.
+getDoublebe :: Get Double
+getDoublebe = wordToDouble <$> getWord64be
+{-# INLINE getDoublebe #-}
+
+-- | Read a 'Double' in little endian IEEE-754 format.
+getDoublele :: Get Double
+getDoublele = wordToDouble <$> getWord64le
+{-# INLINE getDoublele #-}
+
+-- | Read a 'Double' in IEEE-754 format and host endian.
+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..32fb618d8ed49b59468162c81ffa16717ac06257 100644
--- a/src/Data/Binary/Put.hs
+++ b/src/Data/Binary/Put.hs
@@ -49,6 +49,8 @@ module Data.Binary.Put (
, putInt16be
, putInt32be
, putInt64be
+ , putFloatbe
+ , putDoublebe
-- * Little-endian primitives
, putWord16le
@@ -57,6 +59,8 @@ module Data.Binary.Put (
, putInt16le
, putInt32le
, putInt64le
+ , putFloatle
+ , putDoublele
-- * Host-endian, unaligned writes
, putWordhost -- :: Word -> Put
@@ -67,6 +71,8 @@ module Data.Binary.Put (
, putInt16host -- :: Int16 -> Put
, putInt32host -- :: Int32 -> Put
, putInt64host -- :: Int64 -> Put
+ , putFloathost
+ , putDoublehost
-- * Unicode
, putCharUtf8
@@ -93,6 +99,8 @@ import Data.Semigroup
import Control.Applicative
import Prelude -- Silence AMP warning.
+-- needed for casting Floats/Doubles to words.
+import Data.Binary.FloatCast (floatToWord, doubleToWord)
------------------------------------------------------------------------
@@ -346,6 +354,38 @@ putInt64host :: Int64 -> Put
putInt64host = tell . B.putInt64host
{-# INLINE putInt64host #-}
+------------------------------------------------------------------------
+-- Floats/Doubles
+
+-- | Write a 'Float' in big endian IEEE-754 format.
+putFloatbe :: Float -> Put
+putFloatbe = putWord32be . floatToWord
+{-# INLINE putFloatbe #-}
+
+-- | Write a 'Float' in little endian IEEE-754 format.
+putFloatle :: Float -> Put
+putFloatle = putWord32le . floatToWord
+{-# INLINE putFloatle #-}
+
+-- | Write a 'Float' in native in IEEE-754 format and host endian.
+putFloathost :: Float -> Put
+putFloathost = putWord32host . floatToWord
+{-# INLINE putFloathost #-}
+
+-- | Write a 'Double' in big endian IEEE-754 format.
+putDoublebe :: Double -> Put
+putDoublebe = putWord64be . doubleToWord
+{-# INLINE putDoublebe #-}
+
+-- | Write a 'Double' in little endian IEEE-754 format.
+putDoublele :: Double -> Put
+putDoublele = putWord64le . doubleToWord
+{-# INLINE putDoublele #-}
+
+-- | Write a 'Double' in native in IEEE-754 format and host endian.
+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"