binary 0.8.3.0 → 0.10.0.0
raw patch · 20 files changed
Files
- README.md +1/−1
- benchmarks/Builder.hs +2/−0
- benchmarks/Cabal24.hs +360/−0
- benchmarks/GenericsBench.hs +1/−1
- benchmarks/GenericsBenchCache.hs +19/−68
- benchmarks/GenericsBenchTypes.hs +4/−15
- benchmarks/Put.hs +0/−10
- binary.cabal +124/−41
- changelog.md +33/−0
- src/Data/Binary.hs +0/−6
- src/Data/Binary/Builder.hs +4/−2
- src/Data/Binary/Class.hs +325/−29
- src/Data/Binary/FloatCast.hs +45/−0
- src/Data/Binary/Generic.hs +12/−3
- src/Data/Binary/Get.hs +51/−15
- src/Data/Binary/Get/Internal.hs +9/−9
- src/Data/Binary/Put.hs +40/−2
- tests/Arbitrary.hs +0/−40
- tests/QC.hs +63/−12
- tools/derive/BinaryDerive.hs +1/−1
README.md view
@@ -1,6 +1,6 @@ # binary package # -[](http://travis-ci.org/kolmodin/binary)+[](https://hackage.haskell.org/package/binary) [](https://www.stackage.org/package/binary) [](http://travis-ci.org/kolmodin/binary) *Efficient, pure binary serialisation using lazy ByteStrings.*
benchmarks/Builder.hs view
@@ -189,7 +189,9 @@ ------------------------------------------------------------------------ -- Utilities +#if !MIN_VERSION_base(4,11,0) infixr 6 <> (<>) :: Monoid m => m -> m -> m (<>) = mappend+#endif
+ benchmarks/Cabal24.hs view
@@ -0,0 +1,360 @@+{-# LANGUAGE DeriveGeneric #-}++-- | This module contains type definitions copied from Cabal-1.24.2.0+-- to avoid a dependency on Cabal. Their contents for the benchmark are read+-- from a cache file using their 'Read' instance, see "GenericsBenchCache".+--+module Cabal24 where++import Data.Version (Version)+import GHC.Generics (Generic)+import Data.Map (Map)++data Benchmark = Benchmark {+ benchmarkName :: String,+ benchmarkInterface :: BenchmarkInterface,+ benchmarkBuildInfo :: BuildInfo,+ benchmarkEnabled :: Bool+ } deriving (Generic, Eq, Ord, Read, Show)++data BenchmarkInterface =+ BenchmarkExeV10 Version FilePath+ | BenchmarkUnsupported BenchmarkType+ deriving (Generic, Eq, Ord, Read, Show)++data BenchmarkType = BenchmarkTypeExe Version+ | BenchmarkTypeUnknown String Version+ deriving (Generic, Eq, Ord, Read, Show)++data BuildInfo = BuildInfo {+ buildable :: Bool,+ buildTools :: [Dependency],+ cppOptions :: [String],+ ccOptions :: [String],+ ldOptions :: [String],+ pkgconfigDepends :: [Dependency],+ frameworks :: [String],+ extraFrameworkDirs:: [String],+ cSources :: [FilePath],+ jsSources :: [FilePath],+ hsSourceDirs :: [FilePath],+ otherModules :: [ModuleName],+ defaultLanguage :: Maybe Language,+ otherLanguages :: [Language],+ defaultExtensions :: [Extension],+ otherExtensions :: [Extension],+ oldExtensions :: [Extension],+ extraLibs :: [String],+ extraGHCiLibs :: [String],+ extraLibDirs :: [String],+ includeDirs :: [FilePath],+ includes :: [FilePath],+ installIncludes :: [FilePath],+ options :: [(CompilerFlavor,[String])],+ profOptions :: [(CompilerFlavor,[String])],+ sharedOptions :: [(CompilerFlavor,[String])],+ customFieldsBI :: [(String,String)],+ targetBuildDepends :: [Dependency],+ targetBuildRenaming :: Map PackageName ModuleRenaming+ } deriving (Generic, Eq, Ord, Read, Show)++data BuildType+ = Simple+ | Configure+ | Make+ | Custom+ | UnknownBuildType String+ deriving (Generic, Eq, Ord, Read, Show)++data CompilerFlavor = GHC | GHCJS | NHC | YHC | Hugs | HBC | Helium+ | JHC | LHC | UHC+ | HaskellSuite String+ | OtherCompiler String+ deriving (Generic, Eq, Ord, Read, Show)++data Dependency = Dependency PackageName VersionRange+ deriving (Generic, Eq, Ord, Read, Show)++data Executable = Executable {+ exeName :: String,+ modulePath :: FilePath,+ buildInfo :: BuildInfo+ }+ deriving (Generic, Eq, Ord, Read, Show)++data Extension =+ EnableExtension KnownExtension+ | DisableExtension KnownExtension+ | UnknownExtension String+ deriving (Generic, Eq, Ord, Read, Show)++newtype FlagName = FlagName String+ deriving (Generic, Eq, Ord, Read, Show)++data KnownExtension =+ OverlappingInstances+ | UndecidableInstances+ | IncoherentInstances+ | DoRec+ | RecursiveDo+ | ParallelListComp+ | MultiParamTypeClasses+ | MonomorphismRestriction+ | FunctionalDependencies+ | Rank2Types+ | RankNTypes+ | PolymorphicComponents+ | ExistentialQuantification+ | ScopedTypeVariables+ | PatternSignatures+ | ImplicitParams+ | FlexibleContexts+ | FlexibleInstances+ | EmptyDataDecls+ | CPP+ | KindSignatures+ | BangPatterns+ | TypeSynonymInstances+ | TemplateHaskell+ | ForeignFunctionInterface+ | Arrows+ | Generics+ | ImplicitPrelude+ | NamedFieldPuns+ | PatternGuards+ | GeneralizedNewtypeDeriving+ | ExtensibleRecords+ | RestrictedTypeSynonyms+ | HereDocuments+ | MagicHash+ | TypeFamilies+ | StandaloneDeriving+ | UnicodeSyntax+ | UnliftedFFITypes+ | InterruptibleFFI+ | CApiFFI+ | LiberalTypeSynonyms+ | TypeOperators+ | RecordWildCards+ | RecordPuns+ | DisambiguateRecordFields+ | TraditionalRecordSyntax+ | OverloadedStrings+ | GADTs+ | GADTSyntax+ | MonoPatBinds+ | RelaxedPolyRec+ | ExtendedDefaultRules+ | UnboxedTuples+ | DeriveDataTypeable+ | DeriveGeneric+ | DefaultSignatures+ | InstanceSigs+ | ConstrainedClassMethods+ | PackageImports+ | ImpredicativeTypes+ | NewQualifiedOperators+ | PostfixOperators+ | QuasiQuotes+ | TransformListComp+ | MonadComprehensions+ | ViewPatterns+ | XmlSyntax+ | RegularPatterns+ | TupleSections+ | GHCForeignImportPrim+ | NPlusKPatterns+ | DoAndIfThenElse+ | MultiWayIf+ | LambdaCase+ | RebindableSyntax+ | ExplicitForAll+ | DatatypeContexts+ | MonoLocalBinds+ | DeriveFunctor+ | DeriveTraversable+ | DeriveFoldable+ | NondecreasingIndentation+ | SafeImports+ | Safe+ | Trustworthy+ | Unsafe+ | ConstraintKinds+ | PolyKinds+ | DataKinds+ | ParallelArrays+ | RoleAnnotations+ | OverloadedLists+ | EmptyCase+ | AutoDeriveTypeable+ | NegativeLiterals+ | BinaryLiterals+ | NumDecimals+ | NullaryTypeClasses+ | ExplicitNamespaces+ | AllowAmbiguousTypes+ | JavaScriptFFI+ | PatternSynonyms+ | PartialTypeSignatures+ | NamedWildCards+ | DeriveAnyClass+ | DeriveLift+ | StaticPointers+ | StrictData+ | Strict+ | ApplicativeDo+ | DuplicateRecordFields+ | TypeApplications+ | TypeInType+ | UndecidableSuperClasses+ | MonadFailDesugaring+ | TemplateHaskellQuotes+ | OverloadedLabels+ deriving (Generic, Eq, Ord, Read, Show)++data Language =+ Haskell98+ | Haskell2010+ | UnknownLanguage String+ deriving (Generic, Eq, Ord, Read, Show)++data Library = Library {+ exposedModules :: [ModuleName],+ reexportedModules :: [ModuleReexport],+ requiredSignatures:: [ModuleName],+ exposedSignatures:: [ModuleName],+ libExposed :: Bool,+ libBuildInfo :: BuildInfo+ }+ deriving (Generic, Eq, Ord, Read, Show)++data License =+ GPL (Maybe Version)+ | AGPL (Maybe Version)+ | LGPL (Maybe Version)+ | BSD2+ | BSD3+ | BSD4+ | MIT+ | ISC+ | MPL Version+ | Apache (Maybe Version)+ | PublicDomain+ | AllRightsReserved+ | UnspecifiedLicense+ | OtherLicense+ | UnknownLicense String+ deriving (Generic, Eq, Ord, Read, Show)++newtype ModuleName = ModuleName [String]+ deriving (Generic, Eq, Ord, Read, Show)++data ModuleReexport = ModuleReexport {+ moduleReexportOriginalPackage :: Maybe PackageName,+ moduleReexportOriginalName :: ModuleName,+ moduleReexportName :: ModuleName+ } deriving (Generic, Eq, Ord, Read, Show)++data ModuleRenaming = ModuleRenaming Bool [(ModuleName, ModuleName)]+ deriving (Generic, Eq, Ord, Read, Show)++data PackageDescription+ = PackageDescription {+ package :: PackageIdentifier,+ license :: License,+ licenseFiles :: [FilePath],+ copyright :: String,+ maintainer :: String,+ author :: String,+ stability :: String,+ testedWith :: [(CompilerFlavor,VersionRange)],+ homepage :: String,+ pkgUrl :: String,+ bugReports :: String,+ sourceRepos :: [SourceRepo],+ synopsis :: String,+ description :: String,+ category :: String,+ customFieldsPD :: [(String,String)],+ buildDepends :: [Dependency],+ specVersionRaw :: Either Version VersionRange,+ buildType :: Maybe BuildType,+ setupBuildInfo :: Maybe SetupBuildInfo,+ library :: Maybe Library,+ executables :: [Executable],+ testSuites :: [TestSuite],+ benchmarks :: [Benchmark],+ dataFiles :: [FilePath],+ dataDir :: FilePath,+ extraSrcFiles :: [FilePath],+ extraTmpFiles :: [FilePath],+ extraDocFiles :: [FilePath]+ } deriving (Generic, Eq, Ord, Read, Show)++data PackageIdentifier+ = PackageIdentifier {+ pkgName :: PackageName,+ pkgVersion :: Version+ }+ deriving (Generic, Eq, Ord, Read, Show)++newtype PackageName = PackageName { unPackageName :: String }+ deriving (Generic, Eq, Ord, Read, Show)++data RepoKind =+ RepoHead+ | RepoThis+ | RepoKindUnknown String+ deriving (Generic, Eq, Ord, Read, Show)++data RepoType = Darcs | Git | SVN | CVS+ | Mercurial | GnuArch | Bazaar | Monotone+ | OtherRepoType String+ deriving (Generic, Eq, Ord, Read, Show)++data SetupBuildInfo = SetupBuildInfo {+ setupDepends :: [Dependency],+ defaultSetupDepends :: Bool+ }+ deriving (Generic, Eq, Ord, Read, Show)++data SourceRepo = SourceRepo {+ repoKind :: RepoKind,+ repoType :: Maybe RepoType,+ repoLocation :: Maybe String,+ repoModule :: Maybe String,+ repoBranch :: Maybe String,+ repoTag :: Maybe String,+ repoSubdir :: Maybe FilePath+}+ deriving (Generic, Eq, Ord, Read, Show)++data TestSuite = TestSuite {+ testName :: String,+ testInterface :: TestSuiteInterface,+ testBuildInfo :: BuildInfo,+ testEnabled :: Bool+ }+ deriving (Generic, Eq, Ord, Read, Show)++data TestSuiteInterface =+ TestSuiteExeV10 Version FilePath+ | TestSuiteLibV09 Version ModuleName+ | TestSuiteUnsupported TestType+ deriving (Generic, Eq, Ord, Read, Show)++data TestType = TestTypeExe Version+ | TestTypeLib Version+ | TestTypeUnknown String Version+ deriving (Generic, Eq, Ord, Read, Show)++data VersionRange+ = AnyVersion+ | ThisVersion Version+ | LaterVersion Version+ | EarlierVersion Version+ | WildcardVersion Version+ | UnionVersionRanges VersionRange VersionRange+ | IntersectVersionRanges VersionRange VersionRange+ | VersionRangeParens VersionRange+ deriving (Generic, Eq, Ord, Read, Show)
benchmarks/GenericsBench.hs view
@@ -2,7 +2,7 @@ module Main where import qualified Data.ByteString.Lazy as L-import Distribution.PackageDescription+import Cabal24 (PackageDescription) import Criterion.Main
benchmarks/GenericsBenchCache.hs view
@@ -1,20 +1,12 @@ {-# LANGUAGE DeriveGeneric, StandaloneDeriving, BangPatterns, CPP #-} module GenericsBenchCache (readPackageDescriptionCache) where -import qualified Text.ParserCombinators.ReadP as Read- import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC8+import qualified Codec.Compression.GZip as GZip -import Data.Version (parseVersion)-import Distribution.PackageDescription-import Distribution.PackageDescription.Configuration-import Distribution.PackageDescription.Parse-import Distribution.Version (Version)+import Cabal24 (PackageDescription) -import qualified Codec.Archive.Tar as Tar-import qualified Codec.Compression.GZip as GZip-import qualified Data.HashMap.Lazy as Map import System.Directory import System.Exit @@ -24,66 +16,25 @@ import Control.Applicative ((<$>)) #endif -readTar :: String -> Int -> IO [PackageDescription]-readTar tarPath limit = do- entries <- Tar.read . GZip.decompress <$> L.readFile tarPath- let contents = Tar.foldEntries unpack [] (error "tar error") entries- let !pkgs = Map.fromListWith pick- [ (pkg, (version, content))- | (path, content) <- contents- , Just (pkg, version) <- return (readFilePath path) ]-- return $ take limit [ flattenPackageDescription gpd- | (_, (_, content)) <- Map.toList pkgs- , ParseOk _warns gpd <- return (parsePackageDescription (LC8.unpack content)) ]- where- pick (v,a) (w,b) | v >= w = (v,a)- | otherwise = (w,b)- unpack e acc =- case Tar.entryContent e of- Tar.NormalFile content _ -> (Tar.entryPath e, content):acc- _ -> acc--readFilePath :: String -> Maybe (String, Version)-readFilePath str = extract (Read.readP_to_S parse str)- where- extract [(result,_)] = Just result- extract _ = Nothing- parse = do- packageName <- Read.many1 (Read.satisfy (/='/'))- _ <- Read.char '/'- version <- parseVersion- _ <- Read.char '/'- return (packageName, version)--writePackageDescriptionCache :: String -> [PackageDescription] -> IO ()-writePackageDescriptionCache path = writeFile path . show- readPackageDescriptionCache :: Int -> IO [PackageDescription] readPackageDescriptionCache amount = do- let cacheFilePath' = cacheFilePath ++ "-" ++ (show amount)- createPackageDescriptionCache cacheFilePath' amount- pds <- read <$> readFile cacheFilePath'+ cacheExists <- doesFileExist cacheFilePath+ bs <-+ if cacheExists+ then do+ putStrLn "reading the cache file, might take a moment..."+ L.readFile cacheFilePath+ else do+ -- In older versions of this benchmark, there was machinery to+ -- regenerate the cache using the data in @~/.cabal@. Now the cache is+ -- simply stored in the repo to avoid a dependency on Cabal the library.+ putStrLn (cacheFilePath ++ " missing, aborting")+ exitFailure+ let str = LC8.unpack (GZip.decompress bs)+ pds = take amount (read str) -- PackageDescription doesn't implement NFData, let's force with the following line- (length (show pds)) `seq` return pds+ (length (show pds)) `seq` putStrLn "done reading the cache file"+ return pds cacheFilePath :: String-cacheFilePath = "generics-bench.cache"--createPackageDescriptionCache :: String -> Int -> IO ()-createPackageDescriptionCache path amount = do- cacheExists <- doesFileExist path- if cacheExists- then putStrLn "reusing cache from previous run"- else do- putStr "creating cabal cache file... "- tarFilePath <- (++"/.cabal/packages/hackage.haskell.org/00-index.tar.gz") <$> getHomeDirectory- fileExists <- doesFileExist tarFilePath- if fileExists- then do- pds <- readTar tarFilePath amount- writePackageDescriptionCache path pds- putStrLn "done"- else do- putStrLn (tarFilePath ++ " missing, aborting")- exitFailure+cacheFilePath = "generics-bench.cache.gz"
benchmarks/GenericsBenchTypes.hs view
@@ -1,21 +1,9 @@-{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module GenericsBenchTypes where -import Distribution.Compiler-import Distribution.License-import Distribution.ModuleName hiding (main)-import Distribution.Package-import Distribution.PackageDescription-import Distribution.Version-import Language.Haskell.Extension--import GHC.Generics (Generic)--import Data.Binary---deriving instance Generic Version+import Cabal24+import Generics.Deriving.Instances ()+import Data.Binary instance Binary Benchmark instance Binary BenchmarkInterface@@ -39,6 +27,7 @@ instance Binary PackageName instance Binary RepoKind instance Binary RepoType+instance Binary SetupBuildInfo instance Binary SourceRepo instance Binary TestSuite instance Binary TestSuiteInterface
benchmarks/Put.hs view
@@ -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
binary.cabal view
@@ -1,5 +1,5 @@ name: binary-version: 0.8.3.0+version: 0.10.0.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, GHC == 8.0.2 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.4, 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 @@ -66,25 +64,49 @@ 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 >= 3.0 && < 5,- bytestring >= 0.10.2,+ base >= 4.5.0.0 && < 5,+ bytestring >= 0.10.4, random>=1.0.1.0, test-framework, test-framework-quickcheck2 >= 0.3,- QuickCheck>=2.8+ QuickCheck >= 2.9 -- 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+ 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 >= 3.0 && < 5,- bytestring >= 0.10.2,+ base >= 4.5.0.0 && < 5,+ bytestring >= 0.10.4, Cabal, directory, filepath,@@ -93,29 +115,56 @@ -- 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+ 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 >= 3.0 && < 5,- bytestring+ base >= 4.5.0.0 && < 5,+ bytestring >= 0.10.4 -- 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+ 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 >= 3.0 && < 5,- bytestring,+ base >= 4.5.0.0 && < 5,+ bytestring >= 0.10.4, cereal, criterion == 1.*, deepseq,@@ -123,63 +172,97 @@ -- 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+ 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 >= 3.0 && < 5,- bytestring,+ base >= 4.5.0.0 && < 5,+ bytestring >= 0.10.4, 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+ 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+ 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 >= 3.0 && < 5,- bytestring,- Cabal == 1.22.*,+ base >= 4.5.0.0 && < 5,+ 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+ -- 'GenericsBenchTypes' used to define 'instance Generic Version'.+ generic-deriving >= 0.10, directory, filepath,- tar, unordered-containers, zlib, criterion+ other-modules:+ Cabal24 GenericsBenchCache GenericsBenchTypes -- 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+ 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 >= 3.0 && < 5,- bytestring,+ base >= 4.5.0.0 && < 5,+ bytestring >= 0.10.4, criterion == 1.*, deepseq, mtl -- 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
changelog.md view
@@ -1,6 +1,39 @@ binary ====== +binary-0.10.0.0+---------------++- Add binary instance for Data.Functor.Identity from base, #146.+- Don't use * when we have TypeOperators, #148.++binary-0.9.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. Next breaking release of `binary` will be version+ `0.10.0.0`.++binary-0.8.5.0+--------------++- Add Binary instances for Typeable TypeReps, #131.++binary-0.8.4.1+--------------++- Fix compilation with bytestring < 0.10.4.++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 --------------
src/Data/Binary.hs view
@@ -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)
src/Data/Binary/Builder.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE CPP, MagicHash #-}-#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Safe #-}-#endif ----------------------------------------------------------------------------- -- |@@ -70,7 +68,11 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L++#if MIN_VERSION_bytestring(0,10,4) import qualified Data.ByteString.Short as T+#endif+ import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Builder.Prim as Prim import Data.ByteString.Builder ( Builder, toLazyByteString )
src/Data/Binary/Class.hs view
@@ -1,9 +1,12 @@ {-# LANGUAGE CPP, FlexibleContexts #-}-#if __GLASGOW_HASKELL__ >= 701 && __GLASGOW_HASKELL__ != 702-{-# LANGUAGE Safe #-}-#endif-#ifdef GENERICS {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE Trustworthy #-}++#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-} #endif #if MIN_VERSION_base(4,8,0)@@ -15,14 +18,6 @@ #define HAS_FIXED_CONSTRUCTOR #endif -#if __GLASGOW_HASKELL__ >= 704-#define HAS_GHC_FINGERPRINT-#endif--#ifndef HAS_FIXED_CONSTRUCTOR-{-# LANGUAGE ScopedTypeVariables #-}-#endif- ----------------------------------------------------------------------------- -- | -- Module : Data.Binary.Class@@ -42,11 +37,9 @@ -- * The Binary class Binary(..) -#ifdef GENERICS -- * Support for generics , GBinaryGet(..) , GBinaryPut(..)-#endif ) where @@ -65,7 +58,15 @@ import Control.Applicative import Data.Monoid (mempty) #endif+import qualified Data.Monoid as Monoid import Data.Monoid ((<>))+#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity (..))+#endif+#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)@@ -75,6 +76,12 @@ import Data.List (unfoldr, foldl') -- And needed for the instances:+#if MIN_VERSION_base(4,10,0)+import Type.Reflection+import Type.Reflection.Unsafe+import Data.Kind (Type)+import GHC.Exts (RuntimeRep(..), VecCount, VecElem)+#endif import qualified Data.ByteString as B #if MIN_VERSION_bytestring(0,10,4) import qualified Data.ByteString.Short as BS@@ -89,9 +96,7 @@ import Data.Array.Unboxed -#ifdef GENERICS import GHC.Generics-#endif #ifdef HAS_NATURAL import Numeric.Natural@@ -102,20 +107,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 +125,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 +155,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 +501,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,35 +530,51 @@ 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) ------------------------------------------------------------------------ -- Container types +#if MIN_VERSION_base(4,8,0)+instance Binary a => Binary (Identity a) where+ put (Identity x) = put x+ get = Identity <$> get+#endif+ instance Binary a => Binary [a] where put = putList get = do n <- get :: Get Int@@ -636,7 +657,6 @@ ------------------------------------------------------------------------ -- Queues and Sequences -#if __GLASGOW_HASKELL__ >= 606 -- -- This is valid Hugs, but you need the most recent Hugs --@@ -650,8 +670,6 @@ x <- g rep (xs Seq.|> x) (n-1) g -#endif- ------------------------------------------------------------------------ -- Floating point @@ -707,7 +725,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 +732,6 @@ x1 <- get x2 <- get return $! Fingerprint x1 x2-#endif ------------------------------------------------------------------------ -- Version@@ -724,3 +740,283 @@ 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++------------------------------------------------------------------------+-- Typeable/Reflection++#if MIN_VERSION_base(4,10,0)++-- $typeable-instances+--+-- 'Binary' instances for GHC's "Type.Reflection", "Data.Typeable", and+-- kind-system primitives are only provided with @base-4.10.0@ (shipped with GHC+-- 8.2.1). In prior GHC releases some of these instances were provided by+-- 'GHCi.TH.Binary' in the @ghci@ package.+--+-- These include instances for,+--+-- * 'VecCount'+-- * 'VecElem'+-- * 'RuntimeRep'+-- * 'KindRep'+-- * 'TypeLitSort'+-- * 'TyCon'+-- * 'TypeRep'+-- * 'SomeTypeRep' (also known as 'Data.Typeable.TypeRep')+--++-- | @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. See #typeable-instances#+instance Binary VecElem where+ put = putWord8 . fromIntegral . fromEnum+ get = toEnum . fromIntegral <$> getWord8++-- | @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+ put LiftedRep = putWord8 3+ put UnliftedRep = putWord8 4+ put IntRep = putWord8 5+ put WordRep = putWord8 6+ put Int64Rep = putWord8 7+ put Word64Rep = putWord8 8+ put AddrRep = putWord8 9+ put FloatRep = putWord8 10+ put DoubleRep = putWord8 11++ get = do+ tag <- getWord8+ case tag of+ 0 -> VecRep <$> get <*> get+ 1 -> TupleRep <$> get+ 2 -> SumRep <$> get+ 3 -> pure LiftedRep+ 4 -> pure UnliftedRep+ 5 -> pure IntRep+ 6 -> pure WordRep+ 7 -> pure Int64Rep+ 8 -> pure Word64Rep+ 9 -> pure AddrRep+ 10 -> pure FloatRep+ 11 -> pure DoubleRep+ _ -> fail "GHCi.TH.Binary.putRuntimeRep: invalid tag"++-- | @since 0.8.5.0. See #typeable-instances#+instance Binary TyCon where+ put tc = do+ put (tyConPackage tc)+ put (tyConModule tc)+ put (tyConName tc)+ put (tyConKindArgs tc)+ put (tyConKindRep tc)+ get = mkTyCon <$> get <*> get <*> get <*> get <*> get++-- | @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+ put (KindRepApp a b) = putWord8 2 >> put a >> put b+ put (KindRepFun a b) = putWord8 3 >> put a >> put b+ put (KindRepTYPE r) = putWord8 4 >> put r+ put (KindRepTypeLit sort r) = putWord8 5 >> put sort >> put r++ get = do+ tag <- getWord8+ case tag of+ 0 -> KindRepTyConApp <$> get <*> get+ 1 -> KindRepVar <$> get+ 2 -> KindRepApp <$> get <*> get+ 3 -> KindRepFun <$> get <*> get+ 4 -> KindRepTYPE <$> get+ 5 -> KindRepTypeLit <$> get <*> get+ _ -> fail "GHCi.TH.Binary.putKindRep: invalid tag"++-- | @since 0.8.5.0. See #typeable-instances#+instance Binary TypeLitSort where+ put TypeLitSymbol = putWord8 0+ put TypeLitNat = putWord8 1+ get = do+ tag <- getWord8+ case tag of+ 0 -> pure TypeLitSymbol+ 1 -> pure TypeLitNat+ _ -> 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)+putTypeRep (Con' con ks) = do+ put (1 :: Word8)+ put con+ put ks+putTypeRep (App f x) = do+ put (2 :: Word8)+ putTypeRep f+ putTypeRep x+putTypeRep (Fun arg res) = do+ put (3 :: Word8)+ putTypeRep arg+ putTypeRep res+putTypeRep _ = fail "GHCi.TH.Binary.putTypeRep: Impossible"++getSomeTypeRep :: Get SomeTypeRep+getSomeTypeRep = do+ tag <- get :: Get Word8+ case tag of+ 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)+ 1 -> do con <- get :: Get TyCon+ ks <- get :: Get [SomeTypeRep]+ return $ SomeTypeRep $ mkTrCon con ks+ 2 -> do SomeTypeRep f <- getSomeTypeRep+ SomeTypeRep x <- getSomeTypeRep+ case typeRepKind f of+ Fun arg res ->+ case arg `eqTypeRep` typeRepKind x of+ Just HRefl -> do+ case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of+ Just HRefl -> return $ SomeTypeRep $ mkTrApp f x+ _ -> failure "Kind mismatch" []+ _ -> failure "Kind mismatch"+ [ "Found argument of kind: " ++ show (typeRepKind x)+ , "Where the constructor: " ++ show f+ , "Expects an argument of kind: " ++ show arg+ ]+ _ -> failure "Applied non-arrow type"+ [ "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 =+ fail $ unlines $ [ "GHCi.TH.Binary.getSomeTypeRep: "++description ]+ ++ map (" "++) info++instance Typeable a => Binary (TypeRep (a :: k)) where+ put = putTypeRep+ get = do+ SomeTypeRep rep <- getSomeTypeRep+ case rep `eqTypeRep` expected of+ Just HRefl -> pure rep+ Nothing -> fail $ unlines+ [ "GHCi.TH.Binary: Type mismatch"+ , " Deserialized type: " ++ show rep+ , " Expected type: " ++ show expected+ ]+ where expected = typeRep :: TypeRep a++instance Binary SomeTypeRep where+ put (SomeTypeRep rep) = putTypeRep rep+ get = getSomeTypeRep+#endif+
+ src/Data/Binary/FloatCast.hs view
@@ -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 #-}
src/Data/Binary/Generic.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures, ScopedTypeVariables, TypeOperators, TypeSynonymInstances #-}-#if __GLASGOW_HASKELL__ >= 701 && __GLASGOW_HASKELL__ != 702 {-# LANGUAGE Safe #-}-#endif {-# OPTIONS_GHC -fno-warn-orphans #-} +#if __GLASGOW_HASKELL__ >= 800+#define HAS_DATA_KIND+#endif+ ----------------------------------------------------------------------------- -- | -- Module : Data.Binary.Generic@@ -29,6 +31,9 @@ import Data.Bits import Data.Word import Data.Monoid ((<>))+#ifdef HAS_DATA_KIND+import Data.Kind+#endif import GHC.Generics import Prelude -- Silence AMP warning. @@ -138,7 +143,11 @@ class SumSize f where sumSize :: Tagged f Word64 -newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b}+#ifdef HAS_DATA_KIND+newtype Tagged (s :: Type -> Type) b = Tagged {unTagged :: b}+#else+newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b}+#endif instance (SumSize a, SumSize b) => SumSize (a :+: b) where sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) +
src/Data/Binary/Get.hs view
@@ -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"@@ -43,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.--- <http://www.haskell.org/ghc/docs/latest/html/users_guide/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. --@@ -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)
src/Data/Binary/Get/Internal.hs view
@@ -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 #-}
src/Data/Binary/Put.hs view
@@ -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
tests/Arbitrary.hs view
@@ -21,43 +21,3 @@ instance Arbitrary S.ShortByteString where arbitrary = S.toShort `fmap` arbitrary #endif--instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,- Arbitrary f) =>- Arbitrary (a,b,c,d,e,f) where- arbitrary = do- (a,b,c,d,e) <- arbitrary- f <- arbitrary- return (a,b,c,d,e,f)--instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,- Arbitrary f, Arbitrary g) =>- Arbitrary (a,b,c,d,e,f,g) where- arbitrary = do- (a,b,c,d,e) <- arbitrary- (f,g) <- arbitrary- return (a,b,c,d,e,f,g)--instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,- Arbitrary f, Arbitrary g, Arbitrary h) =>- Arbitrary (a,b,c,d,e,f,g,h) where- arbitrary = do- (a,b,c,d,e) <- arbitrary- (f,g,h) <- arbitrary- return (a,b,c,d,e,f,g,h)--instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,- Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i) =>- Arbitrary (a,b,c,d,e,f,g,h,i) where- arbitrary = do- (a,b,c,d,e) <- arbitrary- (f,g,h,i) <- arbitrary- return (a,b,c,d,e,f,g,h,i)--instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,- Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i, Arbitrary j) =>- Arbitrary (a,b,c,d,e,f,g,h,i,j) where- arbitrary = do- (a,b,c,d,e) <- arbitrary- (f,g,h,i,j) <- arbitrary- return (a,b,c,d,e,f,g,h,i,j)
tests/QC.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# LANGUAGE CPP, ScopedTypeVariables, DataKinds, TypeSynonymInstances #-} module Main ( main ) where #if MIN_VERSION_base(4,8,0)@@ -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)@@ -25,27 +21,27 @@ #endif import Data.Int import Data.Ratio+import Data.Typeable import System.IO.Unsafe #ifdef HAS_NATURAL import Numeric.Natural #endif -#ifdef HAS_GHC_FINGERPRINT import GHC.Fingerprint-#endif import qualified Data.Fixed as Fixed import Test.Framework import Test.Framework.Providers.QuickCheck2-import Test.QuickCheck+import Test.QuickCheck hiding (total) import qualified Action (tests) import Arbitrary () import Data.Binary import Data.Binary.Get import Data.Binary.Put+import qualified Data.Binary.Class as Class ------------------------------------------------------------------------ @@ -137,7 +133,58 @@ 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++#if MIN_VERSION_base(4,10,0)+testTypeable :: Test+testTypeable = testProperty "TypeRep" prop_TypeRep++prop_TypeRep :: TypeRep -> Property+prop_TypeRep = roundTripWith Class.put Class.get++atomicTypeReps :: [TypeRep]+atomicTypeReps =+ [ typeRep (Proxy :: Proxy ())+ , typeRep (Proxy :: Proxy String)+ , typeRep (Proxy :: Proxy Int)+ , typeRep (Proxy :: Proxy (,))+ , typeRep (Proxy :: Proxy ((,) (Maybe Int)))+ , typeRep (Proxy :: Proxy Maybe)+ , typeRep (Proxy :: Proxy 'Nothing)+ , typeRep (Proxy :: Proxy 'Left)+ , typeRep (Proxy :: Proxy "Hello")+ , typeRep (Proxy :: Proxy 42)+ , typeRep (Proxy :: Proxy '[1,2,3,4])+ , typeRep (Proxy :: Proxy ('Left Int))+ , typeRep (Proxy :: Proxy (Either Int String))+ , typeRep (Proxy :: Proxy (() -> ()))+ ]++instance Arbitrary TypeRep where+ arbitrary = oneof (map pure atomicTypeReps)+#else+testTypeable :: Test+testTypeable = testGroup "Skipping Typeable tests" []+#endif+ -- done, partial and fail -- | Test partial results.@@ -450,14 +497,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 +605,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 +650,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@@ -659,4 +709,5 @@ , testProperty "HasResolution -> MkFixed" $ p prop_fixed_resolution_constr ] #endif+ , testTypeable ]
tools/derive/BinaryDerive.hs view
@@ -17,7 +17,7 @@ | nTypeChildren > 0 = wrap (join ", " (map ("Binary "++) typeLetters)) ++ " => " | otherwise = ""- inst = wrap $ tyConString typeName ++ concatMap (" "++) typeLetters+ inst = wrap $ tyConName typeName ++ concatMap (" "++) typeLetters wrap x = if nTypeChildren > 0 then "("++x++")" else x join sep lst = concat $ intersperse sep lst nTypeChildren = length typeChildren