binary 0.8.9.3 → 0.10.0.0
raw patch · 11 files changed
Files
- README.md +3/−4
- benchmarks/GenericsBenchCache.hs +1/−1
- binary.cabal +86/−40
- changelog.md +7/−43
- src/Data/Binary.hs +3/−3
- src/Data/Binary/Class.hs +43/−94
- src/Data/Binary/FloatCast.hs +10/−32
- src/Data/Binary/Generic.hs +0/−2
- src/Data/Binary/Get.hs +56/−26
- src/Data/Binary/Get/Internal.hs +11/−19
- tests/QC.hs +6/−4
README.md view
@@ -1,14 +1,13 @@-# binary package+# binary package # [](https://hackage.haskell.org/package/binary) [](https://www.stackage.org/package/binary) [](http://travis-ci.org/kolmodin/binary) -*Pure binary serialisation using lazy ByteStrings.*+*Efficient, pure binary serialisation using lazy ByteStrings.* The ``binary`` package provides Data.Binary, containing the Binary class, and associated methods, for serialising values to and from lazy ByteStrings. -A key feature of ``binary`` is that the interface is both pure, and -moderately efficient.+A key feature of ``binary`` is that the interface is both pure, and efficient. The ``binary`` package is portable to GHC and Hugs. ## Installing binary from Hackage ##
benchmarks/GenericsBenchCache.hs view
@@ -37,4 +37,4 @@ return pds cacheFilePath :: String-cacheFilePath = "generics-bench.cache-100.gz"+cacheFilePath = "generics-bench.cache.gz"
binary.cabal view
@@ -1,16 +1,6 @@-cabal-version: 3.0---- To run tests and binaries you'll need to rename the name of the library--- and all the local dependencies on it. If not, cabal is unable to come up--- with a build plan.------ Try this;--- sed -i 's/\(name:\s*binary\)/\1-cabal-is-broken/' binary.cabal--- sed -i 's/\(binary\),/\1-cabal-is-broken,/' binary.cabal- name: binary-version: 0.8.9.3-license: BSD-3-Clause+version: 0.10.0.0+license: BSD3 license-file: LICENSE author: Lennart Kolmodin <kolmodin@gmail.com> maintainer: Lennart Kolmodin, Don Stewart <dons00@gmail.com>@@ -27,14 +17,14 @@ category: Data, Parsing stability: provisional build-type: Simple-tested-with: GHC == 8.0.2, GHC ==8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.6, GHC == 9.4.4, GHC == 9.6.3, GHC == 9.8.1+cabal-version: >= 1.8+tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2 extra-source-files:- tools/derive/*.hs+ README.md changelog.md docs/hcar/binary-Lb.tex tools/derive/*.hs+ -- from the benchmark 'bench' extra-source-files: benchmarks/CBenchmark.h-extra-doc-files:- README.md changelog.md docs/hcar/binary-Lb.tex source-repository head type: git@@ -60,20 +50,32 @@ ghc-options: -O2 -Wall -fliberate-case-threshold=1000 if impl(ghc >= 8.0)- ghc-options: -Wcompat -Wnoncanonical-monad-instances- default-language: Haskell2010+ ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances +-- Due to circular dependency, we cannot make any of the test-suites or+-- benchmark depend on the binary library. Instead, for each test-suite and+-- benchmark, we include the source directory of binary and build-depend on all+-- the dependencies binary has.+ test-suite qc type: exitcode-stdio-1.0- hs-source-dirs: tests+ hs-source-dirs: src tests main-is: QC.hs other-modules: Action Arbitrary+ other-modules:+ Data.Binary+ Data.Binary.Builder+ Data.Binary.Class+ Data.Binary.FloatCast+ Data.Binary.Generic+ Data.Binary.Get+ Data.Binary.Get.Internal+ Data.Binary.Internal+ Data.Binary.Put build-depends: base >= 4.5.0.0 && < 5,- base-orphans >=0.8.1 && <0.9,- binary, bytestring >= 0.10.4, random>=1.0.1.0, test-framework,@@ -86,16 +88,24 @@ if impl(ghc <= 7.6) -- prior to ghc-7.4 generics lived in ghc-prim build-depends: ghc-prim- default-language: Haskell2010 test-suite read-write-file type: exitcode-stdio-1.0- hs-source-dirs: tests+ hs-source-dirs: src tests main-is: File.hs+ other-modules:+ Data.Binary+ Data.Binary.Builder+ Data.Binary.Class+ Data.Binary.FloatCast+ Data.Binary.Generic+ Data.Binary.Get+ Data.Binary.Get.Internal+ Data.Binary.Internal+ Data.Binary.Put build-depends: base >= 4.5.0.0 && < 5,- binary, bytestring >= 0.10.4, Cabal, directory,@@ -108,18 +118,25 @@ if impl(ghc <= 7.6) -- prior to ghc-7.4 generics lived in ghc-prim build-depends: ghc-prim- default-language: Haskell2010 benchmark bench type: exitcode-stdio-1.0- hs-source-dirs: benchmarks+ hs-source-dirs: src benchmarks main-is: Benchmark.hs other-modules: MemBench+ Data.Binary+ Data.Binary.Builder+ Data.Binary.Class+ Data.Binary.FloatCast+ Data.Binary.Generic+ Data.Binary.Get+ Data.Binary.Get.Internal+ Data.Binary.Internal+ Data.Binary.Put build-depends: base >= 4.5.0.0 && < 5,- binary, bytestring >= 0.10.4 -- build dependencies from using binary source rather than depending on the library build-depends: array, containers@@ -129,17 +146,24 @@ if impl(ghc <= 7.6) -- prior to ghc-7.4 generics lived in ghc-prim build-depends: ghc-prim- default-language: Haskell2010 benchmark get type: exitcode-stdio-1.0- hs-source-dirs: benchmarks+ hs-source-dirs: src benchmarks main-is: Get.hs+ other-modules:+ Data.Binary+ Data.Binary.Builder+ Data.Binary.Class+ Data.Binary.FloatCast+ Data.Binary.Generic+ Data.Binary.Get.Internal+ Data.Binary.Internal+ Data.Binary.Put build-depends: attoparsec, base >= 4.5.0.0 && < 5,- binary, bytestring >= 0.10.4, cereal, criterion == 1.*,@@ -151,16 +175,23 @@ if impl(ghc <= 7.6) -- prior to ghc-7.4 generics lived in ghc-prim build-depends: ghc-prim- default-language: Haskell2010 benchmark put type: exitcode-stdio-1.0- hs-source-dirs: benchmarks+ hs-source-dirs: src benchmarks main-is: Put.hs+ other-modules:+ Data.Binary+ Data.Binary.Builder+ Data.Binary.Class+ Data.Binary.FloatCast+ Data.Binary.Generic+ Data.Binary.Get+ Data.Binary.Get.Internal+ Data.Binary.Internal build-depends: base >= 4.5.0.0 && < 5,- binary, bytestring >= 0.10.4, criterion == 1.*, deepseq@@ -170,15 +201,23 @@ if impl(ghc <= 7.6) -- prior to ghc-7.4 generics lived in ghc-prim build-depends: ghc-prim- default-language: Haskell2010 benchmark generics-bench type: exitcode-stdio-1.0- hs-source-dirs: benchmarks+ hs-source-dirs: src benchmarks main-is: GenericsBench.hs+ other-modules:+ Data.Binary+ Data.Binary.Builder+ Data.Binary.Class+ Data.Binary.FloatCast+ Data.Binary.Generic+ Data.Binary.Get+ Data.Binary.Get.Internal+ Data.Binary.Internal+ Data.Binary.Put build-depends: base >= 4.5.0.0 && < 5,- binary, bytestring >= 0.10.4, -- The benchmark already depended on 'generic-deriving' transitively. That's -- what caused one of the problems, as both 'generic-deriving' and@@ -200,15 +239,23 @@ if impl(ghc <= 7.6) -- prior to ghc-7.4 generics lived in ghc-prim build-depends: ghc-prim- default-language: Haskell2010 benchmark builder type: exitcode-stdio-1.0- hs-source-dirs: benchmarks+ hs-source-dirs: src benchmarks main-is: Builder.hs+ other-modules:+ Data.Binary+ Data.Binary.Builder+ Data.Binary.Class+ Data.Binary.FloatCast+ Data.Binary.Generic+ Data.Binary.Get+ Data.Binary.Get.Internal+ Data.Binary.Internal+ Data.Binary.Put build-depends: base >= 4.5.0.0 && < 5,- binary, bytestring >= 0.10.4, criterion == 1.*, deepseq,@@ -219,4 +266,3 @@ if impl(ghc <= 7.6) -- prior to ghc-7.4 generics lived in ghc-prim build-depends: ghc-prim- default-language: Haskell2010
changelog.md view
@@ -1,55 +1,19 @@ binary ====== -binary-0.8.9.3------------------ Drop `-Wnoncanonical-monadfail-instances` from build flags--binary-0.8.9.2------------------ Documentation improvements-- Ensure that `many` has an unfolding-- Import `Data.List` as qualified--binary-0.8.9.1------------------ Fix redundant pattern match warning in GHC 9.4--binary-0.8.9.0------------------ Compatibility with GHC 9.2-- Drop instances for deprecated `Data.Semigroup.Option`--binary-0.8.8.0---------------+binary-0.10.0.0+--------------- -- Support Int32Rep and Word32Rep (3e0134df).-- Use bases built-in float/word32 and double/word64 casts (8eae4af0).+- Add binary instance for Data.Functor.Identity from base, #146.+- Don't use * when we have TypeOperators, #148. -binary-0.8.7.0+binary-0.9.0.0 -------------- -- MonadFail compatibility in base-4.13 (`fail` is not method of `Monad).-- `Binary NonEmpty` `fail`s non empty lists, not `error`s--binary-0.9.0.0 & binary-0.10.0.0---------------------------------- - `0.8.5.0` was first released as version `0.9.0.0`. It didn't have any breaking changes though, so it was again released as version `0.8.5.0`- according to PVP.-- `0.8.6.0` was first released as version `0.10.0.0`.--binary-0.8.6.0------------------- Add binary instance for Data.Functor.Identity from base, #146.-- Don't use * when we have TypeOperators, #148.-+ according to PVP. Next breaking release of `binary` will be version+ `0.10.0.0`. binary-0.8.5.0 --------------
src/Data/Binary.hs view
@@ -132,7 +132,7 @@ -- > > let e = OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2)) -- > > let v = encode e ----- Where @v@ is a binary encoded data structure. To reconstruct the+-- Where 'v' is a binary encoded data structure. To reconstruct the -- original data, we use 'decode' -- -- > > decode v :: Exp@@ -177,7 +177,7 @@ -- consumed bytes is returned. In case of failure, a human-readable error -- message will be returned as well. ----- @since 0.7.0.0+-- /Since: 0.7.0.0/ decodeOrFail :: Binary a => L.ByteString -> Either (L.ByteString, ByteOffset, String) (L.ByteString, ByteOffset, a)@@ -203,7 +203,7 @@ -- | Decode a value from a file. In case of errors, 'error' will -- be called with the error message. ----- @since 0.7.0.0+-- /Since: 0.7.0.0/ decodeFile :: Binary a => FilePath -> IO a decodeFile f = do result <- decodeFileOrFail f
src/Data/Binary/Class.hs view
@@ -9,10 +9,6 @@ {-# LANGUAGE PolyKinds #-} #endif -#if MIN_VERSION_base(4,16,0)-#define HAS_TYPELITS_CHAR-#endif- #if MIN_VERSION_base(4,8,0) #define HAS_NATURAL #define HAS_VOID@@ -47,9 +43,6 @@ ) where -import Prelude hiding (Foldable(..))-import Data.Foldable (Foldable(..))- import Data.Word import Data.Bits import Data.Int@@ -66,9 +59,7 @@ import Data.Monoid (mempty) #endif import qualified Data.Monoid as Monoid-#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))-#endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity (..)) #endif@@ -82,7 +73,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Builder.Prim as Prim -import Data.List (unfoldr)+import Data.List (unfoldr, foldl') -- And needed for the instances: #if MIN_VERSION_base(4,10,0)@@ -113,10 +104,6 @@ import qualified Data.Fixed as Fixed -#if __GLASGOW_HASKELL__ >= 901-import GHC.Exts (Levity(Lifted,Unlifted))-#endif- -- -- This isn't available in older Hugs or older GHC --@@ -185,7 +172,7 @@ -- Void never gets written nor reconstructed since it's impossible to have a -- value of that type --- | @since 0.8.0.0+-- | /Since: 0.8.0.0/ instance Binary Void where put = absurd get = mzero@@ -350,7 +337,7 @@ let v = roll bytes return $! if sign == (1 :: Word8) then v else - v --- | @since 0.8.0.0+-- | /Since: 0.8.0.0/ #ifdef HAS_FIXED_CONSTRUCTOR instance Binary (Fixed.Fixed a) where put (Fixed.MkFixed a) = put a@@ -380,7 +367,7 @@ -- Fixed-size type for a subset of Natural type NaturalWord = Word64 --- | @since 0.7.3.0+-- | /Since: 0.7.3.0/ instance Binary Natural where {-# INLINE put #-} put n | n <= hi =@@ -593,7 +580,7 @@ get = do n <- get :: Get Int getMany n --- | @'getMany' n@ get @n@ elements in order, without blowing the stack.+-- | 'getMany n' get 'n' elements in order, without blowing the stack. getMany :: Binary a => Int -> Get [a] getMany n = go [] n where@@ -686,7 +673,6 @@ ------------------------------------------------------------------------ -- Floating point --- | Uses non-IEEE754 encoding. Does not round-trip NaN. instance Binary Double where put d = put (decodeFloat d) get = do@@ -694,7 +680,6 @@ y <- get return $! encodeFloat x y --- | Uses non-IEEE754 encoding. Does not round-trip NaN. instance Binary Float where put f = put (decodeFloat f) get = do@@ -740,7 +725,7 @@ ------------------------------------------------------------------------ -- Fingerprints --- | @since 0.7.6.0+-- | /Since: 0.7.6.0/ instance Binary Fingerprint where put (Fingerprint x1 x2) = put x1 <> put x2 get = do@@ -751,7 +736,7 @@ ------------------------------------------------------------------------ -- Version --- | @since 0.8.0.0+-- | /Since: 0.8.0.0/ instance Binary Version where put (Version br tags) = put br <> put tags get = Version <$> get <*> get@@ -759,43 +744,43 @@ ------------------------------------------------------------------------ -- Data.Monoid datatypes --- | @since 0.8.4.0+-- | /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+-- | /Since: 0.8.4.0/ instance Binary Monoid.All where get = fmap Monoid.All get put = put . Monoid.getAll --- | @since 0.8.4.0+-- | /Since: 0.8.4.0/ instance Binary Monoid.Any where get = fmap Monoid.Any get put = put . Monoid.getAny --- | @since 0.8.4.0+-- | /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+-- | /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+-- | /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+-- | /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+-- | /Since: 0.8.4.0/ instance Binary (f a) => Binary (Monoid.Alt f a) where get = fmap Monoid.Alt get put = put . Monoid.getAlt@@ -805,39 +790,37 @@ ------------------------------------------------------------------------ -- Data.Semigroup datatypes --- | @since 0.8.4.0+-- | /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+-- | /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+-- | /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+-- | /Since: 0.8.4.0/ instance Binary a => Binary (Semigroup.Last a) where get = fmap Semigroup.Last get put = put . Semigroup.getLast -#if __GLASGOW_HASKELL__ < 901--- | @since 0.8.4.0+-- | /Since: 0.8.4.0/ instance Binary a => Binary (Semigroup.Option a) where get = fmap Semigroup.Option get put = put . Semigroup.getOption-#endif --- | @since 0.8.4.0+-- | /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+-- | /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@@ -845,13 +828,9 @@ ------------------------------------------------------------------------ -- Non-empty lists --- | @since 0.8.4.0+-- | /Since: 0.8.4.0/ instance Binary a => Binary (NE.NonEmpty a) where- get = do- list <- get- case list of- [] -> fail "NonEmpty is empty!"- x:xs -> pure (x NE.:| xs)+ get = fmap NE.fromList get put = put . NE.toList #endif @@ -879,28 +858,23 @@ -- * 'SomeTypeRep' (also known as 'Data.Typeable.TypeRep') -- --- | @since 0.8.5.0+-- | @since 0.8.5.0. See #typeable-instances# instance Binary VecCount where put = putWord8 . fromIntegral . fromEnum get = toEnum . fromIntegral <$> getWord8 --- | @since 0.8.5.0+-- | @since 0.8.5.0. See #typeable-instances# instance Binary VecElem where put = putWord8 . fromIntegral . fromEnum get = toEnum . fromIntegral <$> getWord8 --- | @since 0.8.5.0+-- | @since 0.8.5.0. See #typeable-instances# instance Binary RuntimeRep where put (VecRep a b) = putWord8 0 >> put a >> put b put (TupleRep reps) = putWord8 1 >> put reps put (SumRep reps) = putWord8 2 >> put reps-#if __GLASGOW_HASKELL__ >= 901- put (BoxedRep Lifted) = putWord8 3- put (BoxedRep Unlifted) = putWord8 4-#else put LiftedRep = putWord8 3 put UnliftedRep = putWord8 4-#endif put IntRep = putWord8 5 put WordRep = putWord8 6 put Int64Rep = putWord8 7@@ -908,16 +882,6 @@ put AddrRep = putWord8 9 put FloatRep = putWord8 10 put DoubleRep = putWord8 11-#if __GLASGOW_HASKELL__ >= 807- put Int8Rep = putWord8 12- put Word8Rep = putWord8 13- put Int16Rep = putWord8 14- put Word16Rep = putWord8 15-#if __GLASGOW_HASKELL__ >= 809- put Int32Rep = putWord8 16- put Word32Rep = putWord8 17-#endif-#endif get = do tag <- getWord8@@ -925,13 +889,8 @@ 0 -> VecRep <$> get <*> get 1 -> TupleRep <$> get 2 -> SumRep <$> get-#if __GLASGOW_HASKELL__ >= 901- 3 -> pure (BoxedRep Lifted)- 4 -> pure (BoxedRep Unlifted)-#else 3 -> pure LiftedRep 4 -> pure UnliftedRep-#endif 5 -> pure IntRep 6 -> pure WordRep 7 -> pure Int64Rep@@ -939,19 +898,9 @@ 9 -> pure AddrRep 10 -> pure FloatRep 11 -> pure DoubleRep-#if __GLASGOW_HASKELL__ >= 807- 12 -> pure Int8Rep- 13 -> pure Word8Rep- 14 -> pure Int16Rep- 15 -> pure Word16Rep-#if __GLASGOW_HASKELL__ >= 809- 16 -> pure Int32Rep- 17 -> pure Word32Rep-#endif-#endif _ -> fail "GHCi.TH.Binary.putRuntimeRep: invalid tag" --- | @since 0.8.5.0+-- | @since 0.8.5.0. See #typeable-instances# instance Binary TyCon where put tc = do put (tyConPackage tc)@@ -961,7 +910,7 @@ put (tyConKindRep tc) get = mkTyCon <$> get <*> get <*> get <*> get <*> get --- | @since 0.8.5.0+-- | @since 0.8.5.0. See #typeable-instances# instance Binary KindRep where put (KindRepTyConApp tc k) = putWord8 0 >> put tc >> put k put (KindRepVar bndr) = putWord8 1 >> put bndr@@ -981,24 +930,21 @@ 5 -> KindRepTypeLit <$> get <*> get _ -> fail "GHCi.TH.Binary.putKindRep: invalid tag" --- | @since 0.8.5.0+-- | @since 0.8.5.0. See #typeable-instances# instance Binary TypeLitSort where put TypeLitSymbol = putWord8 0 put TypeLitNat = putWord8 1-#ifdef HAS_TYPELITS_CHAR- put TypeLitChar = putWord8 2-#endif get = do tag <- getWord8 case tag of 0 -> pure TypeLitSymbol 1 -> pure TypeLitNat-#ifdef HAS_TYPELITS_CHAR- 2 -> pure TypeLitChar-#endif _ -> fail "GHCi.TH.Binary.putTypeLitSort: invalid tag" putTypeRep :: TypeRep a -> Put+-- Special handling for TYPE, (->), and RuntimeRep due to recursive kind+-- relations.+-- See Note [Mutually recursive representations of primitive types] putTypeRep rep -- Handle Type specially since it's so common | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) = put (0 :: Word8)@@ -1010,17 +956,11 @@ put (2 :: Word8) putTypeRep f putTypeRep x-#if __GLASGOW_HASKELL__ < 903--- N.B. This pattern never matches,--- even on versions of GHC older than 9.3:--- a `Fun` typerep will match with the `App` pattern.--- This match is kept solely for pattern-match warnings,--- which are incorrect on GHC prior to 9.3. putTypeRep (Fun arg res) = do put (3 :: Word8) putTypeRep arg putTypeRep res-#endif+putTypeRep _ = fail "GHCi.TH.Binary.putTypeRep: Impossible" getSomeTypeRep :: Get SomeTypeRep getSomeTypeRep = do@@ -1048,6 +988,14 @@ [ "Applied type: " ++ show f , "To argument: " ++ show x ]+ 3 -> do SomeTypeRep arg <- getSomeTypeRep+ SomeTypeRep res <- getSomeTypeRep+ case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of+ Just HRefl ->+ case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of+ Just HRefl -> return $ SomeTypeRep $ Fun arg res+ Nothing -> failure "Kind mismatch" []+ Nothing -> failure "Kind mismatch" [] _ -> failure "Invalid SomeTypeRep" [] where failure description info =@@ -1071,3 +1019,4 @@ put (SomeTypeRep rep) = putTypeRep rep get = getSomeTypeRep #endif+
src/Data/Binary/FloatCast.hs view
@@ -1,61 +1,40 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-}-#if !(MIN_VERSION_base(4,11,0)) {-# LANGUAGE Trustworthy #-}-#endif -- | 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-element STUArray, as described in+-- Implements casting via a 1-elemnt STUArray, as described in -- <http://stackoverflow.com/a/7002812/263061>. module Data.Binary.FloatCast- ( floatToWord -- | Reinterpret-casts a `Float` to a `Word32`.- , wordToFloat -- | Reinterpret-casts a `Word32` to a `Float`.- , doubleToWord -- | Reinterpret-casts a `Double` to a `Word64`.- , wordToDouble -- | Reinterpret-casts a `Word64` to a `Double`.-+ ( floatToWord+ , wordToFloat+ , doubleToWord+ , wordToDouble ) where -#if MIN_VERSION_base(4,11,0)- import Data.Word (Word32, Word64)-import GHC.Float (castWord32ToFloat, castFloatToWord32, castWord64ToDouble, castDoubleToWord64)--floatToWord :: Float -> Word32-floatToWord = castFloatToWord32-{-# INLINE floatToWord #-}--wordToFloat :: Word32 -> Float-wordToFloat = castWord32ToFloat-{-# INLINE wordToFloat #-}--doubleToWord :: Double -> Word64-doubleToWord = castDoubleToWord64-{-# INLINE doubleToWord #-}--wordToDouble :: Word64 -> Double-wordToDouble = castWord64ToDouble-{-# INLINE wordToDouble #-}--#else-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 #-}@@ -64,4 +43,3 @@ MArray (STUArray s) b (ST s)) => a -> ST s b cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0 {-# INLINE cast #-}-#endif
src/Data/Binary/Generic.hs view
@@ -30,9 +30,7 @@ import Data.Binary.Put import Data.Bits import Data.Word-#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))-#endif #ifdef HAS_DATA_KIND import Data.Kind #endif
src/Data/Binary/Get.hs view
@@ -41,7 +41,7 @@ -- The fields in @Trade@ are marked as strict (using @!@) since we don't need -- laziness here. In practise, you would probably consider using the UNPACK -- pragma as well.--- <https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/pragmas.html#unpack-pragma>+-- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#unpack-pragma> -- -- Now, let's have a look at a decoder for this format. --@@ -126,7 +126,7 @@ -- from a socket which has higher likelihood to fail. To address these needs, -- use the incremental input method like in @incrementalExample@. -- For an example of how to read incrementally from a Handle,--- see the implementation of 'Data.Binary.decodeFileOrFail'.+-- see the implementation of 'decodeFileOrFail' in "Data.Binary". ----------------------------------------------------------------------------- @@ -231,6 +231,12 @@ import Data.Binary.Get.Internal hiding ( Decoder(..), runGetIncremental ) import qualified Data.Binary.Get.Internal as I +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+-- needed for (# unboxing #) with magic hash+import GHC.Base+import GHC.Word+#endif+ -- needed for casting words to float/double import Data.Binary.FloatCast (wordToFloat, wordToDouble) @@ -322,7 +328,7 @@ -- consumed is returned. In the case of failure, a human-readable -- error message is included as well. ----- @since 0.6.4.0+-- /Since: 0.6.4.0/ runGetOrFail :: Get a -> L.ByteString -> Either (L.ByteString, ByteOffset, String) (L.ByteString, ByteOffset, a) runGetOrFail g lbs0 = feedAll (runGetIncremental g) lbs0@@ -360,7 +366,7 @@ -- | Feed a 'Decoder' with more input. If the 'Decoder' is 'Done' or 'Fail' it--- will add the input to 'L.ByteString' of unconsumed input.+-- will add the input to 'ByteString' of unconsumed input. -- -- @ -- 'runGetIncremental' myParser \`pushChunks\` myLazyByteString@@ -457,7 +463,7 @@ word16be :: B.ByteString -> Word16 word16be = \s ->- (fromIntegral (s `B.unsafeIndex` 0) `unsafeShiftL` 8) .|.+ (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w16` 8) .|. (fromIntegral (s `B.unsafeIndex` 1)) {-# INLINE[2] getWord16be #-} {-# INLINE word16be #-}@@ -468,7 +474,7 @@ word16le :: B.ByteString -> Word16 word16le = \s ->- (fromIntegral (s `B.unsafeIndex` 1) `unsafeShiftL` 8) .|.+ (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w16` 8) .|. (fromIntegral (s `B.unsafeIndex` 0) ) {-# INLINE[2] getWord16le #-} {-# INLINE word16le #-}@@ -479,9 +485,9 @@ word32be :: B.ByteString -> Word32 word32be = \s ->- (fromIntegral (s `B.unsafeIndex` 0) `unsafeShiftL` 24) .|.- (fromIntegral (s `B.unsafeIndex` 1) `unsafeShiftL` 16) .|.- (fromIntegral (s `B.unsafeIndex` 2) `unsafeShiftL` 8) .|.+ (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w32` 24) .|.+ (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 16) .|.+ (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 8) .|. (fromIntegral (s `B.unsafeIndex` 3) ) {-# INLINE[2] getWord32be #-} {-# INLINE word32be #-}@@ -492,9 +498,9 @@ word32le :: B.ByteString -> Word32 word32le = \s ->- (fromIntegral (s `B.unsafeIndex` 3) `unsafeShiftL` 24) .|.- (fromIntegral (s `B.unsafeIndex` 2) `unsafeShiftL` 16) .|.- (fromIntegral (s `B.unsafeIndex` 1) `unsafeShiftL` 8) .|.+ (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w32` 24) .|.+ (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 16) .|.+ (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 8) .|. (fromIntegral (s `B.unsafeIndex` 0) ) {-# INLINE[2] getWord32le #-} {-# INLINE word32le #-}@@ -505,13 +511,13 @@ word64be :: B.ByteString -> Word64 word64be = \s ->- (fromIntegral (s `B.unsafeIndex` 0) `unsafeShiftL` 56) .|.- (fromIntegral (s `B.unsafeIndex` 1) `unsafeShiftL` 48) .|.- (fromIntegral (s `B.unsafeIndex` 2) `unsafeShiftL` 40) .|.- (fromIntegral (s `B.unsafeIndex` 3) `unsafeShiftL` 32) .|.- (fromIntegral (s `B.unsafeIndex` 4) `unsafeShiftL` 24) .|.- (fromIntegral (s `B.unsafeIndex` 5) `unsafeShiftL` 16) .|.- (fromIntegral (s `B.unsafeIndex` 6) `unsafeShiftL` 8) .|.+ (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w64` 56) .|.+ (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 48) .|.+ (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 40) .|.+ (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 32) .|.+ (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 24) .|.+ (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 16) .|.+ (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 8) .|. (fromIntegral (s `B.unsafeIndex` 7) ) {-# INLINE[2] getWord64be #-} {-# INLINE word64be #-}@@ -522,13 +528,13 @@ word64le :: B.ByteString -> Word64 word64le = \s ->- (fromIntegral (s `B.unsafeIndex` 7) `unsafeShiftL` 56) .|.- (fromIntegral (s `B.unsafeIndex` 6) `unsafeShiftL` 48) .|.- (fromIntegral (s `B.unsafeIndex` 5) `unsafeShiftL` 40) .|.- (fromIntegral (s `B.unsafeIndex` 4) `unsafeShiftL` 32) .|.- (fromIntegral (s `B.unsafeIndex` 3) `unsafeShiftL` 24) .|.- (fromIntegral (s `B.unsafeIndex` 2) `unsafeShiftL` 16) .|.- (fromIntegral (s `B.unsafeIndex` 1) `unsafeShiftL` 8) .|.+ (fromIntegral (s `B.unsafeIndex` 7) `shiftl_w64` 56) .|.+ (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 48) .|.+ (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 40) .|.+ (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 32) .|.+ (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 24) .|.+ (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 16) .|.+ (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 8) .|. (fromIntegral (s `B.unsafeIndex` 0) ) {-# INLINE[2] getWord64le #-} {-# INLINE word64le #-}@@ -645,3 +651,27 @@ getDoublehost :: Get Double getDoublehost = wordToDouble <$> getWord64host {-# INLINE getDoublehost #-}++------------------------------------------------------------------------+-- Unchecked shifts++shiftl_w16 :: Word16 -> Int -> Word16+shiftl_w32 :: Word32 -> Int -> Word32+shiftl_w64 :: Word64 -> Int -> Word64++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)+shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)++#if WORD_SIZE_IN_BITS < 64+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)++#else+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)+#endif++#else+shiftl_w16 = shiftL+shiftl_w32 = shiftL+shiftl_w64 = shiftL+#endif
src/Data/Binary/Get/Internal.hs view
@@ -91,20 +91,12 @@ instance Monad Get where return = pure (>>=) = bindG-#if !(MIN_VERSION_base(4,9,0))- fail = failG -- base < 4.9-#elif !(MIN_VERSION_base(4,13,0))- fail = Fail.fail -- base < 4.13-#endif--- NB: Starting with base-4.13, the `fail` method--- has been removed from the `Monad`-class--- according to the MonadFail proposal (MFP) schedule--- which completes the process that started with base-4.9.- #if MIN_VERSION_base(4,9,0)+ fail = Fail.fail+ instance Fail.MonadFail Get where- fail = failG #endif+ fail = failG bindG :: Get a -> (a -> Get b) -> Get b bindG (C c) f = C $ \i ks -> c i (\i' a -> (runCont (f a)) i' ks)@@ -130,7 +122,7 @@ (<*>) = apG {-# INLINE (<*>) #-} --- | @since 0.7.1.0+-- | /Since: 0.7.1.0/ instance MonadPlus Get where mzero = empty mplus = (<|>)@@ -201,7 +193,7 @@ -- Offset from 'bytesRead' will be relative to the start of 'isolate', not the -- absolute of the input. ----- @since 0.7.2.0+-- /Since: 0.7.2.0/ isolate :: Int -- ^ The number of bytes that must be consumed -> Get a -- ^ The decoder to isolate -> Get a@@ -264,7 +256,7 @@ getBytes = getByteString {-# INLINE getBytes #-} --- | @since 0.7.0.0+-- | /Since: 0.7.0.0/ instance Alternative Get where empty = C $ \inp _ks -> Fail inp "Data.Binary.Get(Alternative).empty" {-# INLINE empty #-}@@ -282,7 +274,7 @@ case v of Nothing -> pure [] Just x -> (:) x <$> many p- {-# INLINEABLE many #-} -- many will never inline because it's recursive, so mark it INLINEABLE instead.+ {-# 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'),@@ -312,7 +304,7 @@ -- | Run the given decoder, but without consuming its input. If the given -- decoder fails, then so will this function. ----- @since 0.7.0.0+-- /Since: 0.7.0.0/ lookAhead :: Get a -> Get a lookAhead g = do (decoder, bs) <- runAndKeepTrack g@@ -325,7 +317,7 @@ -- If 'Nothing' is returned, the input will be unconsumed. -- If the given decoder fails, then so will this function. ----- @since 0.7.0.0+-- /Since: 0.7.0.0/ lookAheadM :: Get (Maybe a) -> Get (Maybe a) lookAheadM g = do let g' = maybe (Left ()) Right <$> g@@ -335,7 +327,7 @@ -- If 'Left' is returned, the input will be unconsumed. -- If the given decoder fails, then so will this function. ----- @since 0.7.1.0+-- /Since: 0.7.1.0/ lookAheadE :: Get (Either a b) -> Get (Either a b) lookAheadE g = do (decoder, bs) <- runAndKeepTrack g@@ -348,7 +340,7 @@ -- | Label a decoder. If the decoder fails, the label will be appended on -- a new line to the error message string. ----- @since 0.7.2.0+-- /Since: 0.7.2.0/ label :: String -> Get a -> Get a label msg decoder = C $ \inp ks -> let r0 = runCont decoder inp (\inp' a -> Done inp' a)
tests/QC.hs view
@@ -24,8 +24,6 @@ import Data.Typeable import System.IO.Unsafe -import Data.Orphans ()- #ifdef HAS_NATURAL import Numeric.Natural #endif@@ -43,7 +41,7 @@ import Data.Binary import Data.Binary.Get import Data.Binary.Put-+import qualified Data.Binary.Class as Class ------------------------------------------------------------------------ @@ -160,7 +158,7 @@ testTypeable = testProperty "TypeRep" prop_TypeRep prop_TypeRep :: TypeRep -> Property-prop_TypeRep = roundTripWith put get+prop_TypeRep = roundTripWith Class.put Class.get atomicTypeReps :: [TypeRep] atomicTypeReps =@@ -501,6 +499,10 @@ 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 ------------------------------------------------------------------------