[commit: packages/binary] master: Implementation of get/put functions for floats/doubles. (f3ec4e3)
git at git.haskell.org
git at git.haskell.org
Sat Feb 4 21:17:27 UTC 2017
Repository : ssh://git@git.haskell.org/binary
On branch : master
Link : http://git.haskell.org/packages/binary.git/commitdiff/f3ec4e3e1fa12d736b9643c733b96e6ca68245df
>---------------------------------------------------------------
commit f3ec4e3e1fa12d736b9643c733b96e6ca68245df
Author: Daniel Díaz <dhelta.diaz at gmail.com>
Date: Sat May 21 14:58:50 2016 -0400
Implementation of get/put functions for floats/doubles.
>---------------------------------------------------------------
f3ec4e3e1fa12d736b9643c733b96e6ca68245df
binary.cabal | 8 +++++---
src/Data/Binary/Get.hs | 44 ++++++++++++++++++++++++++++++++++++++++++++
src/Data/Binary/Put.hs | 43 ++++++++++++++++++++++++++++++++++++++++++-
tests/QC.hs | 27 +++++++++++++++++++++++++++
4 files changed, 118 insertions(+), 4 deletions(-)
diff --git a/binary.cabal b/binary.cabal
index a282ea0..555b2d6 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 40e3e70..3488f66 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
@@ -609,6 +620,39 @@ getInt64host = getPtr (sizeOf (undefined :: Int64))
------------------------------------------------------------------------
+-- 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
shiftl_w16 :: Word16 -> Int -> Word16
diff --git a/src/Data/Binary/Put.hs b/src/Data/Binary/Put.hs
index 9af7c11..286161c 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 3bda2bd..650d32b 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"
More information about the ghc-commits
mailing list