binary 0.7.6.1 → 0.10.0.0
raw patch · 26 files changed
Files
- README.md +1/−1
- benchmarks/Builder.hs +7/−9
- benchmarks/Cabal24.hs +360/−0
- benchmarks/GenericsBench.hs +52/−0
- benchmarks/GenericsBenchCache.hs +40/−0
- benchmarks/GenericsBenchTypes.hs +35/−0
- benchmarks/Get.hs +167/−105
- benchmarks/Put.hs +178/−0
- binary.cabal +158/−27
- changelog.md +76/−0
- src/Data/Binary.hs +9/−9
- src/Data/Binary/Builder.hs +226/−9
- src/Data/Binary/Builder/Base.hs +0/−513
- src/Data/Binary/Builder/Internal.hs +0/−28
- src/Data/Binary/Class.hs +520/−106
- src/Data/Binary/FloatCast.hs +45/−0
- src/Data/Binary/Generic.hs +44/−19
- src/Data/Binary/Get.hs +138/−20
- src/Data/Binary/Get/Internal.hs +42/−30
- src/Data/Binary/Internal.hs +15/−0
- src/Data/Binary/Put.hs +196/−12
- tests/Action.hs +1/−0
- tests/Arbitrary.hs +7/−39
- tests/File.hs +11/−7
- tests/QC.hs +262/−88
- tools/derive/BinaryDerive.hs +1/−1
README.md view
@@ -1,6 +1,6 @@ # binary package # -[](http://travis-ci.org/kolmodin/binary)+[](https://hackage.haskell.org/package/binary) [](https://www.stackage.org/package/binary) [](http://travis-ci.org/kolmodin/binary) *Efficient, pure binary serialisation using lazy ByteStrings.*
benchmarks/Builder.hs view
@@ -6,25 +6,21 @@ module Main (main) where +#if ! MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid(mappend, mempty))+#endif+ import Control.DeepSeq import Control.Exception (evaluate)-import Control.Monad.Trans (liftIO) import Criterion.Main import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.Lazy as L import Data.Char (ord)-import Data.Monoid (Monoid(mappend, mempty)) import Data.Word (Word8) import Data.Binary.Builder -#if !MIN_VERSION_bytestring(0,10,0)-instance NFData S.ByteString-instance NFData L.ByteString where- rnf = rnf . L.toChunks-#endif- main :: IO () main = do evaluate $ rnf@@ -84,7 +80,7 @@ -- Write 100 short, length-prefixed ByteStrings. lengthPrefixedBS :: S.ByteString -> Builder-lengthPrefixedBS bs = loop 100+lengthPrefixedBS bs = loop (100 :: Int) where loop n | n `seq` False = undefined loop 0 = mempty loop n =@@ -193,7 +189,9 @@ ------------------------------------------------------------------------ -- Utilities +#if !MIN_VERSION_base(4,11,0) infixr 6 <> (<>) :: Monoid m => m -> m -> m (<>) = mappend+#endif
+ benchmarks/Cabal24.hs view
@@ -0,0 +1,360 @@+{-# LANGUAGE DeriveGeneric #-}++-- | This module contains type definitions copied from Cabal-1.24.2.0+-- to avoid a dependency on Cabal. Their contents for the benchmark are read+-- from a cache file using their 'Read' instance, see "GenericsBenchCache".+--+module Cabal24 where++import Data.Version (Version)+import GHC.Generics (Generic)+import Data.Map (Map)++data Benchmark = Benchmark {+ benchmarkName :: String,+ benchmarkInterface :: BenchmarkInterface,+ benchmarkBuildInfo :: BuildInfo,+ benchmarkEnabled :: Bool+ } deriving (Generic, Eq, Ord, Read, Show)++data BenchmarkInterface =+ BenchmarkExeV10 Version FilePath+ | BenchmarkUnsupported BenchmarkType+ deriving (Generic, Eq, Ord, Read, Show)++data BenchmarkType = BenchmarkTypeExe Version+ | BenchmarkTypeUnknown String Version+ deriving (Generic, Eq, Ord, Read, Show)++data BuildInfo = BuildInfo {+ buildable :: Bool,+ buildTools :: [Dependency],+ cppOptions :: [String],+ ccOptions :: [String],+ ldOptions :: [String],+ pkgconfigDepends :: [Dependency],+ frameworks :: [String],+ extraFrameworkDirs:: [String],+ cSources :: [FilePath],+ jsSources :: [FilePath],+ hsSourceDirs :: [FilePath],+ otherModules :: [ModuleName],+ defaultLanguage :: Maybe Language,+ otherLanguages :: [Language],+ defaultExtensions :: [Extension],+ otherExtensions :: [Extension],+ oldExtensions :: [Extension],+ extraLibs :: [String],+ extraGHCiLibs :: [String],+ extraLibDirs :: [String],+ includeDirs :: [FilePath],+ includes :: [FilePath],+ installIncludes :: [FilePath],+ options :: [(CompilerFlavor,[String])],+ profOptions :: [(CompilerFlavor,[String])],+ sharedOptions :: [(CompilerFlavor,[String])],+ customFieldsBI :: [(String,String)],+ targetBuildDepends :: [Dependency],+ targetBuildRenaming :: Map PackageName ModuleRenaming+ } deriving (Generic, Eq, Ord, Read, Show)++data BuildType+ = Simple+ | Configure+ | Make+ | Custom+ | UnknownBuildType String+ deriving (Generic, Eq, Ord, Read, Show)++data CompilerFlavor = GHC | GHCJS | NHC | YHC | Hugs | HBC | Helium+ | JHC | LHC | UHC+ | HaskellSuite String+ | OtherCompiler String+ deriving (Generic, Eq, Ord, Read, Show)++data Dependency = Dependency PackageName VersionRange+ deriving (Generic, Eq, Ord, Read, Show)++data Executable = Executable {+ exeName :: String,+ modulePath :: FilePath,+ buildInfo :: BuildInfo+ }+ deriving (Generic, Eq, Ord, Read, Show)++data Extension =+ EnableExtension KnownExtension+ | DisableExtension KnownExtension+ | UnknownExtension String+ deriving (Generic, Eq, Ord, Read, Show)++newtype FlagName = FlagName String+ deriving (Generic, Eq, Ord, Read, Show)++data KnownExtension =+ OverlappingInstances+ | UndecidableInstances+ | IncoherentInstances+ | DoRec+ | RecursiveDo+ | ParallelListComp+ | MultiParamTypeClasses+ | MonomorphismRestriction+ | FunctionalDependencies+ | Rank2Types+ | RankNTypes+ | PolymorphicComponents+ | ExistentialQuantification+ | ScopedTypeVariables+ | PatternSignatures+ | ImplicitParams+ | FlexibleContexts+ | FlexibleInstances+ | EmptyDataDecls+ | CPP+ | KindSignatures+ | BangPatterns+ | TypeSynonymInstances+ | TemplateHaskell+ | ForeignFunctionInterface+ | Arrows+ | Generics+ | ImplicitPrelude+ | NamedFieldPuns+ | PatternGuards+ | GeneralizedNewtypeDeriving+ | ExtensibleRecords+ | RestrictedTypeSynonyms+ | HereDocuments+ | MagicHash+ | TypeFamilies+ | StandaloneDeriving+ | UnicodeSyntax+ | UnliftedFFITypes+ | InterruptibleFFI+ | CApiFFI+ | LiberalTypeSynonyms+ | TypeOperators+ | RecordWildCards+ | RecordPuns+ | DisambiguateRecordFields+ | TraditionalRecordSyntax+ | OverloadedStrings+ | GADTs+ | GADTSyntax+ | MonoPatBinds+ | RelaxedPolyRec+ | ExtendedDefaultRules+ | UnboxedTuples+ | DeriveDataTypeable+ | DeriveGeneric+ | DefaultSignatures+ | InstanceSigs+ | ConstrainedClassMethods+ | PackageImports+ | ImpredicativeTypes+ | NewQualifiedOperators+ | PostfixOperators+ | QuasiQuotes+ | TransformListComp+ | MonadComprehensions+ | ViewPatterns+ | XmlSyntax+ | RegularPatterns+ | TupleSections+ | GHCForeignImportPrim+ | NPlusKPatterns+ | DoAndIfThenElse+ | MultiWayIf+ | LambdaCase+ | RebindableSyntax+ | ExplicitForAll+ | DatatypeContexts+ | MonoLocalBinds+ | DeriveFunctor+ | DeriveTraversable+ | DeriveFoldable+ | NondecreasingIndentation+ | SafeImports+ | Safe+ | Trustworthy+ | Unsafe+ | ConstraintKinds+ | PolyKinds+ | DataKinds+ | ParallelArrays+ | RoleAnnotations+ | OverloadedLists+ | EmptyCase+ | AutoDeriveTypeable+ | NegativeLiterals+ | BinaryLiterals+ | NumDecimals+ | NullaryTypeClasses+ | ExplicitNamespaces+ | AllowAmbiguousTypes+ | JavaScriptFFI+ | PatternSynonyms+ | PartialTypeSignatures+ | NamedWildCards+ | DeriveAnyClass+ | DeriveLift+ | StaticPointers+ | StrictData+ | Strict+ | ApplicativeDo+ | DuplicateRecordFields+ | TypeApplications+ | TypeInType+ | UndecidableSuperClasses+ | MonadFailDesugaring+ | TemplateHaskellQuotes+ | OverloadedLabels+ deriving (Generic, Eq, Ord, Read, Show)++data Language =+ Haskell98+ | Haskell2010+ | UnknownLanguage String+ deriving (Generic, Eq, Ord, Read, Show)++data Library = Library {+ exposedModules :: [ModuleName],+ reexportedModules :: [ModuleReexport],+ requiredSignatures:: [ModuleName],+ exposedSignatures:: [ModuleName],+ libExposed :: Bool,+ libBuildInfo :: BuildInfo+ }+ deriving (Generic, Eq, Ord, Read, Show)++data License =+ GPL (Maybe Version)+ | AGPL (Maybe Version)+ | LGPL (Maybe Version)+ | BSD2+ | BSD3+ | BSD4+ | MIT+ | ISC+ | MPL Version+ | Apache (Maybe Version)+ | PublicDomain+ | AllRightsReserved+ | UnspecifiedLicense+ | OtherLicense+ | UnknownLicense String+ deriving (Generic, Eq, Ord, Read, Show)++newtype ModuleName = ModuleName [String]+ deriving (Generic, Eq, Ord, Read, Show)++data ModuleReexport = ModuleReexport {+ moduleReexportOriginalPackage :: Maybe PackageName,+ moduleReexportOriginalName :: ModuleName,+ moduleReexportName :: ModuleName+ } deriving (Generic, Eq, Ord, Read, Show)++data ModuleRenaming = ModuleRenaming Bool [(ModuleName, ModuleName)]+ deriving (Generic, Eq, Ord, Read, Show)++data PackageDescription+ = PackageDescription {+ package :: PackageIdentifier,+ license :: License,+ licenseFiles :: [FilePath],+ copyright :: String,+ maintainer :: String,+ author :: String,+ stability :: String,+ testedWith :: [(CompilerFlavor,VersionRange)],+ homepage :: String,+ pkgUrl :: String,+ bugReports :: String,+ sourceRepos :: [SourceRepo],+ synopsis :: String,+ description :: String,+ category :: String,+ customFieldsPD :: [(String,String)],+ buildDepends :: [Dependency],+ specVersionRaw :: Either Version VersionRange,+ buildType :: Maybe BuildType,+ setupBuildInfo :: Maybe SetupBuildInfo,+ library :: Maybe Library,+ executables :: [Executable],+ testSuites :: [TestSuite],+ benchmarks :: [Benchmark],+ dataFiles :: [FilePath],+ dataDir :: FilePath,+ extraSrcFiles :: [FilePath],+ extraTmpFiles :: [FilePath],+ extraDocFiles :: [FilePath]+ } deriving (Generic, Eq, Ord, Read, Show)++data PackageIdentifier+ = PackageIdentifier {+ pkgName :: PackageName,+ pkgVersion :: Version+ }+ deriving (Generic, Eq, Ord, Read, Show)++newtype PackageName = PackageName { unPackageName :: String }+ deriving (Generic, Eq, Ord, Read, Show)++data RepoKind =+ RepoHead+ | RepoThis+ | RepoKindUnknown String+ deriving (Generic, Eq, Ord, Read, Show)++data RepoType = Darcs | Git | SVN | CVS+ | Mercurial | GnuArch | Bazaar | Monotone+ | OtherRepoType String+ deriving (Generic, Eq, Ord, Read, Show)++data SetupBuildInfo = SetupBuildInfo {+ setupDepends :: [Dependency],+ defaultSetupDepends :: Bool+ }+ deriving (Generic, Eq, Ord, Read, Show)++data SourceRepo = SourceRepo {+ repoKind :: RepoKind,+ repoType :: Maybe RepoType,+ repoLocation :: Maybe String,+ repoModule :: Maybe String,+ repoBranch :: Maybe String,+ repoTag :: Maybe String,+ repoSubdir :: Maybe FilePath+}+ deriving (Generic, Eq, Ord, Read, Show)++data TestSuite = TestSuite {+ testName :: String,+ testInterface :: TestSuiteInterface,+ testBuildInfo :: BuildInfo,+ testEnabled :: Bool+ }+ deriving (Generic, Eq, Ord, Read, Show)++data TestSuiteInterface =+ TestSuiteExeV10 Version FilePath+ | TestSuiteLibV09 Version ModuleName+ | TestSuiteUnsupported TestType+ deriving (Generic, Eq, Ord, Read, Show)++data TestType = TestTypeExe Version+ | TestTypeLib Version+ | TestTypeUnknown String Version+ deriving (Generic, Eq, Ord, Read, Show)++data VersionRange+ = AnyVersion+ | ThisVersion Version+ | LaterVersion Version+ | EarlierVersion Version+ | WildcardVersion Version+ | UnionVersionRanges VersionRange VersionRange+ | IntersectVersionRanges VersionRange VersionRange+ | VersionRangeParens VersionRange+ deriving (Generic, Eq, Ord, Read, Show)
+ benchmarks/GenericsBench.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DeriveGeneric, StandaloneDeriving, BangPatterns #-}+module Main where++import qualified Data.ByteString.Lazy as L+import Cabal24 (PackageDescription)++import Criterion.Main++import qualified Data.Binary as Binary+import Data.Binary.Get (Get)+import qualified Data.Binary.Get as Binary++import GenericsBenchCache++main :: IO ()+main = benchmark =<< readPackageDescriptionCache 100++benchmark :: [PackageDescription] -> IO ()+benchmark pds = do+ let lbs = encode pds+ !_ = L.length lbs+ str = show pds+ !_ = length str+ defaultMain [+ bench "encode" (nf encode pds)+ , bench "decode" (nf decode lbs)+ , bench "decode null" (nf decodeNull lbs)+ , bgroup "embarrassment" [+ bench "read" (nf readPackageDescription str)+ , bench "show" (nf show pds)+ ]+ ]++encode :: [PackageDescription] -> L.ByteString+encode = Binary.encode++decode :: L.ByteString -> Int+decode = length . (Binary.decode :: L.ByteString -> [PackageDescription])++decodeNull :: L.ByteString -> ()+decodeNull =+ Binary.runGet $ do+ n <- Binary.get :: Get Int+ go n+ where+ go 0 = return ()+ go i = do+ x <- Binary.get :: Get PackageDescription+ x `seq` go (i-1)++readPackageDescription :: String -> Int+readPackageDescription = length . (read :: String -> [PackageDescription])
+ benchmarks/GenericsBenchCache.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DeriveGeneric, StandaloneDeriving, BangPatterns, CPP #-}+module GenericsBenchCache (readPackageDescriptionCache) where++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 System.Directory+import System.Exit++import GenericsBenchTypes ()++#if ! MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++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)+ -- PackageDescription doesn't implement NFData, let's force with the following line+ (length (show pds)) `seq` putStrLn "done reading the cache file"+ return pds++cacheFilePath :: String+cacheFilePath = "generics-bench.cache.gz"
+ benchmarks/GenericsBenchTypes.hs view
@@ -0,0 +1,35 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module GenericsBenchTypes where++import Cabal24+import Generics.Deriving.Instances ()+import Data.Binary++instance Binary Benchmark+instance Binary BenchmarkInterface+instance Binary BenchmarkType+instance Binary BuildInfo+instance Binary BuildType+instance Binary CompilerFlavor+instance Binary Dependency+instance Binary Executable+instance Binary Extension+instance Binary FlagName+instance Binary KnownExtension+instance Binary Language+instance Binary Library+instance Binary License+instance Binary ModuleName+instance Binary ModuleReexport+instance Binary ModuleRenaming+instance Binary PackageDescription+instance Binary PackageIdentifier+instance Binary PackageName+instance Binary RepoKind+instance Binary RepoType+instance Binary SetupBuildInfo+instance Binary SourceRepo+instance Binary TestSuite+instance Binary TestSuiteInterface+instance Binary TestType+instance Binary VersionRange
benchmarks/Get.hs view
@@ -8,21 +8,19 @@ import Control.DeepSeq import Control.Exception (evaluate)-import Control.Monad.Trans (liftIO) import Criterion.Main import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as L+import Data.Bits import Data.Char (ord)-import Data.Monoid (Monoid(mappend, mempty))-import Data.Word (Word8, Word16, Word32)+import Data.List (foldl') import Control.Applicative+import Data.Binary import Data.Binary.Get-import Data.Binary ( get ) import qualified Data.Serialize.Get as Cereal-import qualified Data.Serialize as Cereal import qualified Data.Attoparsec.ByteString as A import qualified Data.Attoparsec.ByteString.Lazy as AL@@ -40,62 +38,88 @@ rnf bracketsInChunks, rnf bracketCount, rnf oneMegabyte,- rnf oneMegabyteLBS+ rnf oneMegabyteLBS,+ rnf manyBytes,+ rnf encodedBigInteger ] defaultMain- [- bench "brackets 100kb one chunk input" $- whnf (checkBracket . runTest bracketParser) brackets- , bench "brackets 100kb in 100 byte chunks" $- whnf (checkBracket . runTest bracketParser) bracketsInChunks- , bench "Attoparsec lazy-bs brackets 100kb one chunk" $- whnf (checkBracket . runAttoL bracketParser_atto) brackets- , bench "Attoparsec lazy-bs brackets 100kb in 100 byte chunks" $- whnf (checkBracket . runAttoL bracketParser_atto) bracketsInChunks- , bench "Attoparsec strict-bs brackets 100kb" $- whnf (checkBracket . runAtto bracketParser_atto) $ S.concat (L.toChunks brackets)- , bench "Cereal strict-bs brackets 100kb" $- whnf (checkBracket . runCereal bracketParser_cereal) $ S.concat (L.toChunks brackets)- , bench "Binary getStruct4 1MB struct of 4 word8" $- whnf (runTest (getStruct4 mega)) oneMegabyteLBS- , bench "Cereal getStruct4 1MB struct of 4 word8" $- whnf (runCereal (getStruct4_cereal mega)) oneMegabyte- , bench "Attoparsec getStruct4 1MB struct of 4 word8" $- whnf (runAtto (getStruct4_atto mega)) oneMegabyte- , bench "Binary getWord8 1MB chunk size 1 byte" $- whnf (runTest (getWord8N1 mega)) oneMegabyteLBS- , bench "Cereal getWord8 1MB chunk size 1 byte" $- whnf (runCereal (getWord8N1_cereal mega)) oneMegabyte- , bench "Attoparsec getWord8 1MB chunk size 1 byte" $- whnf (runAtto (getWord8N1_atto mega)) oneMegabyte- , bench "getWord8 1MB chunk size 2 bytes" $- whnf (runTest (getWord8N2 mega)) oneMegabyteLBS- , bench "getWord8 1MB chunk size 4 bytes" $- whnf (runTest (getWord8N4 mega)) oneMegabyteLBS- , bench "getWord8 1MB chunk size 8 bytes" $- whnf (runTest (getWord8N8 mega)) oneMegabyteLBS- , bench "getWord8 1MB chunk size 16 bytes" $- whnf (runTest (getWord8N16 mega)) oneMegabyteLBS- , bench "getWord8 1MB chunk size 2 bytes Applicative" $- whnf (runTest (getWord8N2A mega)) oneMegabyteLBS- , bench "getWord8 1MB chunk size 4 bytes Applicative" $- whnf (runTest (getWord8N4A mega)) oneMegabyteLBS- , bench "getWord8 1MB chunk size 8 bytes Applicative" $- whnf (runTest (getWord8N8A mega)) oneMegabyteLBS- , bench "getWord8 1MB chunk size 16 bytes Applicative" $- whnf (runTest (getWord8N16A mega)) oneMegabyteLBS+ [ bgroup "brackets"+ [ bench "Binary 100kb, one chunk" $+ whnf (checkBracket . runTest bracketParser) brackets+ , bench "Binary 100kb, 100 byte chunks" $+ whnf (checkBracket . runTest bracketParser) bracketsInChunks+ , bench "Attoparsec lazy-bs 100kb, one chunk" $+ whnf (checkBracket . runAttoL bracketParser_atto) brackets+ , bench "Attoparsec lazy-bs 100kb, 100 byte chunks" $+ whnf (checkBracket . runAttoL bracketParser_atto) bracketsInChunks+ , bench "Attoparsec strict-bs 100kb" $+ whnf (checkBracket . runAtto bracketParser_atto) $ S.concat (L.toChunks brackets)+ , bench "Cereal strict-bs 100kb" $+ whnf (checkBracket . runCereal bracketParser_cereal) $ S.concat (L.toChunks brackets)+ ]+ , bgroup "comparison getStruct4, 1MB of struct of 4 Word8s"+ [ bench "Attoparsec" $+ whnf (runAtto (getStruct4_atto mega)) oneMegabyte+ , bench "Binary" $+ whnf (runTest (getStruct4 mega)) oneMegabyteLBS+ , bench "Cereal" $+ whnf (runCereal (getStruct4_cereal mega)) oneMegabyte+ ]+ , bgroup "comparison getWord8, 1MB"+ [ bench "Attoparsec" $+ whnf (runAtto (getWord8N1_atto mega)) oneMegabyte+ , bench "Binary" $+ whnf (runTest (getWord8N1 mega)) oneMegabyteLBS+ , bench "Cereal" $+ whnf (runCereal (getWord8N1_cereal mega)) oneMegabyte+ ]+ , bgroup "getWord8 1MB"+ [ bench "chunk size 2 bytes" $+ whnf (runTest (getWord8N2 mega)) oneMegabyteLBS+ , bench "chunk size 4 bytes" $+ whnf (runTest (getWord8N4 mega)) oneMegabyteLBS+ , bench "chunk size 8 bytes" $+ whnf (runTest (getWord8N8 mega)) oneMegabyteLBS+ , bench "chunk size 16 bytes" $+ whnf (runTest (getWord8N16 mega)) oneMegabyteLBS+ ]+ , bgroup "getWord8 1MB Applicative"+ [ bench "chunk size 2 bytes" $+ whnf (runTest (getWord8N2A mega)) oneMegabyteLBS+ , bench "chunk size 4 bytes" $+ whnf (runTest (getWord8N4A mega)) oneMegabyteLBS+ , bench "chunk size 8 bytes" $+ whnf (runTest (getWord8N8A mega)) oneMegabyteLBS+ , bench "chunk size 16 bytes" $+ whnf (runTest (getWord8N16A mega)) oneMegabyteLBS+ ]+ , bgroup "roll"+ [ bench "foldr" $ nf (roll_foldr :: [Word8] -> Integer) manyBytes+ , bench "foldl'" $ nf (roll_foldl' :: [Word8] -> Integer) manyBytes+ ]+ , bgroup "Integer"+ [ bench "decode" $ nf (decode :: L.ByteString -> Integer) encodedBigInteger+ ] ] +checkBracket :: Int -> Int checkBracket x | x == bracketCount = x | otherwise = error "argh!" +runTest :: Get a -> L.ByteString -> a runTest decoder inp = runGet decoder inp++runCereal :: Cereal.Get a -> C8.ByteString -> a runCereal decoder inp = case Cereal.runGet decoder inp of Right a -> a Left err -> error err++runAtto :: AL.Parser a -> C8.ByteString -> a runAtto decoder inp = case A.parseOnly decoder inp of Right a -> a Left err -> error err++runAttoL :: Show a => AL.Parser a -> L.ByteString -> a runAttoL decoder inp = case AL.parse decoder inp of AL.Done _ r -> r a -> error (show a)@@ -108,15 +132,20 @@ oneMegabyteLBS :: L.ByteString oneMegabyteLBS = L.fromChunks [oneMegabyte] +mega :: Int mega = 1024 * 1024 -- 100k of brackets+bracketTest :: L.ByteString -> Int bracketTest inp = runTest bracketParser inp bracketCount :: Int bracketCount = fromIntegral $ L.length brackets `div` 2 +brackets :: L.ByteString brackets = L.fromChunks [C8.concat (L.toChunks bracketsInChunks)]++bracketsInChunks :: L.ByteString bracketsInChunks = L.fromChunks (replicate chunksOfBrackets oneChunk) where oneChunk = "((()((()()))((()(()()()()()()()(((()()()()(()()(()(()())))))()((())())))()())(((())())(()))))()(()))"@@ -143,19 +172,23 @@ bracketParser_atto :: A.Parser Int bracketParser_atto = cont <|> return 0 where- cont = do v <- some ( do A.word8 40+ cont = do v <- some ( do _ <- A.word8 40 n <- bracketParser_atto- A.word8 41+ _ <- A.word8 41 return $! n + 1) return $! sum v -- Strict struct of 4 Word8s-data Struct4 = Struct4 {-# UNPACK #-} !Word8- {-# UNPACK #-} !Word8- {-# UNPACK #-} !Word8- {-# UNPACK #-} !Word8- deriving Show+data S2 = S2 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+data S4 = S4 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+data S8 = S8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+ {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+data S16 = S16 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+ {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+ {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+ {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 +getStruct4 :: Int -> Get [S4] getStruct4 = loop [] where loop acc 0 = return acc loop acc n = do@@ -163,9 +196,10 @@ !w1 <- getWord8 !w2 <- getWord8 !w3 <- getWord8- let !s = Struct4 w0 w1 w2 w3+ let !s = S4 w0 w1 w2 w3 loop (s : acc) (n - 4) +getStruct4_cereal :: Int -> Cereal.Get [S4] getStruct4_cereal = loop [] where loop acc 0 = return acc loop acc n = do@@ -173,9 +207,10 @@ !w1 <- Cereal.getWord8 !w2 <- Cereal.getWord8 !w3 <- Cereal.getWord8- let !s = Struct4 w0 w1 w2 w3+ let !s = S4 w0 w1 w2 w3 loop (s : acc) (n - 4) +getStruct4_atto :: Int -> A.Parser [S4] getStruct4_atto = loop [] where loop acc 0 = return acc loop acc n = do@@ -183,48 +218,53 @@ !w1 <- A.anyWord8 !w2 <- A.anyWord8 !w3 <- A.anyWord8- let !s = Struct4 w0 w1 w2 w3+ let !s = S4 w0 w1 w2 w3 loop (s : acc) (n - 4) --- No-allocation loops.--getWord8N1 = loop 0+getWord8N1 :: Int -> Get [Word8]+getWord8N1 = loop [] where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord8- loop (s0+s) (n-1)+ loop (s0:s) (n-1) -getWord8N1_cereal = loop 0+getWord8N1_cereal :: Int -> Cereal.Get [Word8]+getWord8N1_cereal = loop [] where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- Cereal.getWord8- loop (s0+s) (n-1)+ loop (s0:s) (n-1) -getWord8N1_atto = loop 0+getWord8N1_atto :: Int -> A.Parser [Word8]+getWord8N1_atto = loop [] where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- A.anyWord8- loop (s0+s) (n-1)+ loop (s0:s) (n-1) -getWord8N2 = loop 0+getWord8N2 :: Int -> Get [S2]+getWord8N2 = loop [] where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord8 s1 <- getWord8- loop (s0+s1+s) (n-2)+ let !v = S2 s0 s1+ loop (v:s) (n-2) -getWord8N2A = loop 0+getWord8N2A :: Int -> Get [S2]+getWord8N2A = loop [] where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do- v <- (+) <$> getWord8 <*> getWord8- loop (s+v) (n-2)+ !v <- S2 <$> getWord8 <*> getWord8+ loop (v:s) (n-2) -getWord8N4 = loop 0+getWord8N4 :: Int -> Get [S4]+getWord8N4 = loop [] where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do@@ -232,17 +272,19 @@ s1 <- getWord8 s2 <- getWord8 s3 <- getWord8- loop (s+s0+s1+s2+s3) (n-4)+ let !v = S4 s0 s1 s2 s3+ loop (v:s) (n-4) -getWord8N4A = loop 0+getWord8N4A :: Int -> Get [S4]+getWord8N4A = loop [] where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do- let p !s0 !s1 !s2 !s3 = s0 + s1 + s2 + s3- v <- p <$> getWord8 <*> getWord8 <*> getWord8 <*> getWord8- loop (s+v) (n-4)+ !v <- S4 <$> getWord8 <*> getWord8 <*> getWord8 <*> getWord8+ loop (v:s) (n-4) -getWord8N8 = loop 0+getWord8N8 :: Int -> Get [S8]+getWord8N8 = loop [] where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do@@ -254,15 +296,15 @@ s5 <- getWord8 s6 <- getWord8 s7 <- getWord8- loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)+ let !v = S8 s0 s1 s2 s3 s4 s5 s6 s7+ loop (v:s) (n-8) -getWord8N8A = loop 0+getWord8N8A :: Int -> Get [S8]+getWord8N8A = loop [] where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do- let p !s0 !s1 !s2 !s3 !s4 !s5 !s6 !s7 =- s0 + s1 + s2 + s3 + s4 + s5 + s6 + s7- v <- p <$> getWord8+ !v <- S8 <$> getWord8 <*> getWord8 <*> getWord8 <*> getWord8@@ -270,9 +312,10 @@ <*> getWord8 <*> getWord8 <*> getWord8- loop (s+v) (n-8)+ loop (v:s) (n-8) -getWord8N16 = loop 0+getWord8N16 :: Int -> Get [S16]+getWord8N16 = loop [] where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do@@ -292,28 +335,47 @@ s13 <- getWord8 s14 <- getWord8 s15 <- getWord8- loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11+s12+s13+s14+s15) (n-16)+ let !v = S16 s0 s1 s2 s3 s4 s5 s6 s7 s8 s9 s10 s11 s12 s13 s14 s15+ loop (v:s) (n-16) -getWord8N16A = loop 0+getWord8N16A :: Int -> Get [S16]+getWord8N16A = loop [] where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do- let p !s0 !s1 !s2 !s3 !s4 !s5 !s6 !s7 !s8 !s9 !s10 !s11 !s12 !s13 !s14 !s15 =- s0 + s1 + s2 + s3 + s4 + s5 + s6 + s7 + s8 + s9 + s10 + s11 + s12 + s13 + s14 + s15- !v <- p <$> getWord8- <*> getWord8- <*> getWord8- <*> getWord8- <*> getWord8- <*> getWord8- <*> getWord8- <*> getWord8- <*> getWord8- <*> getWord8- <*> getWord8- <*> getWord8- <*> getWord8- <*> getWord8- <*> getWord8- <*> getWord8- loop (s+v) (n-16)+ !v <- S16 <$> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ loop (v:s) (n-16)++manyBytes :: [Word8]+manyBytes = concat $ replicate 256 [0..255]++bigInteger :: Integer+bigInteger = roll_foldl' manyBytes++encodedBigInteger :: L.ByteString+encodedBigInteger = encode bigInteger++roll_foldr :: (Integral a, Bits a) => [Word8] -> a+roll_foldr = foldr unstep 0+ where+ unstep b a = a `shiftL` 8 .|. fromIntegral b++roll_foldl' :: (Integral a, Bits a) => [Word8] -> a+roll_foldl' = foldl' unstep 0 . reverse+ where+ unstep a b = a `shiftL` 8 .|. fromIntegral b
+ benchmarks/Put.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE CPP, ExistentialQuantification #-}+{-# LANGUAGE DeriveGeneric #-}++module Main (main) where++import Control.DeepSeq+import Control.Exception (evaluate)+import Criterion.Main+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as C+import qualified Data.ByteString.Lazy as L+import Data.Monoid++import GHC.Generics++import Data.Binary+import Data.Binary.Put+import Data.ByteString.Builder as BB+import Prelude -- Silence Monoid import warning.++main :: IO ()+main = do+ evaluate $ rnf+ [ rnf bigIntegers+ , rnf smallIntegers+ , rnf smallByteStrings+ , rnf smallStrings+ , rnf doubles+ , rnf word8s+ , rnf word16s+ , rnf word32s+ , rnf word64s+ ]+ defaultMain+ [+ bench "small Integers" $ whnf (run . fromIntegers) smallIntegers,+ bench "big Integers" $ whnf (run . fromIntegers) bigIntegers,++ bench "[small Integer]" $ whnf (run . put) smallIntegers,+ bench "[big Integer]" $ whnf (run . put) bigIntegers,++ bench "small ByteStrings" $ whnf (run . fromByteStrings) smallByteStrings,+ bench "[small ByteString]" $ whnf (run . put) smallByteStrings,++ bench "small Strings" $ whnf (run . fromStrings) smallStrings,+ bench "[small String]" $ whnf (run . put) smallStrings,++ bench "Double" $ whnf (run . put) doubles,++ bench "Word8s monoid put" $ whnf (run . fromWord8s) word8s,+ bench "Word8s builder" $ whnf (L.length . toLazyByteString . fromWord8sBuilder) word8s,+ bench "[Word8]" $ whnf (run . put) word8s,+ bench "Word16s monoid put" $ whnf (run . fromWord16s) word16s,+ bench "Word16s builder" $ whnf (L.length . toLazyByteString . fromWord16sBuilder) word16s,+ bench "[Word16]" $ whnf (run . put) word16s,+ bench "Word32s monoid put" $ whnf (run . fromWord32s) word32s,+ bench "Word32s builder" $ whnf (L.length . toLazyByteString . fromWord32sBuilder) word32s,+ bench "[Word32]" $ whnf (run . put) word32s,+ bench "Word64s monoid put" $ whnf (run . fromWord64s) word64s,+ bench "Word64s builder" $ whnf (L.length . toLazyByteString . fromWord64sBuilder) word64s,+ bench "[Word64]" $ whnf (run . put) word64s++ , 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+ ]+ ]+ where+ run = L.length . runPut++data Struct = Struct Word8 Word16 Word32 Word64 deriving Generic+instance Binary Struct++data StructList = StructList [Struct] deriving Generic+instance Binary StructList++structs :: [Struct]+structs = take 10000 $ [ Struct a b 0 0 | a <- [0 .. maxBound], b <- [0 .. maxBound] ]++structLists :: [StructList]+structLists = replicate 1000 (StructList (take 10 structs))++-- Input data++smallIntegers :: [Integer]+smallIntegers = [0..10000]+{-# NOINLINE smallIntegers #-}++bigIntegers :: [Integer]+bigIntegers = [m .. m + 10000]+ where+ m :: Integer+ m = fromIntegral (maxBound :: Word64)+{-# NOINLINE bigIntegers #-}++smallByteStrings :: [S.ByteString]+smallByteStrings = replicate 10000 $ C.pack "abcdefghi"+{-# NOINLINE smallByteStrings #-}++smallStrings :: [String]+smallStrings = replicate 10000 "abcdefghi"+{-# NOINLINE smallStrings #-}++doubles :: [Double]+doubles = take 10000 $ [ sign * 2 ** n | sign <- [-1, 1], n <- [ 0, 0.2 .. 1023 ]]++word8s :: [Word8]+word8s = take 10000 $ cycle [minBound .. maxBound]+{-# NOINLINE word8s #-}++word16s :: [Word16]+word16s = take 10000 $ cycle [minBound .. maxBound]+{-# NOINLINE word16s #-}++word32s :: [Word32]+word32s = take 10000 $ cycle [minBound .. maxBound]+{-# NOINLINE word32s #-}++word64s :: [Word64]+word64s = take 10000 $ cycle [minBound .. maxBound]+{-# NOINLINE word64s #-}++------------------------------------------------------------------------+-- Benchmarks++fromIntegers :: [Integer] -> Put+fromIntegers [] = mempty+fromIntegers (x:xs) = put x `mappend` fromIntegers xs++fromByteStrings :: [S.ByteString] -> Put+fromByteStrings [] = mempty+fromByteStrings (x:xs) = put x `mappend` fromByteStrings xs++fromStrings :: [String] -> Put+fromStrings [] = mempty+fromStrings (x:xs) = put x `mappend` fromStrings xs++fromWord8s :: [Word8] -> Put+fromWord8s [] = mempty+fromWord8s (x:xs) = put x `mappend` fromWord8s xs++fromWord8sBuilder :: [Word8] -> BB.Builder+fromWord8sBuilder [] = mempty+fromWord8sBuilder (x:xs) = BB.word8 x `mappend` fromWord8sBuilder xs++fromWord16s :: [Word16] -> Put+fromWord16s [] = mempty+fromWord16s (x:xs) = put x `mappend` fromWord16s xs++fromWord16sBuilder :: [Word16] -> BB.Builder+fromWord16sBuilder [] = mempty+fromWord16sBuilder (x:xs) = BB.word16BE x `mappend` fromWord16sBuilder xs++fromWord32s :: [Word32] -> Put+fromWord32s [] = mempty+fromWord32s (x:xs) = put x `mappend` fromWord32s xs++fromWord32sBuilder :: [Word32] -> BB.Builder+fromWord32sBuilder [] = mempty+fromWord32sBuilder (x:xs) = BB.word32BE x `mappend` fromWord32sBuilder xs++fromWord64s :: [Word64] -> Put+fromWord64s [] = mempty+fromWord64s (x:xs) = put x `mappend` fromWord64s xs++fromWord64sBuilder :: [Word64] -> BB.Builder+fromWord64sBuilder [] = mempty+fromWord64sBuilder (x:xs) = BB.word64BE x `mappend` fromWord64sBuilder xs++fromStructs :: [Struct] -> Put+fromStructs [] = mempty+fromStructs (x:xs) = put x `mappend` fromStructs xs++fromStructLists :: [StructList] -> Put+fromStructLists [] = mempty+fromStructLists (x:xs) = put x `mappend` fromStructLists xs
binary.cabal view
@@ -1,5 +1,5 @@ name: binary-version: 0.7.6.1+version: 0.10.0.0 license: BSD3 license-file: LICENSE author: Lennart Kolmodin <kolmodin@gmail.com>@@ -18,7 +18,7 @@ stability: provisional build-type: Simple cabal-version: >= 1.8-tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1+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,27 +31,27 @@ location: git://github.com/kolmodin/binary.git library- build-depends: base >= 3.0 && < 5, bytestring >= 0.9, 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, Data.Binary.Get, Data.Binary.Get.Internal,- Data.Binary.Builder,- Data.Binary.Builder.Internal-- other-modules: Data.Binary.Builder.Base,- Data.Binary.Class+ Data.Binary.Builder - if impl(ghc >= 7.2.1)- cpp-options: -DGENERICS- other-modules: Data.Binary.Generic- if impl(ghc <= 7.6)- -- prior to ghc-7.4 generics lived in ghc-prim- build-depends: ghc-prim+ other-modules: Data.Binary.Class,+ 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 + if impl(ghc >= 8.0)+ 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@@ -64,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.9,+ 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.9,+ base >= 4.5.0.0 && < 5,+ bytestring >= 0.10.4, Cabal, directory, filepath,@@ -91,47 +115,154 @@ -- 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, mtl -- build dependencies from using binary source rather than depending on the library build-depends: array, containers- ghc-options: -O2+ 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 >= 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.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 >= 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,+ 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.6)+ -- prior to ghc-7.4 generics lived in ghc-prim+ build-depends: ghc-prim+ benchmark builder type: exitcode-stdio-1.0 hs-source-dirs: src benchmarks main-is: Builder.hs+ other-modules:+ Data.Binary+ Data.Binary.Builder+ Data.Binary.Class+ Data.Binary.FloatCast+ Data.Binary.Generic+ Data.Binary.Get+ Data.Binary.Get.Internal+ Data.Binary.Internal+ Data.Binary.Put build-depends:- base >= 3.0 && < 5,- bytestring,+ base >= 4.5.0.0 && < 5,+ bytestring >= 0.10.4, criterion == 1.*, deepseq, mtl -- build dependencies from using binary source rather than depending on the library build-depends: array, containers ghc-options: -O2+ if impl(ghc <= 7.6)+ -- prior to ghc-7.4 generics lived in ghc-prim+ build-depends: ghc-prim
changelog.md view
@@ -1,6 +1,82 @@ 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+--------------++- Replace binary's home grown `Builder` with `Data.ByteString.Builder`.+ `Data.Binary.Builder` now exports `Data.ByteString.Builder.Builder`.+- Add `putList :: [a] -> Put` to the `Binary` class. This is used to be able to+ use the list writing primitives of the new Builder. This brought a number of speedups;+ Encoding a String is now 70% faster. [Word8] is 76% faster, which also makes+ Integer 34% faster. Similar numbers for all [IntXX] and [WordXX].+- Fail gracefully within `Get` when decoding `Bool` and `Ordering`. Previously+ when decoding invalid data these instances would fail with `error`.+- Add Binary instance for `Complex a`.+- Add Monoid and Semigroup instance for `Put`.++binary-0.8.2.1+--------------++- Fix compilation error when using older GHC versions and clang. clang barfs on some of its CPP input (#105).++binary-0.8.2.0+--------------++- When using GHC >= 8, `Data.Binary.Get.Get` implements MonadFail and delegates its `fail` to `MonadFail.fail`.++binary-0.8.1.0+--------------++- Add binary instance for `Data.ByteString.Short`.+- Add get/put functions for all Int sizes to `Data.Binary.Builder`, `Data.Binary.Get` and `Data.Binary.Put`.++binary-0.8.0.1+--------------++- Address compiler warnings.++binary-0.8.0.0+--------------++- Added binary instance for `Version` from `Data.Version`.+- Added binary instance for `Void` from GHC 7.10.1.+- Added binary instance for `(Data.Fixed a)` from GHC 7.8.1.+- Added semigroup instance for `Data.Binary.Builder` from GHC 8.0.+ binary-0.7.6.1 --------------
src/Data/Binary.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Binary@@ -30,8 +28,9 @@ -- If the specifics of the data format is not important to you, for example, -- you are more interested in serializing and deserializing values than -- in which format will be used, it is possible to derive 'Binary'--- instances using the generic support. See 'GBinary'.--- +-- instances using the generic support. See 'GBinaryGet' and+-- 'GBinaryPut'.+-- -- If you have specific requirements about the encoding format, you can use -- the encoding and decoding primitives directly, see the modules -- "Data.Binary.Get" and "Data.Binary.Put".@@ -45,11 +44,10 @@ -- ** Example -- $example -#ifdef GENERICS -- * Generic support -- $generics- , GBinary(..)-#endif+ , GBinaryGet(..)+ , GBinaryPut(..) -- * The Get and Put monads , Get@@ -78,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)@@ -180,6 +176,8 @@ -- 'Right' on success. In both cases the unconsumed input and the number of -- consumed bytes is returned. In case of failure, a human-readable error -- message will be returned as well.+--+-- /Since: 0.7.0.0/ decodeOrFail :: Binary a => L.ByteString -> Either (L.ByteString, ByteOffset, String) (L.ByteString, ByteOffset, a)@@ -204,6 +202,8 @@ -- | Decode a value from a file. In case of errors, 'error' will -- be called with the error message.+--+-- /Since: 0.7.0.0/ decodeFile :: Binary a => FilePath -> IO a decodeFile f = do result <- decodeFileOrFail f
src/Data/Binary/Builder.hs view
@@ -1,23 +1,23 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE CPP, MagicHash #-} {-# LANGUAGE Safe #-}-#endif+ ----------------------------------------------------------------------------- -- | -- Module : Data.Binary.Builder -- Copyright : Lennart Kolmodin, Ross Paterson -- License : BSD3-style (see LICENSE)--- +-- -- Maintainer : Lennart Kolmodin <kolmodin@gmail.com> -- Stability : experimental -- Portability : portable to Hugs and GHC ----- Efficient construction of lazy bytestrings.+-- Efficient constructions of lazy bytestrings. --+-- This now re-exports 'Data.ByteString.Lazy.Builder'.+-- ----------------------------------------------------------------------------- module Data.Binary.Builder (- -- * The Builder type Builder , toLazyByteString@@ -28,7 +28,9 @@ , append , fromByteString -- :: S.ByteString -> Builder , fromLazyByteString -- :: L.ByteString -> Builder-+#if MIN_VERSION_bytestring(0,10,4)+ , fromShortByteString -- :: T.ByteString -> Builder+#endif -- * Flushing the buffer state , flush @@ -37,21 +39,236 @@ , putWord16be -- :: Word16 -> Builder , putWord32be -- :: Word32 -> Builder , putWord64be -- :: Word64 -> Builder+ , putInt16be -- :: Int16 -> Builder+ , putInt32be -- :: Int32 -> Builder+ , putInt64be -- :: Int64 -> Builder -- ** Little-endian writes , putWord16le -- :: Word16 -> Builder , putWord32le -- :: Word32 -> Builder , putWord64le -- :: Word64 -> Builder+ , putInt16le -- :: Int16 -> Builder+ , putInt32le -- :: Int32 -> Builder+ , putInt64le -- :: Int64 -> Builder -- ** Host-endian, unaligned writes , putWordhost -- :: Word -> Builder , putWord16host -- :: Word16 -> Builder , putWord32host -- :: Word32 -> Builder , putWord64host -- :: Word64 -> Builder+ , putInthost -- :: Int -> Builder+ , putInt16host -- :: Int16 -> Builder+ , putInt32host -- :: Int32 -> Builder+ , putInt64host -- :: Int64 -> Builder -- ** Unicode , putCharUtf8+ , putStringUtf8+ ) where - ) where+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L -import Data.Binary.Builder.Base+#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 )+import Data.ByteString.Builder.Extra ( flush )+import Data.Monoid+import Data.Word+import Data.Int+import Prelude -- Silence AMP warning.++------------------------------------------------------------------------++-- | /O(1)./ The empty Builder, satisfying+--+-- * @'toLazyByteString' 'empty' = 'L.empty'@+--+empty :: Builder+empty = mempty+{-# INLINE empty #-}++-- | /O(1)./ A Builder taking a single byte, satisfying+--+-- * @'toLazyByteString' ('singleton' b) = 'L.singleton' b@+--+singleton :: Word8 -> Builder+singleton = B.word8+{-# INLINE singleton #-}++------------------------------------------------------------------------++-- | /O(1)./ The concatenation of two Builders, an associative operation+-- with identity 'empty', satisfying+--+-- * @'toLazyByteString' ('append' x y) = 'L.append' ('toLazyByteString' x) ('toLazyByteString' y)@+--+append :: Builder -> Builder -> Builder+append = mappend+{-# INLINE append #-}++-- | /O(1)./ A Builder taking a 'S.ByteString', satisfying+--+-- * @'toLazyByteString' ('fromByteString' bs) = 'L.fromChunks' [bs]@+--+fromByteString :: S.ByteString -> Builder+fromByteString = B.byteString+{-# INLINE fromByteString #-}++-- | /O(1)./ A Builder taking a lazy 'L.ByteString', satisfying+--+-- * @'toLazyByteString' ('fromLazyByteString' bs) = bs@+--+fromLazyByteString :: L.ByteString -> Builder+fromLazyByteString = B.lazyByteString+{-# INLINE fromLazyByteString #-}++#if MIN_VERSION_bytestring(0,10,4)+-- | /O(n)./ A builder taking 'T.ShortByteString' and copy it to a Builder,+-- satisfying+--+-- * @'toLazyByteString' ('fromShortByteString' bs) = 'L.fromChunks' ['T.fromShort' bs]+fromShortByteString :: T.ShortByteString -> Builder+fromShortByteString = B.shortByteString+{-# INLINE fromShortByteString #-}+#endif++------------------------------------------------------------------------++-- | Write a Word16 in big endian format+putWord16be :: Word16 -> Builder+putWord16be = B.word16BE+{-# INLINE putWord16be #-}++-- | Write a Word16 in little endian format+putWord16le :: Word16 -> Builder+putWord16le = B.word16LE+{-# INLINE putWord16le #-}++-- | Write a Word32 in big endian format+putWord32be :: Word32 -> Builder+putWord32be = B.word32BE+{-# INLINE putWord32be #-}++-- | Write a Word32 in little endian format+putWord32le :: Word32 -> Builder+putWord32le = B.word32LE+{-# INLINE putWord32le #-}++-- | Write a Word64 in big endian format+putWord64be :: Word64 -> Builder+putWord64be = B.word64BE+{-# INLINE putWord64be #-}++-- | Write a Word64 in little endian format+putWord64le :: Word64 -> Builder+putWord64le = B.word64LE+{-# INLINE putWord64le #-}++-- | Write a Int16 in big endian format+putInt16be :: Int16 -> Builder+putInt16be = B.int16BE+{-# INLINE putInt16be #-}++-- | Write a Int16 in little endian format+putInt16le :: Int16 -> Builder+putInt16le = B.int16LE+{-# INLINE putInt16le #-}++-- | Write a Int32 in big endian format+putInt32be :: Int32 -> Builder+putInt32be = B.int32BE+{-# INLINE putInt32be #-}++-- | Write a Int32 in little endian format+putInt32le :: Int32 -> Builder+putInt32le = B.int32LE+{-# INLINE putInt32le #-}++-- | Write a Int64 in big endian format+putInt64be :: Int64 -> Builder+putInt64be = B.int64BE++-- | Write a Int64 in little endian format+putInt64le :: Int64 -> Builder+putInt64le = B.int64LE+++------------------------------------------------------------------------+-- Unaligned, word size ops++-- | /O(1)./ A Builder taking a single native machine word. The word is+-- written in host order, host endian form, for the machine you're on.+-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine,+-- 4 bytes. Values written this way are not portable to+-- different endian or word sized machines, without conversion.+--+putWordhost :: Word -> Builder+putWordhost = Prim.primFixed Prim.wordHost+{-# INLINE putWordhost #-}++-- | Write a Word16 in native host order and host endianness.+-- 2 bytes will be written, unaligned.+putWord16host :: Word16 -> Builder+putWord16host = Prim.primFixed Prim.word16Host+{-# INLINE putWord16host #-}++-- | Write a Word32 in native host order and host endianness.+-- 4 bytes will be written, unaligned.+putWord32host :: Word32 -> Builder+putWord32host = Prim.primFixed Prim.word32Host+{-# INLINE putWord32host #-}++-- | Write a Word64 in native host order.+-- On a 32 bit machine we write two host order Word32s, in big endian form.+-- 8 bytes will be written, unaligned.+putWord64host :: Word64 -> Builder+putWord64host = Prim.primFixed Prim.word64Host+{-# INLINE putWord64host #-}++-- | /O(1)./ A Builder taking a single native machine word. The word is+-- written in host order, host endian form, for the machine you're on.+-- On a 64 bit machine the Int is an 8 byte value, on a 32 bit machine,+-- 4 bytes. Values written this way are not portable to+-- different endian or word sized machines, without conversion.+--+putInthost :: Int -> Builder+putInthost = Prim.primFixed Prim.intHost+{-# INLINE putInthost #-}++-- | Write a Int16 in native host order and host endianness.+-- 2 bytes will be written, unaligned.+putInt16host :: Int16 -> Builder+putInt16host = Prim.primFixed Prim.int16Host+{-# INLINE putInt16host #-}++-- | Write a Int32 in native host order and host endianness.+-- 4 bytes will be written, unaligned.+putInt32host :: Int32 -> Builder+putInt32host = Prim.primFixed Prim.int32Host+{-# INLINE putInt32host #-}++-- | Write a Int64 in native host order.+-- On a 32 bit machine we write two host order Int32s, in big endian form.+-- 8 bytes will be written, unaligned.+putInt64host :: Int64 -> Builder+putInt64host = Prim.primFixed Prim.int64Host+{-# INLINE putInt64host #-}+++------------------------------------------------------------------------+-- Unicode++-- | Write a character using UTF-8 encoding.+putCharUtf8 :: Char -> Builder+putCharUtf8 = Prim.primBounded Prim.charUtf8+{-# INLINE putCharUtf8 #-}++-- | Write a String using UTF-8 encoding.+putStringUtf8 :: String -> Builder+putStringUtf8 = Prim.primMapListBounded Prim.charUtf8+{-# INLINE putStringUtf8 #-}
− src/Data/Binary/Builder/Base.hs
@@ -1,513 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, MagicHash #-}-#if __GLASGOW_HASKELL__ >= 701-{-# LANGUAGE Trustworthy #-}-#endif---------------------------------------------------------------------------------- |--- Module : Data.Binary.Builder.Base--- Copyright : Lennart Kolmodin, Ross Paterson--- License : BSD3-style (see LICENSE)------ Maintainer : Lennart Kolmodin <kolmodin@gmail.com>--- Stability : experimental--- Portability : portable to Hugs and GHC------ A module exporting types and functions that are shared by--- 'Data.Binary.Builder' and 'Data.Binary.Builder.Internal'.-----------------------------------------------------------------------------------#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)-#include "MachDeps.h"-#endif--module Data.Binary.Builder.Base (- -- * The Builder type- Builder- , toLazyByteString-- -- * Constructing Builders- , empty- , singleton- , append- , fromByteString -- :: S.ByteString -> Builder- , fromLazyByteString -- :: L.ByteString -> Builder-- -- * Flushing the buffer state- , flush-- -- * Derived Builders- -- ** Big-endian writes- , putWord16be -- :: Word16 -> Builder- , putWord32be -- :: Word32 -> Builder- , putWord64be -- :: Word64 -> Builder-- -- ** Little-endian writes- , putWord16le -- :: Word16 -> Builder- , putWord32le -- :: Word32 -> Builder- , putWord64le -- :: Word64 -> Builder-- -- ** Host-endian, unaligned writes- , putWordhost -- :: Word -> Builder- , putWord16host -- :: Word16 -> Builder- , putWord32host -- :: Word32 -> Builder- , putWord64host -- :: Word64 -> Builder-- -- ** Unicode- , putCharUtf8-- -- * Low-level construction of Builders- , writeN- , writeAtMost- ) where--import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import Data.Monoid-import Data.Word-import Foreign--import System.IO.Unsafe as IO ( unsafePerformIO )--#ifdef BYTESTRING_IN_BASE-import Data.ByteString.Base (inlinePerformIO)-import qualified Data.ByteString.Base as S-import qualified Data.ByteString.Lazy.Base as L-#else-import Data.ByteString.Internal (inlinePerformIO)-import qualified Data.ByteString.Internal as S-import qualified Data.ByteString.Lazy.Internal as L-#endif--#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)-import GHC.Base (ord,Int(..),uncheckedShiftRL#)-import GHC.Word (Word32(..),Word16(..),Word64(..))-# if WORD_SIZE_IN_BITS < 64-import GHC.Word (uncheckedShiftRL64#)-# endif-#endif-import Prelude -- Silence AMP warning.------------------------------------------------------------------------------ | A 'Builder' is an efficient way to build lazy 'L.ByteString's.--- There are several functions for constructing 'Builder's, but only one--- to inspect them: to extract any data, you have to turn them into lazy--- 'L.ByteString's using 'toLazyByteString'.------ Internally, a 'Builder' constructs a lazy 'L.Bytestring' by filling byte--- arrays piece by piece. As each buffer is filled, it is \'popped\'--- off, to become a new chunk of the resulting lazy 'L.ByteString'.--- All this is hidden from the user of the 'Builder'.--newtype Builder = Builder {- runBuilder :: (Buffer -> IO L.ByteString)- -> Buffer- -> IO L.ByteString- }--instance Monoid Builder where- mempty = empty- {-# INLINE mempty #-}- mappend = append- {-# INLINE mappend #-}- mconcat = foldr mappend mempty- {-# INLINE mconcat #-}------------------------------------------------------------------------------ | /O(1)./ The empty Builder, satisfying------ * @'toLazyByteString' 'empty' = 'L.empty'@----empty :: Builder-empty = Builder (\ k b -> k b)-{-# INLINE empty #-}---- | /O(1)./ A Builder taking a single byte, satisfying------ * @'toLazyByteString' ('singleton' b) = 'L.singleton' b@----singleton :: Word8 -> Builder-singleton = writeN 1 . flip poke-{-# INLINE singleton #-}------------------------------------------------------------------------------ | /O(1)./ The concatenation of two Builders, an associative operation--- with identity 'empty', satisfying------ * @'toLazyByteString' ('append' x y) = 'L.append' ('toLazyByteString' x) ('toLazyByteString' y)@----append :: Builder -> Builder -> Builder-append (Builder f) (Builder g) = Builder (f . g)-{-# INLINE [0] append #-}---- | /O(1)./ A Builder taking a 'S.ByteString', satisfying------ * @'toLazyByteString' ('fromByteString' bs) = 'L.fromChunks' [bs]@----fromByteString :: S.ByteString -> Builder-fromByteString bs- | S.null bs = empty- | otherwise = flush `append` mapBuilder (L.Chunk bs)-{-# INLINE fromByteString #-}---- | /O(1)./ A Builder taking a lazy 'L.ByteString', satisfying------ * @'toLazyByteString' ('fromLazyByteString' bs) = bs@----fromLazyByteString :: L.ByteString -> Builder-fromLazyByteString bss = flush `append` mapBuilder (bss `L.append`)-{-# INLINE fromLazyByteString #-}------------------------------------------------------------------------------ Our internal buffer type-data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8)- {-# UNPACK #-} !Int -- offset- {-# UNPACK #-} !Int -- used bytes- {-# UNPACK #-} !Int -- length left------------------------------------------------------------------------------ | /O(n)./ Extract a lazy 'L.ByteString' from a 'Builder'.--- The construction work takes place if and when the relevant part of--- the lazy 'L.ByteString' is demanded.----toLazyByteString :: Builder -> L.ByteString-toLazyByteString m = IO.unsafePerformIO $ do- buf <- newBuffer defaultSize- runBuilder (m `append` flush) (const (return L.Empty)) buf-{-# INLINE toLazyByteString #-}---- | /O(1)./ Pop the 'S.ByteString' we have constructed so far, if any,--- yielding a new chunk in the result lazy 'L.ByteString'.-flush :: Builder-flush = Builder $ \ k buf@(Buffer p o u l) ->- if u == 0 -- Invariant (from Data.ByteString.Lazy)- then k buf- else let !b = Buffer p (o+u) 0 l- !bs = S.PS p o u- in return $! L.Chunk bs (inlinePerformIO (k b))--------------------------------------------------------------------------------- copied from Data.ByteString.Lazy----defaultSize :: Int-defaultSize = 32 * k - overhead- where k = 1024- overhead = 2 * sizeOf (undefined :: Int)------------------------------------------------------------------------------ | Sequence an IO operation on the buffer-withBuffer :: (Buffer -> IO Buffer) -> Builder-withBuffer f = Builder $ \ k buf -> f buf >>= k-{-# INLINE withBuffer #-}---- | Get the size of the buffer-withSize :: (Int -> Builder) -> Builder-withSize f = Builder $ \ k buf@(Buffer _ _ _ l) ->- runBuilder (f l) k buf---- | Map the resulting list of bytestrings.-mapBuilder :: (L.ByteString -> L.ByteString) -> Builder-mapBuilder f = Builder (fmap f .)------------------------------------------------------------------------------ | Ensure that there are at least @n@ many bytes available.-ensureFree :: Int -> Builder-ensureFree n = n `seq` withSize $ \ l ->- if n <= l then empty else- flush `append` withBuffer (const (newBuffer (max n defaultSize)))-{-# INLINE [0] ensureFree #-}---- | Ensure that @n@ bytes are available, and then use @f@ to write at--- most @n@ bytes into memory. @f@ must return the actual number of--- bytes written.-writeAtMost :: Int -> (Ptr Word8 -> IO Int) -> Builder-writeAtMost n f = ensureFree n `append` withBuffer (writeBuffer f)-{-# INLINE [0] writeAtMost #-}---- | Ensure that @n@ bytes are available, and then use @f@ to write--- exactly @n@ bytes into memory.-writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder-writeN n f = writeAtMost n (\ p -> f p >> return n)-{-# INLINE writeN #-}--writeBuffer :: (Ptr Word8 -> IO Int) -> Buffer -> IO Buffer-writeBuffer f (Buffer fp o u l) = do- n <- withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))- return $! Buffer fp o (u+n) (l-n)-{-# INLINE writeBuffer #-}--newBuffer :: Int -> IO Buffer-newBuffer size = do- fp <- S.mallocByteString size- return $! Buffer fp 0 0 size-{-# INLINE newBuffer #-}--------------------------------------------------------------------------------- We rely on the fromIntegral to do the right masking for us.--- The inlining here is critical, and can be worth 4x performance------- | Write a Word16 in big endian format-putWord16be :: Word16 -> Builder-putWord16be w = writeN 2 $ \p -> do- poke p (fromIntegral (shiftr_w16 w 8) :: Word8)- poke (p `plusPtr` 1) (fromIntegral (w) :: Word8)-{-# INLINE putWord16be #-}---- | Write a Word16 in little endian format-putWord16le :: Word16 -> Builder-putWord16le w = writeN 2 $ \p -> do- poke p (fromIntegral (w) :: Word8)- poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8)-{-# INLINE putWord16le #-}---- putWord16le w16 = writeN 2 (\p -> poke (castPtr p) w16)---- | Write a Word32 in big endian format-putWord32be :: Word32 -> Builder-putWord32be w = writeN 4 $ \p -> do- poke p (fromIntegral (shiftr_w32 w 24) :: Word8)- poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8)- poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8)- poke (p `plusPtr` 3) (fromIntegral (w) :: Word8)-{-# INLINE putWord32be #-}------- a data type to tag Put/Check. writes construct these which are then--- inlined and flattened. matching Checks will be more robust with rules.------- | Write a Word32 in little endian format-putWord32le :: Word32 -> Builder-putWord32le w = writeN 4 $ \p -> do- poke p (fromIntegral (w) :: Word8)- poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 8) :: Word8)- poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 16) :: Word8)- poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 w 24) :: Word8)-{-# INLINE putWord32le #-}---- on a little endian machine:--- putWord32le w32 = writeN 4 (\p -> poke (castPtr p) w32)---- | Write a Word64 in big endian format-putWord64be :: Word64 -> Builder-#if WORD_SIZE_IN_BITS < 64------ To avoid expensive 64 bit shifts on 32 bit machines, we cast to--- Word32, and write that----putWord64be w =- let a = fromIntegral (shiftr_w64 w 32) :: Word32- b = fromIntegral w :: Word32- in writeN 8 $ \p -> do- poke p (fromIntegral (shiftr_w32 a 24) :: Word8)- poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8)- poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 8) :: Word8)- poke (p `plusPtr` 3) (fromIntegral (a) :: Word8)- poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8)- poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8)- poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 8) :: Word8)- poke (p `plusPtr` 7) (fromIntegral (b) :: Word8)-#else-putWord64be w = writeN 8 $ \p -> do- poke p (fromIntegral (shiftr_w64 w 56) :: Word8)- poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8)- poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8)- poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 32) :: Word8)- poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 24) :: Word8)- poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 16) :: Word8)- poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 8) :: Word8)- poke (p `plusPtr` 7) (fromIntegral (w) :: Word8)-#endif-{-# INLINE putWord64be #-}---- | Write a Word64 in little endian format-putWord64le :: Word64 -> Builder--#if WORD_SIZE_IN_BITS < 64-putWord64le w =- let b = fromIntegral (shiftr_w64 w 32) :: Word32- a = fromIntegral w :: Word32- in writeN 8 $ \p -> do- poke (p) (fromIntegral (a) :: Word8)- poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 8) :: Word8)- poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 16) :: Word8)- poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 a 24) :: Word8)- poke (p `plusPtr` 4) (fromIntegral (b) :: Word8)- poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 8) :: Word8)- poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8)- poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8)-#else-putWord64le w = writeN 8 $ \p -> do- poke p (fromIntegral (w) :: Word8)- poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 8) :: Word8)- poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 16) :: Word8)- poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 24) :: Word8)- poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 32) :: Word8)- poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 40) :: Word8)- poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 48) :: Word8)- poke (p `plusPtr` 7) (fromIntegral (shiftr_w64 w 56) :: Word8)-#endif-{-# INLINE putWord64le #-}---- on a little endian machine:--- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64)----------------------------------------------------------------------------- Unaligned, word size ops---- | /O(1)./ A Builder taking a single native machine word. The word is--- written in host order, host endian form, for the machine you're on.--- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine,--- 4 bytes. Values written this way are not portable to--- different endian or word sized machines, without conversion.----putWordhost :: Word -> Builder-putWordhost w =- writeN (sizeOf (undefined :: Word)) (\p -> poke (castPtr p) w)-{-# INLINE putWordhost #-}---- | Write a Word16 in native host order and host endianness.--- 2 bytes will be written, unaligned.-putWord16host :: Word16 -> Builder-putWord16host w16 =- writeN (sizeOf (undefined :: Word16)) (\p -> poke (castPtr p) w16)-{-# INLINE putWord16host #-}---- | Write a Word32 in native host order and host endianness.--- 4 bytes will be written, unaligned.-putWord32host :: Word32 -> Builder-putWord32host w32 =- writeN (sizeOf (undefined :: Word32)) (\p -> poke (castPtr p) w32)-{-# INLINE putWord32host #-}---- | Write a Word64 in native host order.--- On a 32 bit machine we write two host order Word32s, in big endian form.--- 8 bytes will be written, unaligned.-putWord64host :: Word64 -> Builder-putWord64host w =- writeN (sizeOf (undefined :: Word64)) (\p -> poke (castPtr p) w)-{-# INLINE putWord64host #-}----------------------------------------------------------------------------- Unicode---- Code lifted from the text package by Bryan O'Sullivan.---- | Write a character using UTF-8 encoding.-putCharUtf8 :: Char -> Builder-putCharUtf8 x = writeAtMost 4 $ \ p -> case undefined of- _ | n <= 0x7F -> poke p c >> return 1- | n <= 0x07FF -> do- poke p a2- poke (p `plusPtr` 1) b2- return 2- | n <= 0xFFFF -> do- poke p a3- poke (p `plusPtr` 1) b3- poke (p `plusPtr` 2) c3- return 3- | otherwise -> do- poke p a4- poke (p `plusPtr` 1) b4- poke (p `plusPtr` 2) c4- poke (p `plusPtr` 3) d4- return 4- where- n = ord x- c = fromIntegral n- (a2,b2) = ord2 x- (a3,b3,c3) = ord3 x- (a4,b4,c4,d4) = ord4 x--ord2 :: Char -> (Word8,Word8)-ord2 c = (x1,x2)- where- n = ord c- x1 = fromIntegral $ (n `shiftR` 6) + 0xC0- x2 = fromIntegral $ (n .&. 0x3F) + 0x80--ord3 :: Char -> (Word8,Word8,Word8)-ord3 c = (x1,x2,x3)- where- n = ord c- x1 = fromIntegral $ (n `shiftR` 12) + 0xE0- x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80- x3 = fromIntegral $ (n .&. 0x3F) + 0x80--ord4 :: Char -> (Word8,Word8,Word8,Word8)-ord4 c = (x1,x2,x3,x4)- where- n = ord c- x1 = fromIntegral $ (n `shiftR` 18) + 0xF0- x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80- x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80- x4 = fromIntegral $ (n .&. 0x3F) + 0x80----------------------------------------------------------------------------- Unchecked shifts--{-# INLINE shiftr_w16 #-}-shiftr_w16 :: Word16 -> Int -> Word16-{-# INLINE shiftr_w32 #-}-shiftr_w32 :: Word32 -> Int -> Word32-{-# INLINE shiftr_w64 #-}-shiftr_w64 :: Word64 -> Int -> Word64--#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)-shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i)-shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i)--# if WORD_SIZE_IN_BITS < 64-shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)-# else-shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)-# endif--#else-shiftr_w16 = shiftR-shiftr_w32 = shiftR-shiftr_w64 = shiftR-#endif----------------------------------------------------------------------------- Some nice rules for Builder--#if __GLASGOW_HASKELL__ >= 700--- In versions of GHC prior to 7.0 these rules would make GHC believe--- that 'writeN' and 'ensureFree' are recursive and the rules wouldn't--- fire.-{-# RULES--"append/writeAtMost" forall a b (f::Ptr Word8 -> IO Int)- (g::Ptr Word8 -> IO Int) ws.- append (writeAtMost a f) (append (writeAtMost b g) ws) =- append (writeAtMost (a+b) (\p -> f p >>= \n ->- g (p `plusPtr` n) >>= \m ->- let s = n+m in s `seq` return s)) ws--"writeAtMost/writeAtMost" forall a b (f::Ptr Word8 -> IO Int)- (g::Ptr Word8 -> IO Int).- append (writeAtMost a f) (writeAtMost b g) =- writeAtMost (a+b) (\p -> f p >>= \n ->- g (p `plusPtr` n) >>= \m ->- let s = n+m in s `seq` return s)--"ensureFree/ensureFree" forall a b .- append (ensureFree a) (ensureFree b) = ensureFree (max a b)--"flush/flush"- append flush flush = flush #-}-#endif
− src/Data/Binary/Builder/Internal.hs
@@ -1,28 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 701-{-# LANGUAGE Safe #-}-#endif--------------------------------------------------------------------------------- |--- Module : Data.Binary.Builder.Internal--- Copyright : Lennart Kolmodin, Ross Paterson--- License : BSD3-style (see LICENSE)------ Maintainer : Lennart Kolmodin <kolmodin@gmail.com>--- Stability : experimental--- Portability : portable to Hugs and GHC------ A module containing semi-public 'Builder' internals that exposes--- low level construction functions. Modules which extend the--- 'Builder' system will need to use this module while ideally most--- users will be able to make do with the public interface modules.-----------------------------------------------------------------------------------module Data.Binary.Builder.Internal (- -- * Low-level construction of Builders- writeN- , writeAtMost- ) where--import Data.Binary.Builder.Base
src/Data/Binary/Class.hs view
@@ -1,17 +1,21 @@ {-# 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) #define HAS_NATURAL+#define HAS_VOID #endif -#if __GLASGOW_HASKELL__ >= 704-#define HAS_GHC_FINGERPRINT+#if MIN_VERSION_base(4,7,0)+#define HAS_FIXED_CONSTRUCTOR #endif -----------------------------------------------------------------------------@@ -33,30 +37,55 @@ -- * The Binary class Binary(..) -#ifdef GENERICS -- * Support for generics- , GBinary(..)-#endif+ , GBinaryGet(..)+ , GBinaryPut(..) ) where import Data.Word import Data.Bits import Data.Int+import Data.Complex (Complex(..))+#ifdef HAS_VOID+import Data.Void+#endif import Data.Binary.Put import Data.Binary.Get +#if ! MIN_VERSION_base(4,8,0)+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) import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Builder.Prim as Prim -import Data.Char (ord)-import Data.List (unfoldr)+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+#endif import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.IntMap as IntMap@@ -67,32 +96,35 @@ import Data.Array.Unboxed -#ifdef GENERICS import GHC.Generics-#endif #ifdef HAS_NATURAL import Numeric.Natural #endif++import qualified Data.Fixed as Fixed+ -- -- 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-class GBinary f where+-- 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'.+-- See also: https://ghc.haskell.org/trac/ghc/ticket/9630+class GBinaryPut f where gput :: f t -> Put++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@@ -117,32 +149,59 @@ -- | Decode a value in the Get monad get :: Get t -#ifdef GENERICS- default put :: (Generic t, GBinary (Rep t)) => t -> Put+ -- | Encode a list of values in the Put monad.+ -- The default implementation may be overridden to be more efficient+ -- but must still have the same encoding format.+ putList :: [t] -> Put+ putList = defaultPutList++ default put :: (Generic t, GBinaryPut (Rep t)) => t -> Put put = gput . from - default get :: (Generic t, GBinary (Rep t)) => Get t+ default get :: (Generic t, GBinaryGet (Rep t)) => Get t get = to `fmap` gget-#endif +{-# INLINE defaultPutList #-}+defaultPutList :: Binary a => [a] -> Put+defaultPutList xs = put (length xs) <> mapM_ put xs+ ------------------------------------------------------------------------ -- Simple instances +#ifdef HAS_VOID+-- Void never gets written nor reconstructed since it's impossible to have a+-- value of that type++-- | /Since: 0.8.0.0/+instance Binary Void where+ put = absurd+ get = mzero+#endif+ -- The () type need never be written to disk: values of singleton type -- can be reconstructed from the type alone instance Binary () where- put () = return ()+ put () = mempty get = return () -- Bools are encoded as a byte in the range 0 .. 1 instance Binary Bool where put = putWord8 . fromIntegral . fromEnum- get = liftM (toEnum . fromIntegral) getWord8+ get = getWord8 >>= toBool+ where+ toBool 0 = return False+ toBool 1 = return True+ toBool c = fail ("Could not map value " ++ show c ++ " to Bool") -- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2 instance Binary Ordering where put = putWord8 . fromIntegral . fromEnum- get = liftM (toEnum . fromIntegral) getWord8+ get = getWord8 >>= toOrd+ where+ toOrd 0 = return LT+ toOrd 1 = return EQ+ toOrd 2 = return GT+ toOrd c = fail ("Could not map value " ++ show c ++ " to Ordering") ------------------------------------------------------------------------ -- Words and Ints@@ -150,54 +209,94 @@ -- Words8s are written as bytes instance Binary Word8 where put = putWord8+ {-# INLINE putList #-}+ putList xs =+ put (length xs)+ <> putBuilder (Prim.primMapListFixed Prim.word8 xs) get = getWord8 -- Words16s are written as 2 bytes in big-endian (network) order instance Binary Word16 where put = putWord16be+ {-# INLINE putList #-}+ putList xs =+ put (length xs)+ <> putBuilder (Prim.primMapListFixed Prim.word16BE xs) get = getWord16be -- Words32s are written as 4 bytes in big-endian (network) order instance Binary Word32 where put = putWord32be+ {-# INLINE putList #-}+ putList xs =+ put (length xs)+ <> putBuilder (Prim.primMapListFixed Prim.word32BE xs) get = getWord32be -- Words64s are written as 8 bytes in big-endian (network) order instance Binary Word64 where put = putWord64be+ {-# INLINE putList #-}+ putList xs =+ put (length xs)+ <> putBuilder (Prim.primMapListFixed Prim.word64BE xs) get = getWord64be -- Int8s are written as a single byte. instance Binary Int8 where- put i = put (fromIntegral i :: Word8)- get = liftM fromIntegral (get :: Get Word8)+ put = putInt8+ {-# INLINE putList #-}+ putList xs =+ put (length xs)+ <> putBuilder (Prim.primMapListFixed Prim.int8 xs)+ get = getInt8 -- Int16s are written as a 2 bytes in big endian format instance Binary Int16 where- put i = put (fromIntegral i :: Word16)- get = liftM fromIntegral (get :: Get Word16)+ put = putInt16be+ {-# INLINE putList #-}+ putList xs =+ put (length xs)+ <> putBuilder (Prim.primMapListFixed Prim.int16BE xs)+ get = getInt16be -- Int32s are written as a 4 bytes in big endian format instance Binary Int32 where- put i = put (fromIntegral i :: Word32)- get = liftM fromIntegral (get :: Get Word32)+ put = putInt32be+ {-# INLINE putList #-}+ putList xs =+ put (length xs)+ <> putBuilder (Prim.primMapListFixed Prim.int32BE xs)+ get = getInt32be -- Int64s are written as a 8 bytes in big endian format instance Binary Int64 where- put i = put (fromIntegral i :: Word64)- get = liftM fromIntegral (get :: Get Word64)+ put = putInt64be+ {-# INLINE putList #-}+ putList xs =+ put (length xs)+ <> putBuilder (Prim.primMapListFixed Prim.int64BE xs)+ get = getInt64be ------------------------------------------------------------------------ -- Words are are written as Word64s, that is, 8 bytes in big endian format instance Binary Word where- put i = put (fromIntegral i :: Word64)- get = liftM fromIntegral (get :: Get Word64)+ put = putWord64be . fromIntegral+ {-# INLINE putList #-}+ putList xs =+ put (length xs)+ <> putBuilder (Prim.primMapListFixed Prim.word64BE (map fromIntegral xs))+ get = liftM fromIntegral getWord64be -- Ints are are written as Int64s, that is, 8 bytes in big endian format instance Binary Int where- put i = put (fromIntegral i :: Int64)- get = liftM fromIntegral (get :: Get Int64)+ put = putInt64be . fromIntegral+ {-# INLINE putList #-}+ putList xs =+ put (length xs)+ <> putBuilder (Prim.primMapListFixed Prim.int64BE (map fromIntegral xs))+ get = liftM fromIntegral getInt64be ------------------------------------------------------------------------ --@@ -215,17 +314,16 @@ instance Binary Integer where {-# INLINE put #-}- put n | n >= lo && n <= hi = do- putWord8 0- put (fromIntegral n :: SmallInt) -- fast path+ put n | n >= lo && n <= hi =+ putBuilder (Prim.primFixed (Prim.word8 Prim.>*< Prim.int32BE) (0, fromIntegral n)) where lo = fromIntegral (minBound :: SmallInt) :: Integer hi = fromIntegral (maxBound :: SmallInt) :: Integer - put n = do+ put n = putWord8 1- put sign- put (unroll (abs n)) -- unroll the bytes+ <> put sign+ <> put (unroll (abs n)) -- unroll the bytes where sign = fromIntegral (signum n) :: Word8 @@ -239,35 +337,48 @@ let v = roll bytes return $! if sign == (1 :: Word8) then v else - v +-- | /Since: 0.8.0.0/+#ifdef HAS_FIXED_CONSTRUCTOR+instance Binary (Fixed.Fixed a) where+ put (Fixed.MkFixed a) = put a+ get = Fixed.MkFixed `liftM` get+#else+instance forall a. Fixed.HasResolution a => Binary (Fixed.Fixed a) where+ -- Using undefined :: Maybe a as a proxy, as Data.Proxy is introduced only in base-4.7+ put x = put (truncate (x * fromInteger (Fixed.resolution (undefined :: Maybe a))) :: Integer)+ get = (\x -> fromInteger x / fromInteger (Fixed.resolution (undefined :: Maybe a))) `liftM` get+#endif+ -- -- Fold and unfold an Integer to and from a list of its bytes ---unroll :: (Integral a, Num a, Bits a) => a -> [Word8]+unroll :: (Integral a, Bits a) => a -> [Word8] unroll = unfoldr step where step 0 = Nothing step i = Just (fromIntegral i, i `shiftR` 8) -roll :: (Integral a, Num a, Bits a) => [Word8] -> a-roll = foldr unstep 0+roll :: (Integral a, Bits a) => [Word8] -> a+roll = foldl' unstep 0 . reverse where- unstep b a = a `shiftL` 8 .|. fromIntegral b+ unstep a b = a `shiftL` 8 .|. fromIntegral b #ifdef HAS_NATURAL -- Fixed-size type for a subset of Natural type NaturalWord = Word64 +-- | /Since: 0.7.3.0/ instance Binary Natural where {-# INLINE put #-}- put n | n <= hi = do+ put n | n <= hi = putWord8 0- put (fromIntegral n :: NaturalWord) -- fast path+ <> put (fromIntegral n :: NaturalWord) -- fast path where hi = fromIntegral (maxBound :: NaturalWord) :: Natural - put n = do+ put n = putWord8 1- put (unroll (abs n)) -- unroll the bytes+ <> put (unroll (abs n)) -- unroll the bytes {-# INLINE get #-} get = do@@ -345,32 +456,21 @@ -} instance (Binary a,Integral a) => Binary (R.Ratio a) where- put r = put (R.numerator r) >> put (R.denominator r)+ put r = put (R.numerator r) <> put (R.denominator r) get = liftM2 (R.%) get get +instance Binary a => Binary (Complex a) where+ {-# INLINE put #-}+ put (r :+ i) = put (r, i)+ {-# INLINE get #-}+ get = (\(r,i) -> r :+ i) <$> get+ ------------------------------------------------------------------------ -- Char is serialised as UTF-8 instance Binary Char where- put a | c <= 0x7f = put (fromIntegral c :: Word8)- | c <= 0x7ff = do put (0xc0 .|. y)- put (0x80 .|. z)- | c <= 0xffff = do put (0xe0 .|. x)- put (0x80 .|. y)- put (0x80 .|. z)- | c <= 0x10ffff = do put (0xf0 .|. w)- put (0x80 .|. x)- put (0x80 .|. y)- put (0x80 .|. z)- | otherwise = error "Not a valid Unicode code point"- where- c = ord a- z, y, x, w :: Word8- z = fromIntegral (c .&. 0x3f)- y = fromIntegral (shiftR c 6 .&. 0x3f)- x = fromIntegral (shiftR c 12 .&. 0x3f)- w = fromIntegral (shiftR c 18 .&. 0x7)-+ put = putCharUtf8+ putList str = put (length str) <> putStringUtf8 str get = do let getByte = liftM (fromIntegral :: Word8 -> Int) get shiftL6 = flip shiftL 6 :: Int -> Int@@ -401,19 +501,27 @@ -- Instances for the first few tuples instance (Binary a, Binary b) => Binary (a,b) where- put (a,b) = put a >> put b+ {-# 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- put (a,b,c) = put a >> put b >> put c+ {-# 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- put (a,b,c,d) = put a >> put b >> put c >> put d+ {-# 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- put (a,b,c,d,e) = put a >> put b >> put c >> put d >> put e+ {-# 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 --@@ -422,39 +530,55 @@ 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 l = put (length l) >> mapM_ put l- get = do n <- get :: Get Int- getMany n+ put = putList+ get = do n <- get :: Get Int+ getMany n -- | 'getMany n' get 'n' elements in order, without blowing the stack. getMany :: Binary a => Int -> Get [a]@@ -469,7 +593,7 @@ instance (Binary a) => Binary (Maybe a) where put Nothing = putWord8 0- put (Just x) = putWord8 1 >> put x+ put (Just x) = putWord8 1 <> put x get = do w <- getWord8 case w of@@ -477,8 +601,8 @@ _ -> liftM Just get instance (Binary a, Binary b) => Binary (Either a b) where- put (Left a) = putWord8 0 >> put a- put (Right b) = putWord8 1 >> put b+ put (Left a) = putWord8 0 <> put a+ put (Right b) = putWord8 1 <> put b get = do w <- getWord8 case w of@@ -489,8 +613,8 @@ -- ByteStrings (have specially efficient instances) instance Binary B.ByteString where- put bs = do put (B.length bs)- putByteString bs+ put bs = put (B.length bs)+ <> putByteString bs get = get >>= getByteString --@@ -499,39 +623,46 @@ -- Requires 'flexible instances' -- instance Binary ByteString where- put bs = do put (fromIntegral (L.length bs) :: Int)- putLazyByteString bs+ put bs = put (fromIntegral (L.length bs) :: Int)+ <> putLazyByteString bs get = get >>= getLazyByteString ++#if MIN_VERSION_bytestring(0,10,4)+instance Binary BS.ShortByteString where+ put bs = put (BS.length bs)+ <> putShortByteString bs+ get = get >>= fmap BS.toShort . getByteString+#endif+ ------------------------------------------------------------------------ -- Maps and Sets instance (Binary a) => Binary (Set.Set a) where- put s = put (Set.size s) >> mapM_ put (Set.toAscList s)+ put s = put (Set.size s) <> mapM_ put (Set.toAscList s) get = liftM Set.fromDistinctAscList get instance (Binary k, Binary e) => Binary (Map.Map k e) where- put m = put (Map.size m) >> mapM_ put (Map.toAscList m)+ put m = put (Map.size m) <> mapM_ put (Map.toAscList m) get = liftM Map.fromDistinctAscList get instance Binary IntSet.IntSet where- put s = put (IntSet.size s) >> mapM_ put (IntSet.toAscList s)+ put s = put (IntSet.size s) <> mapM_ put (IntSet.toAscList s) get = liftM IntSet.fromDistinctAscList get instance (Binary e) => Binary (IntMap.IntMap e) where- put m = put (IntMap.size m) >> mapM_ put (IntMap.toAscList m)+ put m = put (IntMap.size m) <> mapM_ put (IntMap.toAscList m) get = liftM IntMap.fromDistinctAscList get ------------------------------------------------------------------------ -- Queues and Sequences -#if __GLASGOW_HASKELL__ >= 606 -- -- This is valid Hugs, but you need the most recent Hugs -- instance (Binary e) => Binary (Seq.Seq e) where- put s = put (Seq.length s) >> Fold.mapM_ put s+ put s = put (Seq.length s) <> Fold.mapM_ put s get = do n <- get :: Get Int rep Seq.empty n get where rep xs 0 _ = return $! xs@@ -539,8 +670,6 @@ x <- g rep (xs Seq.|> x) (n-1) g -#endif- ------------------------------------------------------------------------ -- Floating point @@ -562,17 +691,17 @@ -- Trees instance (Binary e) => Binary (T.Tree e) where- put (T.Node r s) = put r >> put s+ put (T.Node r s) = put r <> put s get = liftM2 T.Node get get ------------------------------------------------------------------------ -- Arrays instance (Binary i, Ix i, Binary e) => Binary (Array i e) where- put a = do+ put a = put (bounds a)- put (rangeSize $ bounds a) -- write the length- mapM_ put (elems a) -- now the elems.+ <> put (rangeSize $ bounds a) -- write the length+ <> mapM_ put (elems a) -- now the elems. get = do bs <- get n <- get -- read the length@@ -583,10 +712,10 @@ -- The IArray UArray e constraint is non portable. Requires flexible instances -- instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where- put a = do+ put a = put (bounds a)- put (rangeSize $ bounds a) -- now write the length- mapM_ put (elems a)+ <> put (rangeSize $ bounds a) -- now write the length+ <> mapM_ put (elems a) get = do bs <- get n <- get@@ -596,13 +725,298 @@ ------------------------------------------------------------------------ -- Fingerprints -#ifdef HAS_GHC_FINGERPRINT+-- | /Since: 0.7.6.0/ instance Binary Fingerprint where- put (Fingerprint x1 x2) = do- put x1- put x2+ put (Fingerprint x1 x2) = put x1 <> put x2 get = do x1 <- get x2 <- get return $! Fingerprint x1 x2++------------------------------------------------------------------------+-- Version++-- | /Since: 0.8.0.0/+instance Binary Version where+ put (Version br tags) = put br <> put tags+ get = Version <$> get <*> get++------------------------------------------------------------------------+-- Data.Monoid datatypes++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Monoid.Dual a) where+ get = fmap Monoid.Dual get+ put = put . Monoid.getDual++-- | /Since: 0.8.4.0/+instance Binary Monoid.All where+ get = fmap Monoid.All get+ put = put . Monoid.getAll++-- | /Since: 0.8.4.0/+instance Binary Monoid.Any where+ get = fmap Monoid.Any get+ put = put . Monoid.getAny++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Monoid.Sum a) where+ get = fmap Monoid.Sum get+ put = put . Monoid.getSum++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Monoid.Product a) where+ get = fmap Monoid.Product get+ put = put . Monoid.getProduct++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Monoid.First a) where+ get = fmap Monoid.First get+ put = put . Monoid.getFirst++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Monoid.Last a) where+ get = fmap Monoid.Last get+ put = put . Monoid.getLast++#if MIN_VERSION_base(4,8,0)+-- | /Since: 0.8.4.0/+instance Binary (f a) => Binary (Monoid.Alt f a) where+ get = fmap Monoid.Alt get+ put = put . Monoid.getAlt #endif++#if MIN_VERSION_base(4,9,0)+------------------------------------------------------------------------+-- Data.Semigroup datatypes++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Semigroup.Min a) where+ get = fmap Semigroup.Min get+ put = put . Semigroup.getMin++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Semigroup.Max a) where+ get = fmap Semigroup.Max get+ put = put . Semigroup.getMax++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Semigroup.First a) where+ get = fmap Semigroup.First get+ put = put . Semigroup.getFirst++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Semigroup.Last a) where+ get = fmap Semigroup.Last get+ put = put . Semigroup.getLast++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Semigroup.Option a) where+ get = fmap Semigroup.Option get+ put = put . Semigroup.getOption++-- | /Since: 0.8.4.0/+instance Binary m => Binary (Semigroup.WrappedMonoid m) where+ get = fmap Semigroup.WrapMonoid get+ put = put . Semigroup.unwrapMonoid++-- | /Since: 0.8.4.0/+instance (Binary a, Binary b) => Binary (Semigroup.Arg a b) where+ get = liftM2 Semigroup.Arg get get+ put (Semigroup.Arg a b) = put a <> put b++------------------------------------------------------------------------+-- Non-empty lists++-- | /Since: 0.8.4.0/+instance Binary a => Binary (NE.NonEmpty a) where+ get = fmap NE.fromList get+ put = put . NE.toList+#endif++------------------------------------------------------------------------+-- Typeable/Reflection++#if MIN_VERSION_base(4,10,0)++-- $typeable-instances+--+-- 'Binary' instances for GHC's "Type.Reflection", "Data.Typeable", and+-- kind-system primitives are only provided with @base-4.10.0@ (shipped with GHC+-- 8.2.1). In prior GHC releases some of these instances were provided by+-- 'GHCi.TH.Binary' in the @ghci@ package.+--+-- These include instances for,+--+-- * 'VecCount'+-- * 'VecElem'+-- * 'RuntimeRep'+-- * 'KindRep'+-- * 'TypeLitSort'+-- * 'TyCon'+-- * 'TypeRep'+-- * 'SomeTypeRep' (also known as 'Data.Typeable.TypeRep')+--++-- | @since 0.8.5.0. See #typeable-instances#+instance Binary VecCount where+ put = putWord8 . fromIntegral . fromEnum+ get = toEnum . fromIntegral <$> getWord8++-- | @since 0.8.5.0. See #typeable-instances#+instance Binary VecElem where+ put = putWord8 . fromIntegral . fromEnum+ get = toEnum . fromIntegral <$> getWord8++-- | @since 0.8.5.0. See #typeable-instances#+instance Binary RuntimeRep where+ put (VecRep a b) = putWord8 0 >> put a >> put b+ put (TupleRep reps) = putWord8 1 >> put reps+ put (SumRep reps) = putWord8 2 >> put reps+ put LiftedRep = putWord8 3+ put UnliftedRep = putWord8 4+ put IntRep = putWord8 5+ put WordRep = putWord8 6+ put Int64Rep = putWord8 7+ put Word64Rep = putWord8 8+ put AddrRep = putWord8 9+ put FloatRep = putWord8 10+ put DoubleRep = putWord8 11++ get = do+ tag <- getWord8+ case tag of+ 0 -> VecRep <$> get <*> get+ 1 -> TupleRep <$> get+ 2 -> SumRep <$> get+ 3 -> pure LiftedRep+ 4 -> pure UnliftedRep+ 5 -> pure IntRep+ 6 -> pure WordRep+ 7 -> pure Int64Rep+ 8 -> pure Word64Rep+ 9 -> pure AddrRep+ 10 -> pure FloatRep+ 11 -> pure DoubleRep+ _ -> fail "GHCi.TH.Binary.putRuntimeRep: invalid tag"++-- | @since 0.8.5.0. See #typeable-instances#+instance Binary TyCon where+ put tc = do+ put (tyConPackage tc)+ put (tyConModule tc)+ put (tyConName tc)+ put (tyConKindArgs tc)+ put (tyConKindRep tc)+ get = mkTyCon <$> get <*> get <*> get <*> get <*> get++-- | @since 0.8.5.0. See #typeable-instances#+instance Binary KindRep where+ put (KindRepTyConApp tc k) = putWord8 0 >> put tc >> put k+ put (KindRepVar bndr) = putWord8 1 >> put bndr+ put (KindRepApp a b) = putWord8 2 >> put a >> put b+ put (KindRepFun a b) = putWord8 3 >> put a >> put b+ put (KindRepTYPE r) = putWord8 4 >> put r+ put (KindRepTypeLit sort r) = putWord8 5 >> put sort >> put r++ get = do+ tag <- getWord8+ case tag of+ 0 -> KindRepTyConApp <$> get <*> get+ 1 -> KindRepVar <$> get+ 2 -> KindRepApp <$> get <*> get+ 3 -> KindRepFun <$> get <*> get+ 4 -> KindRepTYPE <$> get+ 5 -> KindRepTypeLit <$> get <*> get+ _ -> fail "GHCi.TH.Binary.putKindRep: invalid tag"++-- | @since 0.8.5.0. See #typeable-instances#+instance Binary TypeLitSort where+ put TypeLitSymbol = putWord8 0+ put TypeLitNat = putWord8 1+ get = do+ tag <- getWord8+ case tag of+ 0 -> pure TypeLitSymbol+ 1 -> pure TypeLitNat+ _ -> fail "GHCi.TH.Binary.putTypeLitSort: invalid tag"++putTypeRep :: TypeRep a -> Put+-- Special handling for TYPE, (->), and RuntimeRep due to recursive kind+-- relations.+-- See Note [Mutually recursive representations of primitive types]+putTypeRep rep -- Handle Type specially since it's so common+ | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)+ = put (0 :: Word8)+putTypeRep (Con' con ks) = do+ put (1 :: Word8)+ put con+ put ks+putTypeRep (App f x) = do+ put (2 :: Word8)+ putTypeRep f+ putTypeRep x+putTypeRep (Fun arg res) = do+ put (3 :: Word8)+ putTypeRep arg+ putTypeRep res+putTypeRep _ = fail "GHCi.TH.Binary.putTypeRep: Impossible"++getSomeTypeRep :: Get SomeTypeRep+getSomeTypeRep = do+ tag <- get :: Get Word8+ case tag of+ 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)+ 1 -> do con <- get :: Get TyCon+ ks <- get :: Get [SomeTypeRep]+ return $ SomeTypeRep $ mkTrCon con ks+ 2 -> do SomeTypeRep f <- getSomeTypeRep+ SomeTypeRep x <- getSomeTypeRep+ case typeRepKind f of+ Fun arg res ->+ case arg `eqTypeRep` typeRepKind x of+ Just HRefl -> do+ case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of+ Just HRefl -> return $ SomeTypeRep $ mkTrApp f x+ _ -> failure "Kind mismatch" []+ _ -> failure "Kind mismatch"+ [ "Found argument of kind: " ++ show (typeRepKind x)+ , "Where the constructor: " ++ show f+ , "Expects an argument of kind: " ++ show arg+ ]+ _ -> failure "Applied non-arrow type"+ [ "Applied type: " ++ show f+ , "To argument: " ++ show x+ ]+ 3 -> do SomeTypeRep arg <- getSomeTypeRep+ SomeTypeRep res <- getSomeTypeRep+ case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of+ Just HRefl ->+ case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of+ Just HRefl -> return $ SomeTypeRep $ Fun arg res+ Nothing -> failure "Kind mismatch" []+ Nothing -> failure "Kind mismatch" []+ _ -> failure "Invalid SomeTypeRep" []+ where+ failure description info =+ fail $ unlines $ [ "GHCi.TH.Binary.getSomeTypeRep: "++description ]+ ++ map (" "++) info++instance Typeable a => Binary (TypeRep (a :: k)) where+ put = putTypeRep+ get = do+ SomeTypeRep rep <- getSomeTypeRep+ case rep `eqTypeRep` expected of+ Just HRefl -> pure rep+ Nothing -> fail $ unlines+ [ "GHCi.TH.Binary: Type mismatch"+ , " Deserialized type: " ++ show rep+ , " Expected type: " ++ show expected+ ]+ where expected = typeRep :: TypeRep a++instance Binary SomeTypeRep where+ put (SomeTypeRep rep) = putTypeRep rep+ get = getSomeTypeRep+#endif+
+ src/Data/Binary/FloatCast.hs view
@@ -0,0 +1,45 @@++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Trustworthy #-}++-- | This module was written based on+-- <http://hackage.haskell.org/package/reinterpret-cast-0.1.0/docs/src/Data-ReinterpretCast-Internal-ImplArray.html>.+--+-- Implements casting via a 1-elemnt STUArray, as described in+-- <http://stackoverflow.com/a/7002812/263061>.+module Data.Binary.FloatCast+ ( floatToWord+ , wordToFloat+ , doubleToWord+ , wordToDouble+ ) where++import Data.Word (Word32, Word64)+import Data.Array.ST (newArray, readArray, MArray, STUArray)+import Data.Array.Unsafe (castSTUArray)+import GHC.ST (runST, ST)++-- | Reinterpret-casts a `Float` to a `Word32`.+floatToWord :: Float -> Word32+floatToWord x = runST (cast x)+{-# INLINE floatToWord #-}++-- | Reinterpret-casts a `Word32` to a `Float`.+wordToFloat :: Word32 -> Float+wordToFloat x = runST (cast x)+{-# INLINE wordToFloat #-}++-- | Reinterpret-casts a `Double` to a `Word64`.+doubleToWord :: Double -> Word64+doubleToWord x = runST (cast x)+{-# INLINE doubleToWord #-}++-- | Reinterpret-casts a `Word64` to a `Double`.+wordToDouble :: Word64 -> Double+wordToDouble x = runST (cast x)+{-# INLINE wordToDouble #-}++cast :: (MArray (STUArray s) a (ST s),+ MArray (STUArray s) b (ST s)) => a -> ST s b+cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0+{-# INLINE cast #-}
src/Data/Binary/Generic.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures, ScopedTypeVariables, TypeOperators, TypeSynonymInstances #-}-#if __GLASGOW_HASKELL__ >= 701 && __GLASGOW_HASKELL__ != 702 {-# LANGUAGE Safe #-}-#endif {-# OPTIONS_GHC -fno-warn-orphans #-} +#if __GLASGOW_HASKELL__ >= 800+#define HAS_DATA_KIND+#endif+ ----------------------------------------------------------------------------- -- | -- Module : Data.Binary.Generic@@ -28,32 +30,46 @@ import Data.Binary.Put 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. -- Type without constructors-instance GBinary V1 where- gput _ = return ()+instance GBinaryPut V1 where+ gput _ = pure ()++instance GBinaryGet V1 where gget = return undefined -- Constructor without arguments-instance GBinary U1 where- gput U1 = return ()+instance GBinaryPut U1 where+ gput U1 = pure ()++instance GBinaryGet U1 where gget = return U1 -- Product: constructor with parameters-instance (GBinary a, GBinary b) => GBinary (a :*: b) where- gput (x :*: y) = gput x >> gput y+instance (GBinaryPut a, GBinaryPut b) => GBinaryPut (a :*: b) where+ gput (x :*: y) = gput x <> gput y++instance (GBinaryGet a, GBinaryGet b) => GBinaryGet (a :*: b) where gget = (:*:) <$> gget <*> gget -- Metadata (constructor name, etc)-instance GBinary a => GBinary (M1 i c a) where+instance GBinaryPut a => GBinaryPut (M1 i c a) where gput = gput . unM1++instance GBinaryGet a => GBinaryGet (M1 i c a) where gget = M1 <$> gget -- Constants, additional parameters, and rank-1 recursion-instance Binary a => GBinary (K1 i a) where+instance Binary a => GBinaryPut (K1 i a) where gput = put . unK1++instance Binary a => GBinaryGet (K1 i a) where gget = K1 <$> get -- Borrowed from the cereal package.@@ -69,14 +85,15 @@ #define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size) #define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size) -instance ( GSum a, GSum b- , GBinary a, GBinary b- , SumSize a, SumSize b) => GBinary (a :+: b) where+instance ( GSumPut a, GSumPut b+ , SumSize a, SumSize b) => GBinaryPut (a :+: b) where gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64) | otherwise = sizeError "encode" size where size = unTagged (sumSize :: Tagged (a :+: b) Word64) +instance ( GSumGet a, GSumGet b+ , SumSize a, SumSize b) => GBinaryGet (a :+: b) where gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64) | otherwise = sizeError "decode" size where@@ -88,23 +105,26 @@ ------------------------------------------------------------------------ -checkGetSum :: (Ord word, Num word, Bits word, GSum f)+checkGetSum :: (Ord word, Num word, Bits word, GSumGet f) => word -> word -> Get (f a) checkGetSum size code | code < size = getSum code size | otherwise = fail "Unknown encoding for constructor" {-# INLINE checkGetSum #-} -class GSum f where+class GSumGet f where getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)++class GSumPut f where putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put -instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where+instance (GSumGet a, GSumGet b) => GSumGet (a :+: b) where getSum !code !size | code < sizeL = L1 <$> getSum code sizeL | otherwise = R1 <$> getSum (code - sizeL) sizeR where sizeL = size `shiftR` 1 sizeR = size - sizeL +instance (GSumPut a, GSumPut b) => GSumPut (a :+: b) where putSum !code !size s = case s of L1 x -> putSum code sizeL x R1 x -> putSum (code + sizeL) sizeR x@@ -112,17 +132,22 @@ sizeL = size `shiftR` 1 sizeR = size - sizeL -instance GBinary a => GSum (C1 c a) where+instance GBinaryGet a => GSumGet (C1 c a) where getSum _ _ = gget - putSum !code _ x = put code *> gput x+instance GBinaryPut a => GSumPut (C1 c a) where+ putSum !code _ x = put code <> gput x ------------------------------------------------------------------------ class SumSize f where sumSize :: Tagged f Word64 -newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b}+#ifdef HAS_DATA_KIND+newtype Tagged (s :: Type -> Type) b = Tagged {unTagged :: b}+#else+newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b}+#endif instance (SumSize a, SumSize b) => SumSize (a :+: b) where sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) +
src/Data/Binary/Get.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE CPP, RankNTypes, MagicHash, BangPatterns #-}-#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}-#endif #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) #include "MachDeps.h"@@ -43,7 +41,7 @@ -- The fields in @Trade@ are marked as strict (using @!@) since we don't need -- laziness here. In practise, you would probably consider using the UNPACK -- pragma as well.--- <http://www.haskell.org/ghc/docs/latest/html/users_guide/pragmas.html#unpack-pragma>+-- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#unpack-pragma> -- -- Now, let's have a look at a decoder for this format. --@@ -63,9 +61,6 @@ --getTrade' = Trade '<$>' 'getWord32le' '<*>' 'getWord32le' '<*>' 'getWord16le' -- @ ----- The applicative style can sometimes result in faster code, as @binary@--- will try to optimize the code by grouping the reads together.--- -- There are two kinds of ways to execute this decoder, the lazy input -- method and the incremental input method. Here we will use the lazy -- input method.@@ -172,7 +167,7 @@ , getLazyByteStringNul , getRemainingLazyByteString - -- ** Decoding words+ -- ** Decoding Words , getWord8 -- *** Big-endian decoding@@ -191,11 +186,41 @@ , getWord32host , getWord64host + -- ** Decoding Ints+ , getInt8++ -- *** Big-endian decoding+ , getInt16be+ , getInt32be+ , getInt64be++ -- *** Little-endian decoding+ , getInt16le+ , getInt32le+ , getInt64le++ -- *** Host-endian, unaligned decoding+ , getInthost+ , getInt16host+ , getInt32host+ , getInt64host++ -- ** Decoding Floats/Doubles+ , getFloatbe+ , getFloatle+ , getFloathost+ , getDoublebe+ , getDoublele+ , getDoublehost+ -- * Deprecated functions , runGetState -- DEPRECATED , remaining -- DEPRECATED , getBytes -- DEPRECATED ) where+#if ! MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif import Foreign import qualified Data.ByteString as B@@ -212,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@@ -299,6 +327,8 @@ -- success. In both cases any unconsumed input and the number of bytes -- consumed is returned. In the case of failure, a human-readable -- error message is included as well.+--+-- /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@@ -409,8 +439,14 @@ -- | Read a Word8 from the monad state getWord8 :: Get Word8 getWord8 = readN 1 B.unsafeHead-{-# INLINE getWord8 #-}+{-# INLINE[2] getWord8 #-} +-- | Read an Int8 from the monad state+getInt8 :: Get Int8+getInt8 = fromIntegral <$> getWord8+{-# INLINE getInt8 #-}++ -- force GHC to inline getWordXX {-# RULES "getWord8/readN" getWord8 = readN 1 B.unsafeHead@@ -429,7 +465,7 @@ word16be = \s -> (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w16` 8) .|. (fromIntegral (s `B.unsafeIndex` 1))-{-# INLINE getWord16be #-}+{-# INLINE[2] getWord16be #-} {-# INLINE word16be #-} -- | Read a Word16 in little endian format@@ -440,7 +476,7 @@ word16le = \s -> (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w16` 8) .|. (fromIntegral (s `B.unsafeIndex` 0) )-{-# INLINE getWord16le #-}+{-# INLINE[2] getWord16le #-} {-# INLINE word16le #-} -- | Read a Word32 in big endian format@@ -453,7 +489,7 @@ (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 16) .|. (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 8) .|. (fromIntegral (s `B.unsafeIndex` 3) )-{-# INLINE getWord32be #-}+{-# INLINE[2] getWord32be #-} {-# INLINE word32be #-} -- | Read a Word32 in little endian format@@ -466,7 +502,7 @@ (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 16) .|. (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 8) .|. (fromIntegral (s `B.unsafeIndex` 0) )-{-# INLINE getWord32le #-}+{-# INLINE[2] getWord32le #-} {-# INLINE word32le #-} -- | Read a Word64 in big endian format@@ -483,7 +519,7 @@ (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 16) .|. (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 8) .|. (fromIntegral (s `B.unsafeIndex` 7) )-{-# INLINE getWord64be #-}+{-# INLINE[2] getWord64be #-} {-# INLINE word64be #-} -- | Read a Word64 in little endian format@@ -500,9 +536,42 @@ (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 16) .|. (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 8) .|. (fromIntegral (s `B.unsafeIndex` 0) )-{-# INLINE getWord64le #-}+{-# INLINE[2] getWord64le #-} {-# INLINE word64le #-} ++-- | Read an Int16 in big endian format.+getInt16be :: Get Int16+getInt16be = fromIntegral <$> getWord16be+{-# INLINE getInt16be #-}++-- | Read an Int32 in big endian format.+getInt32be :: Get Int32+getInt32be = fromIntegral <$> getWord32be+{-# INLINE getInt32be #-}++-- | Read an Int64 in big endian format.+getInt64be :: Get Int64+getInt64be = fromIntegral <$> getWord64be+{-# INLINE getInt64be #-}+++-- | Read an Int16 in little endian format.+getInt16le :: Get Int16+getInt16le = fromIntegral <$> getWord16le+{-# INLINE getInt16le #-}++-- | Read an Int32 in little endian format.+getInt32le :: Get Int32+getInt32le = fromIntegral <$> getWord32le+{-# INLINE getInt32le #-}++-- | Read an Int64 in little endian format.+getInt64le :: Get Int64+getInt64le = fromIntegral <$> getWord64le+{-# INLINE getInt64le #-}++ ------------------------------------------------------------------------ -- Host-endian reads @@ -528,7 +597,62 @@ getWord64host = getPtr (sizeOf (undefined :: Word64)) {-# INLINE getWord64host #-} +-- | /O(1)./ Read a single native machine word in native host+-- order. It works in the same way as 'getWordhost'.+getInthost :: Get Int+getInthost = getPtr (sizeOf (undefined :: Int))+{-# INLINE getInthost #-}++-- | /O(1)./ Read a 2 byte Int16 in native host order and host endianness.+getInt16host :: Get Int16+getInt16host = getPtr (sizeOf (undefined :: Int16))+{-# INLINE getInt16host #-}++-- | /O(1)./ Read an Int32 in native host order and host endianness.+getInt32host :: Get Int32+getInt32host = getPtr (sizeOf (undefined :: Int32))+{-# INLINE getInt32host #-}++-- | /O(1)./ Read an Int64 in native host order and host endianess.+getInt64host :: Get Int64+getInt64host = getPtr (sizeOf (undefined :: Int64))+{-# INLINE getInt64host #-}++ ------------------------------------------------------------------------+-- 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@@ -541,12 +665,6 @@ #if WORD_SIZE_IN_BITS < 64 shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)--#if __GLASGOW_HASKELL__ <= 606--- Exported by GHC.Word in GHC 6.8 and higher-foreign import ccall unsafe "stg_uncheckedShiftL64"- uncheckedShiftL64# :: Word64# -> Int# -> Word64#-#endif #else shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)
src/Data/Binary/Get/Internal.hs view
@@ -23,7 +23,7 @@ , withInputChunks , Consume , failOnEOF- + , get , put , ensureN@@ -44,18 +44,16 @@ import Foreign import qualified Data.ByteString as B-import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Unsafe as B import Control.Applicative import Control.Monad--#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+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail #endif +import Data.Binary.Internal ( accursedUnutterablePerformIO )+ -- 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,@@ -91,13 +89,14 @@ type Success a r = B.ByteString -> a -> Decoder r instance Monad Get where- return = returnG+ return = pure (>>=) = bindG- fail = failG+#if MIN_VERSION_base(4,9,0)+ fail = Fail.fail -returnG :: a -> Get a-returnG a = C $ \s ks -> ks s a-{-# INLINE [0] returnG #-}+instance Fail.MonadFail Get where+#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)@@ -118,11 +117,12 @@ {-# INLINE fmapG #-} instance Applicative Get where- pure = returnG- {-# INLINE pure #-}+ pure = \x -> C $ \s ks -> ks s x+ {-# INLINE [0] pure #-} (<*>) = apG {-# INLINE (<*>) #-} +-- | /Since: 0.7.1.0/ instance MonadPlus Get where mzero = empty mplus = (<|>)@@ -192,6 +192,8 @@ -- If the given decoder fails, 'isolate' will also fail. -- Offset from 'bytesRead' will be relative to the start of 'isolate', not the -- absolute of the input.+--+-- /Since: 0.7.2.0/ isolate :: Int -- ^ The number of bytes that must be consumed -> Get a -- ^ The decoder to isolate -> Get a@@ -254,25 +256,28 @@ getBytes = getByteString {-# INLINE getBytes #-} +-- | /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'), +-- Once it's finished, return the final decoder (always 'Done' or 'Fail'), -- and unconsume all the the input the decoder required to run. -- Any additional chunks which was required to run the decoder -- will also be returned.@@ -298,6 +303,8 @@ -- | Run the given decoder, but without consuming its input. If the given -- decoder fails, then so will this function.+--+-- /Since: 0.7.0.0/ lookAhead :: Get a -> Get a lookAhead g = do (decoder, bs) <- runAndKeepTrack g@@ -309,6 +316,8 @@ -- | Run the given decoder, and only consume its input if it returns 'Just'. -- If 'Nothing' is returned, the input will be unconsumed. -- If the given decoder fails, then so will this function.+--+-- /Since: 0.7.0.0/ lookAheadM :: Get (Maybe a) -> Get (Maybe a) lookAheadM g = do let g' = maybe (Left ()) Right <$> g@@ -317,6 +326,8 @@ -- | Run the given decoder, and only consume its input if it returns 'Right'. -- If 'Left' is returned, the input will be unconsumed. -- If the given decoder fails, then so will this function.+--+-- /Since: 0.7.1.0/ lookAheadE :: Get (Either a b) -> Get (Either a b) lookAheadE g = do (decoder, bs) <- runAndKeepTrack g@@ -326,8 +337,10 @@ Fail inp s -> C $ \_ _ -> Fail inp s _ -> error "Binary: impossible" --- Label a decoder. If the decoder fails, the label will be appended on+-- | 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/ label :: String -> Get a -> Get a label msg decoder = C $ \inp ks -> let r0 = runCont decoder inp (\inp' a -> Done inp' a)@@ -380,17 +393,8 @@ {-# RULES -"<$> to <*>" forall f g.- (<$>) f g = returnG f <*> g- "readN/readN merge" forall n m f g.- apG (readN n f) (readN m g) = readN (n+m) (\bs -> f bs $ g (B.unsafeDrop n bs))--"returnG/readN swap" [~1] forall f.- returnG f = readN 0 (const f)--"readN 0/returnG swapback" [1] forall f.- readN 0 f = returnG (f B.empty) #-}+ apG (readN n f) (readN m g) = readN (n+m) (\bs -> f bs $ g (B.unsafeDrop n bs)) #-} -- | Ensure that there are at least @n@ bytes available. If not, the -- computation will escape with 'Partial'.@@ -404,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 #-} @@ -412,7 +420,11 @@ unsafeReadN !n f = C $ \inp ks -> do ks (B.unsafeDrop n inp) $! f inp -- strict return +-- | @readNWith n f@ where @f@ must be deterministic and not have side effects. readNWith :: Int -> (Ptr a -> IO a) -> Get a readNWith n f = do- readN n $ \s -> B.inlinePerformIO $ B.unsafeUseAsCString s (f . castPtr)+ -- It should be safe to use accursedUnutterablePerformIO here.+ -- The action must be deterministic and not have any external side effects.+ -- It depends on the value of the ByteString so the value dependencies look OK.+ readN n $ \s -> accursedUnutterablePerformIO $ B.unsafeUseAsCString s (f . castPtr) {-# INLINE readNWith #-}
+ src/Data/Binary/Internal.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE CPP #-}++module Data.Binary.Internal + ( accursedUnutterablePerformIO ) where++#if MIN_VERSION_bytestring(0,10,6)+import Data.ByteString.Internal( accursedUnutterablePerformIO )+#else+import Data.ByteString.Internal( inlinePerformIO )++{-# INLINE accursedUnutterablePerformIO #-}+-- | You must be truly desperate to come to me for help.+accursedUnutterablePerformIO :: IO a -> a+accursedUnutterablePerformIO = inlinePerformIO+#endif
src/Data/Binary/Put.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 701 && __GLASGOW_HASKELL__ != 702+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Safe #-}++#if MIN_VERSION_base(4,9,0)+#define HAS_SEMIGROUP #endif -----------------------------------------------------------------------------@@ -32,38 +35,72 @@ -- * Primitives , putWord8+ , putInt8 , putByteString , putLazyByteString+#if MIN_VERSION_bytestring(0,10,4)+ , putShortByteString+#endif -- * Big-endian primitives , putWord16be , putWord32be , putWord64be+ , putInt16be+ , putInt32be+ , putInt64be+ , putFloatbe+ , putDoublebe -- * Little-endian primitives , putWord16le , putWord32le , putWord64le+ , putInt16le+ , putInt32le+ , putInt64le+ , putFloatle+ , putDoublele -- * Host-endian, unaligned writes , putWordhost -- :: Word -> Put , putWord16host -- :: Word16 -> Put , putWord32host -- :: Word32 -> Put , putWord64host -- :: Word64 -> Put+ , putInthost -- :: Int -> Put+ , putInt16host -- :: Int16 -> Put+ , putInt32host -- :: Int32 -> Put+ , putInt64host -- :: Int64 -> Put+ , putFloathost+ , putDoublehost + -- * Unicode+ , putCharUtf8+ , putStringUtf8+ ) where -import Data.Monoid+import qualified Data.Monoid as Monoid import Data.Binary.Builder (Builder, toLazyByteString) import qualified Data.Binary.Builder as B +import Data.Int import Data.Word import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L+#if MIN_VERSION_bytestring(0,10,4)+import Data.ByteString.Short+#endif +#ifdef HAS_SEMIGROUP+import Data.Semigroup+#endif+ import Control.Applicative import Prelude -- Silence AMP warning. +-- needed for casting Floats/Doubles to words.+import Data.Binary.FloatCast (floatToWord, doubleToWord) ------------------------------------------------------------------------ @@ -84,29 +121,58 @@ {-# INLINE fmap #-} instance Applicative PutM where- pure = return+ pure a = Put $ PairS a Monoid.mempty+ {-# INLINE pure #-}+ m <*> k = Put $ let PairS f w = unPut m PairS x w' = unPut k- in PairS (f x) (w `mappend` w')+ in PairS (f x) (w `Monoid.mappend` w') + m *> k = Put $+ let PairS _ w = unPut m+ PairS b w' = unPut k+ in PairS b (w `Monoid.mappend` w')+ {-# INLINE (*>) #-}+ -- Standard Writer monad, with aggressive inlining instance Monad PutM where- return a = Put $ PairS a mempty- {-# INLINE return #-}- m >>= k = Put $ let PairS a w = unPut m PairS b w' = unPut (k a)- in PairS b (w `mappend` w')+ in PairS b (w `Monoid.mappend` w') {-# INLINE (>>=) #-} - m >> k = Put $- let PairS _ w = unPut m- PairS b w' = unPut k- in PairS b (w `mappend` w')+ return = pure+ {-# INLINE return #-}++ (>>) = (*>) {-# INLINE (>>) #-} +instance Monoid.Monoid (PutM ()) where+ mempty = pure ()+ {-# INLINE mempty #-}++#ifdef HAS_SEMIGROUP+ mappend = (<>)+#else+ mappend = mappend'+#endif+ {-# INLINE mappend #-}++mappend' :: Put -> Put -> Put+mappend' m k = Put $+ let PairS _ w = unPut m+ PairS _ w' = unPut k+ in PairS () (w `Monoid.mappend` w')+{-# INLINE mappend' #-}++#ifdef HAS_SEMIGROUP+instance Semigroup (PutM ()) where+ (<>) = mappend'+ {-# INLINE (<>) #-}+#endif+ tell :: Builder -> Put tell b = Put $ PairS () b {-# INLINE tell #-}@@ -143,6 +209,11 @@ putWord8 = tell . B.singleton {-# INLINE putWord8 #-} +-- | Efficiently write a signed byte into the output buffer+putInt8 :: Int8 -> Put+putInt8 = tell . B.singleton . fromIntegral+{-# INLINE putInt8 #-}+ -- | An efficient primitive to write a strict ByteString into the output buffer. -- It flushes the current buffer, and writes the argument into a new chunk. putByteString :: S.ByteString -> Put@@ -155,6 +226,13 @@ putLazyByteString = tell . B.fromLazyByteString {-# INLINE putLazyByteString #-} +#if MIN_VERSION_bytestring(0,10,4)+-- | Write 'ShortByteString' to the buffer+putShortByteString :: ShortByteString -> Put+putShortByteString = tell . B.fromShortByteString+{-# INLINE putShortByteString #-}+#endif+ -- | Write a Word16 in big endian format putWord16be :: Word16 -> Put putWord16be = tell . B.putWord16be@@ -185,6 +263,37 @@ putWord64le = tell . B.putWord64le {-# INLINE putWord64le #-} +-- | Write an Int16 in big endian format+putInt16be :: Int16 -> Put+putInt16be = tell . B.putInt16be+{-# INLINE putInt16be #-}++-- | Write an Int16 in little endian format+putInt16le :: Int16 -> Put+putInt16le = tell . B.putInt16le+{-# INLINE putInt16le #-}++-- | Write an Int32 in big endian format+putInt32be :: Int32 -> Put+putInt32be = tell . B.putInt32be+{-# INLINE putInt32be #-}++-- | Write an Int32 in little endian format+putInt32le :: Int32 -> Put+putInt32le = tell . B.putInt32le+{-# INLINE putInt32le #-}++-- | Write an Int64 in big endian format+putInt64be :: Int64 -> Put+putInt64be = tell . B.putInt64be+{-# INLINE putInt64be #-}++-- | Write an Int64 in little endian format+putInt64le :: Int64 -> Put+putInt64le = tell . B.putInt64le+{-# INLINE putInt64le #-}++ ------------------------------------------------------------------------ -- | /O(1)./ Write a single native machine word. The word is@@ -215,3 +324,78 @@ putWord64host :: Word64 -> Put putWord64host = tell . B.putWord64host {-# INLINE putWord64host #-}++-- | /O(1)./ Write a single native machine word. The word is+-- written in host order, host endian form, for the machine you're on.+-- On a 64 bit machine the Int is an 8 byte value, on a 32 bit machine,+-- 4 bytes. Values written this way are not portable to+-- different endian or word sized machines, without conversion.+--+putInthost :: Int -> Put+putInthost = tell . B.putInthost+{-# INLINE putInthost #-}++-- | /O(1)./ Write an Int16 in native host order and host endianness.+-- For portability issues see @putInthost@.+putInt16host :: Int16 -> Put+putInt16host = tell . B.putInt16host+{-# INLINE putInt16host #-}++-- | /O(1)./ Write an Int32 in native host order and host endianness.+-- For portability issues see @putInthost@.+putInt32host :: Int32 -> Put+putInt32host = tell . B.putInt32host+{-# INLINE putInt32host #-}++-- | /O(1)./ Write an Int64 in native host order+-- On a 32 bit machine we write two host order Int32s, in big endian form.+-- For portability issues see @putInthost@.+putInt64host :: Int64 -> Put+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++-- | Write a character using UTF-8 encoding.+putCharUtf8 :: Char -> Put+putCharUtf8 = tell . B.putCharUtf8+{-# INLINE putCharUtf8 #-}++-- | Write a String using UTF-8 encoding.+putStringUtf8 :: String -> Put+putStringUtf8 = tell . B.putStringUtf8+{-# INLINE putStringUtf8 #-}
tests/Action.hs view
@@ -38,6 +38,7 @@ deriving (Show, Eq) instance Arbitrary Action where+ arbitrary = fmap Actions (gen_actions False) shrink action = case action of Actions [a] -> [a]
tests/Arbitrary.hs view
@@ -7,6 +7,9 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L+#if MIN_VERSION_bytestring(0,10,4)+import qualified Data.ByteString.Short as S+#endif instance Arbitrary L.ByteString where arbitrary = fmap L.fromChunks arbitrary@@ -14,42 +17,7 @@ instance Arbitrary B.ByteString where arbitrary = B.pack `fmap` arbitrary -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)+#if MIN_VERSION_bytestring(0,10,4)+instance Arbitrary S.ShortByteString where+ arbitrary = S.toShort `fmap` arbitrary+#endif
tests/File.hs view
@@ -1,14 +1,18 @@+{-# LANGUAGE CPP #-} module Main where -import Control.Applicative-import Test.HUnit-import System.Directory ( getTemporaryDirectory )-import System.FilePath ( (</>) )+#if ! MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif -import Distribution.Simple.Utils ( withTempDirectory )-import Distribution.Verbosity ( silent )+import System.Directory (getTemporaryDirectory)+import System.FilePath ((</>))+import Test.HUnit -import Data.Binary+import Distribution.Simple.Utils (withTempDirectory)+import Distribution.Verbosity (silent)++import Data.Binary data Foo = Bar !Word32 !Word32 !Word32 deriving (Eq, Show)
tests/QC.hs view
@@ -1,12 +1,12 @@-{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# LANGUAGE CPP, ScopedTypeVariables, DataKinds, TypeSynonymInstances #-} module Main ( main ) where #if MIN_VERSION_base(4,8,0) #define HAS_NATURAL #endif -#if __GLASGOW_HASKELL__ >= 704-#define HAS_GHC_FINGERPRINT+#if MIN_VERSION_base(4,7,0)+#define HAS_FIXED_CONSTRUCTOR #endif import Control.Applicative@@ -16,27 +16,32 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Internal as L+#if MIN_VERSION_bytestring(0,10,4)+import Data.ByteString.Short (ShortByteString)+#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 ------------------------------------------------------------------------ @@ -57,7 +62,12 @@ (\(_e :: SomeException) -> return True) -- low level ones:+--+-- Words +prop_Word8 :: Word8 -> Property+prop_Word8 = roundTripWith putWord8 getWord8+ prop_Word16be :: Word16 -> Property prop_Word16be = roundTripWith putWord16be getWord16be @@ -88,7 +98,93 @@ prop_Wordhost :: Word -> Property prop_Wordhost = roundTripWith putWordhost getWordhost +-- Ints +prop_Int8 :: Int8 -> Property+prop_Int8 = roundTripWith putInt8 getInt8++prop_Int16be :: Int16 -> Property+prop_Int16be = roundTripWith putInt16be getInt16be++prop_Int16le :: Int16 -> Property+prop_Int16le = roundTripWith putInt16le getInt16le++prop_Int16host :: Int16 -> Property+prop_Int16host = roundTripWith putInt16host getInt16host++prop_Int32be :: Int32 -> Property+prop_Int32be = roundTripWith putInt32be getInt32be++prop_Int32le :: Int32 -> Property+prop_Int32le = roundTripWith putInt32le getInt32le++prop_Int32host :: Int32 -> Property+prop_Int32host = roundTripWith putInt32host getInt32host++prop_Int64be :: Int64 -> Property+prop_Int64be = roundTripWith putInt64be getInt64be++prop_Int64le :: Int64 -> Property+prop_Int64le = roundTripWith putInt64le getInt64le++prop_Int64host :: Int64 -> Property+prop_Int64host = roundTripWith putInt64host getInt64host++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.@@ -365,35 +461,71 @@ ------------------------------------------------------------------------ +genInteger :: Gen Integer+genInteger = do+ b <- arbitrary+ if b then genIntegerSmall else genIntegerSmall++genIntegerSmall :: Gen Integer+genIntegerSmall = arbitrary++genIntegerBig :: Gen Integer+genIntegerBig = do+ x <- arbitrarySizedIntegral :: Gen Integer+ -- arbitrarySizedIntegral generates numbers smaller than+ -- (maxBound :: Word32), so let's make them bigger to better test+ -- the Binary instance.+ return (x + fromIntegral (maxBound :: Word32))+ #ifdef HAS_NATURAL-prop_test_Natural :: Property-prop_test_Natural = forAll (gen :: Gen Natural) test- where- gen :: Gen Natural- gen = do- b <- arbitrary- if b- then do- x <- arbitrarySizedNatural :: Gen Natural- -- arbitrarySizedNatural generates numbers smaller than- -- (maxBound :: Word64), so let's make them bigger to better test- -- the Binary instance.- return (x + fromIntegral (maxBound :: Word64))- else arbitrarySizedNatural+genNatural :: Gen Natural+genNatural = do+ b <- arbitrary+ if b then genNaturalSmall else genNaturalBig++genNaturalSmall :: Gen Natural+genNaturalSmall = arbitrarySizedNatural++genNaturalBig :: Gen Natural+genNaturalBig = do+ x <- arbitrarySizedNatural :: Gen Natural+ -- arbitrarySizedNatural generates numbers smaller than+ -- (maxBound :: Word64), so let's make them bigger to better test+ -- the Binary instance.+ return (x + fromIntegral (maxBound :: Word64)) #endif ------------------------------------------------------------------------ -#ifdef HAS_GHC_FINGERPRINT-prop_test_GHC_Fingerprint :: Property-prop_test_GHC_Fingerprint = forAll gen test- where- gen :: Gen Fingerprint- gen = liftM2 Fingerprint arbitrary arbitrary+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++------------------------------------------------------------------------++#ifdef HAS_FIXED_CONSTRUCTOR++fixedPut :: forall a. Fixed.HasResolution a => Fixed.Fixed a -> Put+fixedPut x = put (truncate (x * fromInteger (Fixed.resolution (undefined :: Maybe a))) :: Integer)++fixedGet :: forall a. Fixed.HasResolution a => Get (Fixed.Fixed a)+fixedGet = (\x -> fromInteger x / fromInteger (Fixed.resolution (undefined :: Maybe a))) `liftA` get++-- | Serialise using base >=4.7 and <4.7 methods agree+prop_fixed_ser :: Fixed.Fixed Fixed.E3 -> Bool+prop_fixed_ser x = runPut (put x) == runPut (fixedPut x)++-- | Serialised with base >=4.7, unserialised with base <4.7 method roundtrip+prop_fixed_constr_resolution :: Fixed.Fixed Fixed.E3 -> Bool+prop_fixed_constr_resolution x = runGet fixedGet (runPut (put x)) == x++-- | Serialised with base <4.7, unserialised with base >=4.7 method roundtrip+prop_fixed_resolution_constr :: Fixed.Fixed Fixed.E3 -> Bool+prop_fixed_resolution_constr x = runGet get (runPut (fixedPut x)) == x+ #endif ------------------------------------------------------------------------@@ -407,6 +539,20 @@ test :: (Eq a, Binary a) => a -> Property test a = forAll positiveList (roundTrip a . refragment) +test' :: (Show a, Arbitrary a) => String -> (a -> Property) -> ([a] -> Property) -> Test+test' desc prop propList =+ testGroup desc [+ testProperty desc prop,+ testProperty ("[" ++ desc ++ "]") propList+ ]++testWithGen :: (Show a, Eq a, Binary a) => String -> Gen a -> Test+testWithGen desc gen =+ testGroup desc [+ testProperty desc (forAll gen test),+ testProperty ("[" ++ desc ++ "]") (forAll (listOf gen) test)+ ]+ positiveList :: Gen [Int] positiveList = fmap (filter (/=0) . map abs) $ arbitrary @@ -436,7 +582,8 @@ Action.tests , testGroup "Primitives"- [ testProperty "Word16be" (p prop_Word16be)+ [ testProperty "Word8" (p prop_Word8)+ , testProperty "Word16be" (p prop_Word16be) , testProperty "Word16le" (p prop_Word16le) , testProperty "Word16host" (p prop_Word16host) , testProperty "Word32be" (p prop_Word32be)@@ -446,6 +593,25 @@ , testProperty "Word64le" (p prop_Word64le) , testProperty "Word64host" (p prop_Word64host) , testProperty "Wordhost" (p prop_Wordhost)+ -- Int+ , testProperty "Int8" (p prop_Int8)+ , testProperty "Int16be" (p prop_Int16be)+ , testProperty "Int16le" (p prop_Int16le)+ , testProperty "Int16host" (p prop_Int16host)+ , testProperty "Int32be" (p prop_Int32be)+ , testProperty "Int32le" (p prop_Int32le)+ , testProperty "Int32host" (p prop_Int32host)+ , testProperty "Int64be" (p prop_Int64be)+ , 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"@@ -455,79 +621,75 @@ , testProperty "getRemainingLazyByteString" prop_getRemainingLazyByteString ] - , testGroup "Using Binary class, refragmented ByteString" $ map (uncurry testProperty)- [ ("()", p (test :: T () ))- , ("Bool", p (test :: T Bool ))- , ("Ordering", p (test :: T Ordering ))- , ("Ratio Int", p (test :: T (Ratio Int) ))+ , testGroup "Using Binary class, refragmented ByteString"+ [ test' "()" (test :: T () ) test+ , test' "Bool" (test :: T Bool ) test+ , test' "Char" (test :: T Char ) test+ , test' "Ordering" (test :: T Ordering ) test+ , test' "Ratio Int" (test :: T (Ratio Int)) test + , test' "Word" (test :: T Word ) test+ , test' "Word8" (test :: T Word8 ) test+ , test' "Word16" (test :: T Word16) test+ , test' "Word32" (test :: T Word32) test+ , test' "Word64" (test :: T Word64) test - , ("Word8", p (test :: T Word8 ))- , ("Word16", p (test :: T Word16 ))- , ("Word32", p (test :: T Word32 ))- , ("Word64", p (test :: T Word64 ))+ , test' "Int" (test :: T Int ) test+ , test' "Int8" (test :: T Int8 ) test+ , test' "Int16" (test :: T Int16) test+ , test' "Int32" (test :: T Int32) test+ , test' "Int64" (test :: T Int64) test - , ("Int8", p (test :: T Int8 ))- , ("Int16", p (test :: T Int16 ))- , ("Int32", p (test :: T Int32 ))- , ("Int64", p (test :: T Int64 ))+ , testWithGen "Integer mixed" genInteger+ , testWithGen "Integer small" genIntegerSmall+ , testWithGen "Integer big" genIntegerBig - , ("Word", p (test :: T Word ))- , ("Int", p (test :: T Int ))- , ("Integer", p (test :: T Integer ))+ , test' "Fixed" (test :: T (Fixed.Fixed Fixed.E3) ) test #ifdef HAS_NATURAL- , ("Natural", prop_test_Natural )-#endif-#ifdef HAS_GHC_FINGERPRINT- , ("GHC.Fingerprint", prop_test_GHC_Fingerprint )+ , testWithGen "Natural mixed" genNatural+ , testWithGen "Natural small" genNaturalSmall+ , testWithGen "Natural big" genNaturalBig #endif-- , ("Float", p (test :: T Float ))- , ("Double", p (test :: T Double ))-- , ("Char", p (test :: T Char ))+ , testWithGen "GHC.Fingerprint" genFingerprint - , ("[()]", p (test :: T [()] ))- , ("[Word8]", p (test :: T [Word8] ))- , ("[Word32]", p (test :: T [Word32] ))- , ("[Word64]", p (test :: T [Word64] ))- , ("[Word]", p (test :: T [Word] ))- , ("[Int]", p (test :: T [Int] ))- , ("[Integer]", p (test :: T [Integer] ))- , ("String", p (test :: T String ))- , ("((), ())", p (test :: T ((), ()) ))- , ("(Word8, Word32)", p (test :: T (Word8, Word32) ))- , ("(Int8, Int32)", p (test :: T (Int8, Int32) ))- , ("(Int32, [Int])", p (test :: T (Int32, [Int]) ))+ , test' "Float" (test :: T Float ) test+ , test' "Double" (test :: T Double) test - , ("Maybe Int8", p (test :: T (Maybe Int8) ))- , ("Either Int8 Int16", p (test :: T (Either Int8 Int16) ))+ , test' "((), ())" (test :: T ((), ()) ) test+ , test' "(Word8, Word32)" (test :: T (Word8, Word32) ) test+ , test' "(Int8, Int32)" (test :: T (Int8, Int32) ) test+ , test' "(Int32, [Int])" (test :: T (Int32, [Int]) ) test+ , test' "Maybe Int8" (test :: T (Maybe Int8) ) test+ , test' "Either Int8 Int16" (test :: T (Either Int8 Int16) ) test - , ("(Int, ByteString)",- p (test :: T (Int, B.ByteString) ))- , ("[(Int, ByteString)]",- p (test :: T [(Int, B.ByteString)] ))+ , test' "(Int, ByteString)"+ (test :: T (Int, B.ByteString) ) test+ , test' "[(Int, ByteString)]"+ (test :: T [(Int, B.ByteString)] ) test - , ("(Maybe Int64, Bool, [Int])",- p (test :: T (Maybe Int64, Bool, [Int])))- , ("(Maybe Word8, Bool, [Int], Either Bool Word8)",- p (test :: T (Maybe Word8, Bool, [Int], Either Bool Word8) ))- , ("(Maybe Word16, Bool, [Int], Either Bool Word16, Int)",- p (test :: T (Maybe Word16, Bool, [Int], Either Bool Word16, Int) ))+ , test' "(Maybe Int64, Bool, [Int])"+ (test :: T (Maybe Int64, Bool, [Int])) test+ , test' "(Maybe Word8, Bool, [Int], Either Bool Word8)"+ (test :: T (Maybe Word8, Bool, [Int], Either Bool Word8)) test+ , test' "(Maybe Word16, Bool, [Int], Either Bool Word16, Int)"+ (test :: T (Maybe Word16, Bool, [Int], Either Bool Word16, Int)) test - , ("(Int,Int,Int,Int,Int,Int)",- p (test :: T (Int,Int,Int,Int,Int,Int)))- , ("(Int,Int,Int,Int,Int,Int,Int)",- p (test :: T (Int,Int,Int,Int,Int,Int,Int)))- , ("(Int,Int,Int,Int,Int,Int,Int,Int)",- p (test :: T (Int,Int,Int,Int,Int,Int,Int,Int)))- , ("(Int,Int,Int,Int,Int,Int,Int,Int,Int)",- p (test :: T (Int,Int,Int,Int,Int,Int,Int,Int,Int)))- , ("(Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)",- p (test :: T (Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)))+ , test' "(Int,Int,Int,Int,Int,Int)"+ (test :: T (Int,Int,Int,Int,Int,Int)) test+ , test' "(Int,Int,Int,Int,Int,Int,Int)"+ (test :: T (Int,Int,Int,Int,Int,Int,Int)) test+ , test' "(Int,Int,Int,Int,Int,Int,Int,Int)"+ (test :: T (Int,Int,Int,Int,Int,Int,Int,Int)) test+ , test' "(Int,Int,Int,Int,Int,Int,Int,Int,Int)"+ (test :: T (Int,Int,Int,Int,Int,Int,Int,Int,Int)) test+ , test' "(Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)"+ (test :: T (Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)) test - , ("B.ByteString", p (test :: T B.ByteString ))- , ("L.ByteString", p (test :: T L.ByteString ))+ , test' "B.ByteString" (test :: T B.ByteString) test+ , test' "L.ByteString" (test :: T L.ByteString) test+#if MIN_VERSION_bytestring(0,10,4)+ , test' "ShortByteString" (test :: T ShortByteString) test+#endif ] , testGroup "Invariants" $ map (uncurry testProperty)@@ -535,5 +697,17 @@ , ("[B.ByteString] invariant", p (prop_invariant :: B [B.ByteString] )) , ("L.ByteString invariant", p (prop_invariant :: B L.ByteString )) , ("[L.ByteString] invariant", p (prop_invariant :: B [L.ByteString] ))+#if MIN_VERSION_bytestring(0,10,4)+ , ("ShortByteString invariant", p (prop_invariant :: B ShortByteString ))+ , ("[ShortByteString] invariant", p (prop_invariant :: B [ShortByteString] ))+#endif ]+#ifdef HAS_FIXED_CONSTRUCTOR+ , testGroup "Fixed"+ [ testProperty "Serialisation same" $ p prop_fixed_ser+ , testProperty "MkFixed -> HasResolution" $ p prop_fixed_constr_resolution+ , testProperty "HasResolution -> MkFixed" $ p prop_fixed_resolution_constr+ ]+#endif+ , testTypeable ]
tools/derive/BinaryDerive.hs view
@@ -17,7 +17,7 @@ | nTypeChildren > 0 = wrap (join ", " (map ("Binary "++) typeLetters)) ++ " => " | otherwise = ""- inst = wrap $ tyConString typeName ++ concatMap (" "++) typeLetters+ inst = wrap $ tyConName typeName ++ concatMap (" "++) typeLetters wrap x = if nTypeChildren > 0 then "("++x++")" else x join sep lst = concat $ intersperse sep lst nTypeChildren = length typeChildren