diff --git a/benchmarks/GenericsBenchTypes.hs b/benchmarks/GenericsBenchTypes.hs --- a/benchmarks/GenericsBenchTypes.hs +++ b/benchmarks/GenericsBenchTypes.hs @@ -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 diff --git a/benchmarks/Put.hs b/benchmarks/Put.hs --- a/benchmarks/Put.hs +++ b/benchmarks/Put.hs @@ -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 diff --git a/binary.cabal b/binary.cabal --- a/binary.cabal +++ b/binary.cabal @@ -1,5 +1,5 @@ name: binary -version: 0.8.3.0 +version: 0.8.4.0 license: BSD3 license-file: LICENSE author: Lennart Kolmodin @@ -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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 -------------- diff --git a/src/Data/Binary.hs b/src/Data/Binary.hs --- a/src/Data/Binary.hs +++ b/src/Data/Binary.hs @@ -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) diff --git a/src/Data/Binary/Builder.hs b/src/Data/Binary/Builder.hs --- a/src/Data/Binary/Builder.hs +++ b/src/Data/Binary/Builder.hs @@ -1,7 +1,5 @@ {-# LANGUAGE CPP, MagicHash #-} -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Safe #-} -#endif ----------------------------------------------------------------------------- -- | diff --git a/src/Data/Binary/Class.hs b/src/Data/Binary/Class.hs --- a/src/Data/Binary/Class.hs +++ b/src/Data/Binary/Class.hs @@ -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 diff --git a/src/Data/Binary/FloatCast.hs b/src/Data/Binary/FloatCast.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/FloatCast.hs @@ -0,0 +1,45 @@ + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} + +-- | This module was written based on +-- . +-- +-- Implements casting via a 1-elemnt STUArray, as described in +-- . +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/Generic.hs b/src/Data/Binary/Generic.hs --- a/src/Data/Binary/Generic.hs +++ b/src/Data/Binary/Generic.hs @@ -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 #-} ----------------------------------------------------------------------------- diff --git a/src/Data/Binary/Get.hs b/src/Data/Binary/Get.hs --- a/src/Data/Binary/Get.hs +++ b/src/Data/Binary/Get.hs @@ -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) diff --git a/src/Data/Binary/Get/Internal.hs b/src/Data/Binary/Get/Internal.hs --- a/src/Data/Binary/Get/Internal.hs +++ b/src/Data/Binary/Get/Internal.hs @@ -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 #-} diff --git a/src/Data/Binary/Put.hs b/src/Data/Binary/Put.hs --- a/src/Data/Binary/Put.hs +++ b/src/Data/Binary/Put.hs @@ -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 diff --git a/tests/QC.hs b/tests/QC.hs --- a/tests/QC.hs +++ b/tests/QC.hs @@ -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