binary 0.8.3.0 → 0.8.4.0

raw patch · 13 files changed

+349/−113 lines, 13 filesdep ~Cabaldep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: Cabal, base

API changes (from Hackage documentation)

Files

• benchmarks/GenericsBenchTypes.hs +4/−2
• benchmarks/Put.hs +0/−10
• binary.cabal +45/−31
• changelog.md +9/−0
• src/Data/Binary.hs +0/−6
• src/Data/Binary/Builder.hs +0/−2
• src/Data/Binary/Class.hs +120/−25
• src/Data/Binary/FloatCast.hs +45/−0
• src/Data/Binary/Generic.hs +0/−2
• src/Data/Binary/Get.hs +50/−14
• src/Data/Binary/Get/Internal.hs +9/−9
• src/Data/Binary/Put.hs +40/−2
• tests/QC.hs +27/−10

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-}+{-# LANGUAGE CPP, DeriveGeneric, StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module GenericsBenchTypes where @@ -14,8 +14,9 @@  import           Data.Binary -+#if ! MIN_VERSION_base(4,9,0) deriving instance Generic Version+#endif  instance Binary Benchmark instance Binary BenchmarkInterface@@ -39,6 +40,7 @@ instance Binary PackageName instance Binary RepoKind instance Binary RepoType+instance Binary SetupBuildInfo instance Binary SourceRepo instance Binary TestSuite instance Binary TestSuiteInterface

@@ -1,7 +1,5 @@ {-# LANGUAGE CPP, ExistentialQuantification #-}-#ifdef GENERICS {-# LANGUAGE DeriveGeneric #-}-#endif  module Main (main) where @@ -13,9 +11,7 @@ import qualified Data.ByteString.Lazy as L import Data.Monoid -#ifdef GENERICS import GHC.Generics-#endif  import Data.Binary import Data.Binary.Put@@ -64,19 +60,16 @@       bench "Word64s builder" $ whnf (L.length . toLazyByteString . fromWord64sBuilder) word64s,       bench "[Word64]" $ whnf (run . put) word64s -#ifdef GENERICS       , bgroup "Generics" [         bench "Struct monoid put" $ whnf (run . fromStructs) structs,         bench "Struct put as list" $ whnf (run . put) structs,         bench "StructList monoid put" $ whnf (run . fromStructLists) structLists,         bench "StructList put as list" $ whnf (run . put) structLists       ]-#endif     ]   where     run = L.length . runPut -#ifdef GENERICS data Struct = Struct Word8 Word16 Word32 Word64 deriving Generic instance Binary Struct @@ -88,7 +81,6 @@  structLists :: [StructList] structLists = replicate 1000 (StructList (take 10 structs))-#endif  -- Input data @@ -177,7 +169,6 @@ fromWord64sBuilder [] = mempty fromWord64sBuilder (x:xs) = BB.word64BE x `mappend` fromWord64sBuilder xs -#ifdef GENERICS fromStructs :: [Struct] -> Put fromStructs [] = mempty fromStructs (x:xs) = put x `mappend` fromStructs xs@@ -185,4 +176,3 @@ fromStructLists :: [StructList] -> Put fromStructLists [] = mempty fromStructLists (x:xs) = put x `mappend` fromStructLists xs-#endif

@@ -1,5 +1,5 @@ name:            binary-version:         0.8.3.0+version:         0.8.4.0 license:         BSD3 license-file:    LICENSE author:          Lennart Kolmodin <kolmodin@gmail.com>@@ -18,7 +18,7 @@ stability:       provisional build-type:      Simple cabal-version:   >= 1.8-tested-with:     GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3+tested-with:     GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3 extra-source-files:   README.md changelog.md docs/hcar/binary-Lb.tex tools/derive/*.hs @@ -31,7 +31,7 @@   location: git://github.com/kolmodin/binary.git  library-  build-depends:   base >= 3.0 && < 5, bytestring >= 0.10.2, containers, array+  build-depends:   base >= 4.5.0.0 && < 5, bytestring >= 0.10.2, containers, array   hs-source-dirs:  src   exposed-modules: Data.Binary,                    Data.Binary.Put,@@ -40,14 +40,12 @@                    Data.Binary.Builder    other-modules:   Data.Binary.Class,-                   Data.Binary.Internal--  if impl(ghc >= 7.2.1)-    cpp-options: -DGENERICS-    other-modules: Data.Binary.Generic-    if impl(ghc <= 7.6)-      -- prior to ghc-7.4 generics lived in ghc-prim-      build-depends: ghc-prim+                   Data.Binary.Internal,+                   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    ghc-options:     -O2 -Wall -fliberate-case-threshold=1000 @@ -67,7 +65,7 @@     Action     Arbitrary   build-depends:-    base >= 3.0 && < 5,+    base >= 4.5.0.0 && < 5,     bytestring >= 0.10.2,     random>=1.0.1.0,     test-framework,@@ -77,13 +75,17 @@   -- build dependencies from using binary source rather than depending on the library   build-depends: array, containers   ghc-options: -Wall -O2 -threaded+  if impl(ghc <= 7.6)+    -- prior to ghc-7.4 generics lived in ghc-prim+    build-depends: ghc-prim + test-suite read-write-file   type:  exitcode-stdio-1.0   hs-source-dirs: src tests   main-is: File.hs   build-depends:-    base >= 3.0 && < 5,+    base >= 4.5.0.0 && < 5,     bytestring >= 0.10.2,     Cabal,     directory,@@ -93,28 +95,36 @@   -- build dependencies from using binary source rather than depending on the library   build-depends: array, containers   ghc-options: -Wall+  if impl(ghc <= 7.6)+    -- prior to ghc-7.4 generics lived in ghc-prim+    build-depends: ghc-prim + benchmark bench   type: exitcode-stdio-1.0   hs-source-dirs: src benchmarks   main-is: Benchmark.hs   other-modules: MemBench   build-depends:-    base >= 3.0 && < 5,+    base >= 4.5.0.0 && < 5,     bytestring   -- build dependencies from using binary source rather than depending on the library   build-depends: array, containers   c-sources: benchmarks/CBenchmark.c   include-dirs: benchmarks   ghc-options: -O2+  if impl(ghc <= 7.6)+    -- prior to ghc-7.4 generics lived in ghc-prim+    build-depends: ghc-prim + benchmark get   type: exitcode-stdio-1.0   hs-source-dirs: src benchmarks   main-is: Get.hs   build-depends:     attoparsec,-    base >= 3.0 && < 5,+    base >= 4.5.0.0 && < 5,     bytestring,     cereal,     criterion == 1.*,@@ -123,59 +133,60 @@   -- build dependencies from using binary source rather than depending on the library   build-depends: array, containers   ghc-options: -O2 -Wall+  if impl(ghc <= 7.6)+    -- prior to ghc-7.4 generics lived in ghc-prim+    build-depends: ghc-prim + benchmark put   type: exitcode-stdio-1.0   hs-source-dirs: src benchmarks   main-is: Put.hs   build-depends:-    base >= 3.0 && < 5,+    base >= 4.5.0.0 && < 5,     bytestring,     criterion == 1.*,     deepseq   -- build dependencies from using binary source rather than depending on the library   build-depends: array, containers   ghc-options: -O2 -Wall-  if impl(ghc >= 7.2.1)-    cpp-options: -DGENERICS-    other-modules: Data.Binary.Generic-    if impl(ghc <= 7.6)-      -- prior to ghc-7.4 generics lived in ghc-prim-      build-depends: ghc-prim+  other-modules: Data.Binary.Generic+  if impl(ghc <= 7.6)+    -- prior to ghc-7.4 generics lived in ghc-prim+    build-depends: ghc-prim  benchmark generics-bench   type: exitcode-stdio-1.0   hs-source-dirs: src benchmarks   main-is: GenericsBench.hs   build-depends:-    base >= 3.0 && < 5,+    base >= 4.5.0.0 && < 5,     bytestring,-    Cabal == 1.22.*,+    Cabal == 1.24.*,     directory,     filepath,     tar,     unordered-containers,     zlib,     criterion+       other-modules:     GenericsBenchCache     GenericsBenchTypes+    Data.Binary.Generic   -- build dependencies from using binary source rather than depending on the library   build-depends: array, containers   ghc-options: -O2 -Wall-  if impl(ghc >= 7.2.1)-    cpp-options: -DGENERICS-    other-modules: Data.Binary.Generic-    if impl(ghc <= 7.6)-      -- prior to ghc-7.4 generics lived in ghc-prim-      build-depends: ghc-prim+  if impl(ghc <= 7.6)+    -- prior to ghc-7.4 generics lived in ghc-prim+    build-depends: ghc-prim  benchmark builder   type: exitcode-stdio-1.0   hs-source-dirs: src benchmarks   main-is: Builder.hs   build-depends:-    base >= 3.0 && < 5,+    base >= 4.5.0.0 && < 5,     bytestring,     criterion == 1.*,     deepseq,@@ -183,3 +194,6 @@   -- build dependencies from using binary source rather than depending on the library   build-depends: array, containers   ghc-options: -O2+  if impl(ghc <= 7.6)+    -- prior to ghc-7.4 generics lived in ghc-prim+    build-depends: ghc-prim

@@ -1,6 +1,15 @@ binary ====== +binary-0.8.4.0+--------------++- `binary` supports GHC >= 7.4.2+- Performance improvements for `Alternative` functions.+- put/get functions for IEEE-754 floats and doubles, #119.+- Fix performance bugs, #115.+- Binary instances for datatypes in `Data.Monoid` and `Data.Semigroup`, #114.+ binary-0.8.3.0 -------------- 

@@ -1,7 +1,5 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module      : Data.Binary@@ -46,12 +44,10 @@     -- ** Example     -- $example -#ifdef GENERICS     -- * Generic support     -- $generics     , GBinaryGet(..)     , GBinaryPut(..)-#endif      -- * The Get and Put monads     , Get@@ -80,9 +76,7 @@ import Data.Binary.Class import Data.Binary.Put import Data.Binary.Get-#ifdef GENERICS import Data.Binary.Generic ()-#endif  import qualified Data.ByteString as B ( hGet, length ) import Data.ByteString.Lazy (ByteString)

@@ -1,7 +1,5 @@ {-# LANGUAGE CPP, MagicHash #-}-#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Safe #-}-#endif  ----------------------------------------------------------------------------- -- |

@@ -1,9 +1,9 @@ {-# LANGUAGE CPP, FlexibleContexts #-}-#if __GLASGOW_HASKELL__ >= 701 && __GLASGOW_HASKELL__ != 702-{-# LANGUAGE Safe #-}-#endif-#ifdef GENERICS {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE Safe #-}++#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-} #endif  #if MIN_VERSION_base(4,8,0)@@ -15,10 +15,6 @@ #define HAS_FIXED_CONSTRUCTOR #endif -#if __GLASGOW_HASKELL__ >= 704-#define HAS_GHC_FINGERPRINT-#endif- #ifndef HAS_FIXED_CONSTRUCTOR {-# LANGUAGE ScopedTypeVariables #-} #endif@@ -42,11 +38,9 @@     -- * The Binary class       Binary(..) -#ifdef GENERICS     -- * Support for generics     , GBinaryGet(..)     , GBinaryPut(..)-#endif      ) where @@ -65,7 +59,12 @@ import Control.Applicative import Data.Monoid (mempty) #endif+import qualified Data.Monoid as Monoid import Data.Monoid ((<>))+#if MIN_VERSION_base(4,9,0)+import qualified Data.List.NonEmpty as NE+import qualified Data.Semigroup     as Semigroup+#endif import Control.Monad  import Data.ByteString.Lazy (ByteString)@@ -89,9 +88,7 @@  import Data.Array.Unboxed -#ifdef GENERICS import GHC.Generics-#endif  #ifdef HAS_NATURAL import Numeric.Natural@@ -102,20 +99,15 @@ -- -- This isn't available in older Hugs or older GHC ---#if __GLASGOW_HASKELL__ >= 606 import qualified Data.Sequence as Seq import qualified Data.Foldable as Fold-#endif -#ifdef HAS_GHC_FINGERPRINT import GHC.Fingerprint-#endif  import Data.Version (Version(..))  ------------------------------------------------------------------------ -#ifdef GENERICS -- Factored into two classes because this makes GHC optimize the -- instances faster.  This doesn't matter for builds of binary, -- but it matters a lot for end-users who write 'instance Binary T'.@@ -125,7 +117,6 @@  class GBinaryGet f where     gget :: Get (f t)-#endif  -- | The 'Binary' class provides 'put' and 'get', methods to encode and -- decode a Haskell value to a lazy 'ByteString'. It mirrors the 'Read' and@@ -156,13 +147,11 @@     putList :: [t] -> Put     putList = defaultPutList -#ifdef GENERICS     default put :: (Generic t, GBinaryPut (Rep t)) => t -> Put     put = gput . from      default get :: (Generic t, GBinaryGet (Rep t)) => Get t     get = to `fmap` gget-#endif  {-# INLINE defaultPutList #-} defaultPutList :: Binary a => [a] -> Put@@ -504,19 +493,27 @@ -- Instances for the first few tuples  instance (Binary a, Binary b) => Binary (a,b) where+    {-# INLINE put #-}     put (a,b)           = put a <> put b+    {-# INLINE get #-}     get                 = liftM2 (,) get get  instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where+    {-# INLINE put #-}     put (a,b,c)         = put a <> put b <> put c+    {-# INLINE get #-}     get                 = liftM3 (,,) get get get  instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where+    {-# INLINE put #-}     put (a,b,c,d)       = put a <> put b <> put c <> put d+    {-# INLINE get #-}     get                 = liftM4 (,,,) get get get get  instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where+    {-# INLINE put #-}     put (a,b,c,d,e)     = put a <> put b <> put c <> put d <> put e+    {-# INLINE get #-}     get                 = liftM5 (,,,,) get get get get get  --@@ -525,30 +522,40 @@  instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)         => Binary (a,b,c,d,e,f) where+    {-# INLINE put #-}     put (a,b,c,d,e,f)   = put (a,(b,c,d,e,f))+    {-# INLINE get #-}     get                 = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f)  instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g)         => Binary (a,b,c,d,e,f,g) where+    {-# INLINE put #-}     put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g))+    {-# INLINE get #-}     get                 = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g)  instance (Binary a, Binary b, Binary c, Binary d, Binary e,           Binary f, Binary g, Binary h)         => Binary (a,b,c,d,e,f,g,h) where+    {-# INLINE put #-}     put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h))+    {-# INLINE get #-}     get                   = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h)  instance (Binary a, Binary b, Binary c, Binary d, Binary e,           Binary f, Binary g, Binary h, Binary i)         => Binary (a,b,c,d,e,f,g,h,i) where+    {-# INLINE put #-}     put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i))+    {-# INLINE get #-}     get                     = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i)  instance (Binary a, Binary b, Binary c, Binary d, Binary e,           Binary f, Binary g, Binary h, Binary i, Binary j)         => Binary (a,b,c,d,e,f,g,h,i,j) where+    {-# INLINE put #-}     put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j))+    {-# INLINE get #-}     get                       = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j)  ------------------------------------------------------------------------@@ -636,7 +643,6 @@ ------------------------------------------------------------------------ -- Queues and Sequences -#if __GLASGOW_HASKELL__ >= 606 -- -- This is valid Hugs, but you need the most recent Hugs --@@ -650,8 +656,6 @@                            x <- g                            rep (xs Seq.|> x) (n-1) g -#endif- ------------------------------------------------------------------------ -- Floating point @@ -707,7 +711,6 @@ ------------------------------------------------------------------------ -- Fingerprints -#ifdef HAS_GHC_FINGERPRINT -- | /Since: 0.7.6.0/ instance Binary Fingerprint where     put (Fingerprint x1 x2) = put x1 <> put x2@@ -715,7 +718,6 @@         x1 <- get         x2 <- get         return $! Fingerprint x1 x2-#endif  ------------------------------------------------------------------------ -- Version@@ -724,3 +726,96 @@ instance Binary Version where     put (Version br tags) = put br <> put tags     get = Version <$> get <*> get++------------------------------------------------------------------------+-- Data.Monoid datatypes++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Monoid.Dual a) where+  get = fmap Monoid.Dual get+  put = put . Monoid.getDual++-- | /Since: 0.8.4.0/+instance Binary Monoid.All where+  get = fmap Monoid.All get+  put = put . Monoid.getAll++-- | /Since: 0.8.4.0/+instance Binary Monoid.Any where+  get = fmap Monoid.Any get+  put = put . Monoid.getAny++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Monoid.Sum a) where+  get = fmap Monoid.Sum get+  put = put . Monoid.getSum++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Monoid.Product a) where+  get = fmap Monoid.Product get+  put = put . Monoid.getProduct++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Monoid.First a) where+  get = fmap Monoid.First get+  put = put . Monoid.getFirst++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Monoid.Last a) where+  get = fmap Monoid.Last get+  put = put . Monoid.getLast++#if MIN_VERSION_base(4,8,0)+-- | /Since: 0.8.4.0/+instance Binary (f a) => Binary (Monoid.Alt f a) where+  get = fmap Monoid.Alt get+  put = put . Monoid.getAlt+#endif++#if MIN_VERSION_base(4,9,0)+------------------------------------------------------------------------+-- Data.Semigroup datatypes++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Semigroup.Min a) where+  get = fmap Semigroup.Min get+  put = put . Semigroup.getMin++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Semigroup.Max a) where+  get = fmap Semigroup.Max get+  put = put . Semigroup.getMax++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Semigroup.First a) where+  get = fmap Semigroup.First get+  put = put . Semigroup.getFirst++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Semigroup.Last a) where+  get = fmap Semigroup.Last get+  put = put . Semigroup.getLast++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Semigroup.Option a) where+  get = fmap Semigroup.Option get+  put = put . Semigroup.getOption++-- | /Since: 0.8.4.0/+instance Binary m => Binary (Semigroup.WrappedMonoid m) where+  get = fmap Semigroup.WrapMonoid get+  put = put . Semigroup.unwrapMonoid++-- | /Since: 0.8.4.0/+instance (Binary a, Binary b) => Binary (Semigroup.Arg a b) where+  get                     = liftM2 Semigroup.Arg get get+  put (Semigroup.Arg a b) = put a <> put b++------------------------------------------------------------------------+-- Non-empty lists++-- | /Since: 0.8.4.0/+instance Binary a => Binary (NE.NonEmpty a) where+  get = fmap NE.fromList get+  put = put . NE.toList+#endif

@@ -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 #-}

@@ -1,8 +1,6 @@ {-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures,     ScopedTypeVariables, TypeOperators, TypeSynonymInstances #-}-#if __GLASGOW_HASKELL__ >= 701 && __GLASGOW_HASKELL__ != 702 {-# LANGUAGE Safe #-}-#endif {-# OPTIONS_GHC -fno-warn-orphans #-}  -----------------------------------------------------------------------------

@@ -1,7 +1,5 @@ {-# LANGUAGE CPP, RankNTypes, MagicHash, BangPatterns #-}-#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}-#endif  #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) #include "MachDeps.h"@@ -207,6 +205,14 @@     , getInt32host     , getInt64host +    -- ** Decoding Floats/Doubles+    , getFloatbe+    , getFloatle+    , getFloathost+    , getDoublebe+    , getDoublele+    , getDoublehost+     -- * Deprecated functions     , runGetState -- DEPRECATED     , remaining -- DEPRECATED@@ -231,6 +237,9 @@ 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@@ -531,33 +540,33 @@ {-# 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 #-}@@ -611,6 +620,39 @@   ------------------------------------------------------------------------+-- 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  shiftl_w16 :: Word16 -> Int -> Word16@@ -623,12 +665,6 @@  #if WORD_SIZE_IN_BITS < 64 shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)--#if __GLASGOW_HASKELL__ <= 606--- Exported by GHC.Word in GHC 6.8 and higher-foreign import ccall unsafe "stg_uncheckedShiftL64"-    uncheckedShiftL64#     :: Word64# -> Int# -> Word64#-#endif  #else shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)

@@ -54,12 +54,6 @@  import Data.Binary.Internal ( accursedUnutterablePerformIO ) -#if __GLASGOW_HASKELL__ < 704 && !defined(__HADDOCK__)--- needed for (# unboxing #) with magic hash--- Do we still need these? Works without on modern GHCs.-import GHC.Base-#endif- -- Kolmodin 20100427: at zurihac we discussed of having partial take a -- "Maybe ByteString" and implemented it in this way. -- The reasoning was that you could accidently provide an empty bytestring,@@ -265,20 +259,22 @@ -- | /Since: 0.7.0.0/ instance Alternative Get where   empty = C $ \inp _ks -> Fail inp "Data.Binary.Get(Alternative).empty"+  {-# INLINE empty #-}   (<|>) f g = do     (decoder, bs) <- runAndKeepTrack f     case decoder of       Done inp x -> C $ \_ ks -> ks inp x       Fail _ _ -> pushBack bs >> g       _ -> error "Binary: impossible"-#if MIN_VERSION_base(4,2,0)+  {-# INLINE (<|>) #-}   some p = (:) <$> p <*> many p+  {-# INLINE some #-}   many p = do     v <- (Just <$> p) <|> pure Nothing     case v of       Nothing -> pure []       Just x -> (:) x <$> many p-#endif+  {-# INLINE many #-}  -- | Run a decoder and keep track of all the input it consumes. -- Once it's finished, return the final decoder (always 'Done' or 'Fail'),@@ -412,7 +408,11 @@     enoughChunks n str       | B.length str >= n = Right (str,B.empty)       | otherwise = Left (n - B.length str)-    onSucc = B.concat+    -- Sometimes we will produce leftovers lists of the form [B.empty, nonempty]+    -- where `nonempty` is a non-empty ByteString. In this case we can avoid a copy+    -- by simply dropping the empty prefix. In principle ByteString might want+    -- to gain this optimization as well+    onSucc = B.concat . dropWhile B.null     onFail bss = C $ \_ _ -> Fail (B.concat bss) "not enough bytes" {-# INLINE ensureN #-} 

@@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}-#if __GLASGOW_HASKELL__ >= 701 && __GLASGOW_HASKELL__ != 702 {-# LANGUAGE Safe #-}-#endif  #if MIN_VERSION_base(4,9,0) #define HAS_SEMIGROUP@@ -51,6 +49,8 @@     , putInt16be     , putInt32be     , putInt64be+    , putFloatbe+    , putDoublebe      -- * Little-endian primitives     , putWord16le@@ -59,6 +59,8 @@     , putInt16le     , putInt32le     , putInt64le+    , putFloatle+    , putDoublele      -- * Host-endian, unaligned writes     , putWordhost           -- :: Word   -> Put@@ -69,6 +71,8 @@     , putInt16host          -- :: Int16  -> Put     , putInt32host          -- :: Int32  -> Put     , putInt64host          -- :: Int64  -> Put+    , putFloathost+    , putDoublehost      -- * Unicode     , putCharUtf8@@ -95,6 +99,8 @@ import Control.Applicative import Prelude -- Silence AMP warning. +-- needed for casting Floats/Doubles to words.+import Data.Binary.FloatCast (floatToWord, doubleToWord)  ------------------------------------------------------------------------ @@ -348,6 +354,38 @@ 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

@@ -9,10 +9,6 @@ #define HAS_FIXED_CONSTRUCTOR #endif -#if __GLASGOW_HASKELL__ >= 704-#define HAS_GHC_FINGERPRINT-#endif- import           Control.Applicative import           Control.Exception                    as C (SomeException,                                                             catch, evaluate)@@ -31,9 +27,7 @@ import           Numeric.Natural #endif -#ifdef HAS_GHC_FINGERPRINT import           GHC.Fingerprint-#endif  import qualified Data.Fixed as Fixed @@ -137,7 +131,27 @@ 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  -- | Test partial results.@@ -450,14 +464,12 @@  ------------------------------------------------------------------------ -#ifdef HAS_GHC_FINGERPRINT genFingerprint :: Gen Fingerprint genFingerprint = liftM2 Fingerprint arbitrary arbitrary #if !MIN_VERSION_base(4,7,0) instance Show Fingerprint where   show (Fingerprint x1 x2) = show (x1,x2) #endif-#endif  ------------------------------------------------------------------------ @@ -560,6 +572,13 @@             , 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"@@ -598,9 +617,7 @@             , testWithGen "Natural small" genNaturalSmall             , testWithGen "Natural big"   genNaturalBig #endif-#ifdef HAS_GHC_FINGERPRINT             , testWithGen "GHC.Fingerprint" genFingerprint-#endif              , test' "Float"       (test :: T Float ) test             , test' "Double"      (test :: T Double) test