Implementation of get/put functions for floats/doubles.

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

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
 

src/Data/Binary/Put.hs

 {-# 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

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"