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