diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # binary package # -[![Build Status](https://api.travis-ci.org/kolmodin/binary.png?branch=master)](http://travis-ci.org/kolmodin/binary) +[![Hackage version](https://img.shields.io/hackage/v/binary.svg?label=Hackage)](https://hackage.haskell.org/package/binary) [![Stackage version](https://www.stackage.org/package/binary/badge/lts?label=Stackage)](https://www.stackage.org/package/binary) [![Build Status](https://api.travis-ci.org/kolmodin/binary.png?branch=master)](http://travis-ci.org/kolmodin/binary) *Efficient, pure binary serialisation using lazy ByteStrings.* diff --git a/benchmarks/Builder.hs b/benchmarks/Builder.hs --- a/benchmarks/Builder.hs +++ b/benchmarks/Builder.hs @@ -189,7 +189,9 @@ ------------------------------------------------------------------------ -- Utilities +#if !MIN_VERSION_base(4,11,0) infixr 6 <> (<>) :: Monoid m => m -> m -> m (<>) = mappend +#endif diff --git a/benchmarks/Cabal24.hs b/benchmarks/Cabal24.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Cabal24.hs @@ -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) diff --git a/benchmarks/GenericsBench.hs b/benchmarks/GenericsBench.hs --- a/benchmarks/GenericsBench.hs +++ b/benchmarks/GenericsBench.hs @@ -2,7 +2,7 @@ module Main where import qualified Data.ByteString.Lazy as L -import Distribution.PackageDescription +import Cabal24 (PackageDescription) import Criterion.Main diff --git a/benchmarks/GenericsBenchCache.hs b/benchmarks/GenericsBenchCache.hs --- a/benchmarks/GenericsBenchCache.hs +++ b/benchmarks/GenericsBenchCache.hs @@ -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" diff --git a/benchmarks/GenericsBenchTypes.hs b/benchmarks/GenericsBenchTypes.hs --- a/benchmarks/GenericsBenchTypes.hs +++ b/benchmarks/GenericsBenchTypes.hs @@ -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 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.10.0.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, 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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 -------------- 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 ----------------------------------------------------------------------------- -- | @@ -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 ) 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,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 + 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,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) + 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" @@ -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. --- +-- -- -- 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) 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/Arbitrary.hs b/tests/Arbitrary.hs --- a/tests/Arbitrary.hs +++ b/tests/Arbitrary.hs @@ -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) diff --git a/tests/QC.hs b/tests/QC.hs --- a/tests/QC.hs +++ b/tests/QC.hs @@ -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 ] diff --git a/tools/derive/BinaryDerive.hs b/tools/derive/BinaryDerive.hs --- a/tools/derive/BinaryDerive.hs +++ b/tools/derive/BinaryDerive.hs @@ -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