diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # binary package # -[![Build Status](https://api.travis-ci.org/kolmodin/binary.png?branch=master)](http://travis-ci.org/kolmodin/binary) +[![Hackage version](https://img.shields.io/hackage/v/binary.svg?label=Hackage)](https://hackage.haskell.org/package/binary) [![Stackage version](https://www.stackage.org/package/binary/badge/lts?label=Stackage)](https://www.stackage.org/package/binary) [![Build Status](https://api.travis-ci.org/kolmodin/binary.png?branch=master)](http://travis-ci.org/kolmodin/binary) *Efficient, pure binary serialisation using lazy ByteStrings.* diff --git a/benchmarks/Builder.hs b/benchmarks/Builder.hs --- a/benchmarks/Builder.hs +++ b/benchmarks/Builder.hs @@ -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 diff --git a/benchmarks/Cabal24.hs b/benchmarks/Cabal24.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Cabal24.hs @@ -0,0 +1,360 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- | This module contains type definitions copied from Cabal-1.24.2.0 +-- to avoid a dependency on Cabal. Their contents for the benchmark are read +-- from a cache file using their 'Read' instance, see "GenericsBenchCache". +-- +module Cabal24 where + +import Data.Version (Version) +import GHC.Generics (Generic) +import Data.Map (Map) + +data Benchmark = Benchmark { + benchmarkName :: String, + benchmarkInterface :: BenchmarkInterface, + benchmarkBuildInfo :: BuildInfo, + benchmarkEnabled :: Bool + } deriving (Generic, Eq, Ord, Read, Show) + +data BenchmarkInterface = + BenchmarkExeV10 Version FilePath + | BenchmarkUnsupported BenchmarkType + deriving (Generic, Eq, Ord, Read, Show) + +data BenchmarkType = BenchmarkTypeExe Version + | BenchmarkTypeUnknown String Version + deriving (Generic, Eq, Ord, Read, Show) + +data BuildInfo = BuildInfo { + buildable :: Bool, + buildTools :: [Dependency], + cppOptions :: [String], + ccOptions :: [String], + ldOptions :: [String], + pkgconfigDepends :: [Dependency], + frameworks :: [String], + extraFrameworkDirs:: [String], + cSources :: [FilePath], + jsSources :: [FilePath], + hsSourceDirs :: [FilePath], + otherModules :: [ModuleName], + defaultLanguage :: Maybe Language, + otherLanguages :: [Language], + defaultExtensions :: [Extension], + otherExtensions :: [Extension], + oldExtensions :: [Extension], + extraLibs :: [String], + extraGHCiLibs :: [String], + extraLibDirs :: [String], + includeDirs :: [FilePath], + includes :: [FilePath], + installIncludes :: [FilePath], + options :: [(CompilerFlavor,[String])], + profOptions :: [(CompilerFlavor,[String])], + sharedOptions :: [(CompilerFlavor,[String])], + customFieldsBI :: [(String,String)], + targetBuildDepends :: [Dependency], + targetBuildRenaming :: Map PackageName ModuleRenaming + } deriving (Generic, Eq, Ord, Read, Show) + +data BuildType + = Simple + | Configure + | Make + | Custom + | UnknownBuildType String + deriving (Generic, Eq, Ord, Read, Show) + +data CompilerFlavor = GHC | GHCJS | NHC | YHC | Hugs | HBC | Helium + | JHC | LHC | UHC + | HaskellSuite String + | OtherCompiler String + deriving (Generic, Eq, Ord, Read, Show) + +data Dependency = Dependency PackageName VersionRange + deriving (Generic, Eq, Ord, Read, Show) + +data Executable = Executable { + exeName :: String, + modulePath :: FilePath, + buildInfo :: BuildInfo + } + deriving (Generic, Eq, Ord, Read, Show) + +data Extension = + EnableExtension KnownExtension + | DisableExtension KnownExtension + | UnknownExtension String + deriving (Generic, Eq, Ord, Read, Show) + +newtype FlagName = FlagName String + deriving (Generic, Eq, Ord, Read, Show) + +data KnownExtension = + OverlappingInstances + | UndecidableInstances + | IncoherentInstances + | DoRec + | RecursiveDo + | ParallelListComp + | MultiParamTypeClasses + | MonomorphismRestriction + | FunctionalDependencies + | Rank2Types + | RankNTypes + | PolymorphicComponents + | ExistentialQuantification + | ScopedTypeVariables + | PatternSignatures + | ImplicitParams + | FlexibleContexts + | FlexibleInstances + | EmptyDataDecls + | CPP + | KindSignatures + | BangPatterns + | TypeSynonymInstances + | TemplateHaskell + | ForeignFunctionInterface + | Arrows + | Generics + | ImplicitPrelude + | NamedFieldPuns + | PatternGuards + | GeneralizedNewtypeDeriving + | ExtensibleRecords + | RestrictedTypeSynonyms + | HereDocuments + | MagicHash + | TypeFamilies + | StandaloneDeriving + | UnicodeSyntax + | UnliftedFFITypes + | InterruptibleFFI + | CApiFFI + | LiberalTypeSynonyms + | TypeOperators + | RecordWildCards + | RecordPuns + | DisambiguateRecordFields + | TraditionalRecordSyntax + | OverloadedStrings + | GADTs + | GADTSyntax + | MonoPatBinds + | RelaxedPolyRec + | ExtendedDefaultRules + | UnboxedTuples + | DeriveDataTypeable + | DeriveGeneric + | DefaultSignatures + | InstanceSigs + | ConstrainedClassMethods + | PackageImports + | ImpredicativeTypes + | NewQualifiedOperators + | PostfixOperators + | QuasiQuotes + | TransformListComp + | MonadComprehensions + | ViewPatterns + | XmlSyntax + | RegularPatterns + | TupleSections + | GHCForeignImportPrim + | NPlusKPatterns + | DoAndIfThenElse + | MultiWayIf + | LambdaCase + | RebindableSyntax + | ExplicitForAll + | DatatypeContexts + | MonoLocalBinds + | DeriveFunctor + | DeriveTraversable + | DeriveFoldable + | NondecreasingIndentation + | SafeImports + | Safe + | Trustworthy + | Unsafe + | ConstraintKinds + | PolyKinds + | DataKinds + | ParallelArrays + | RoleAnnotations + | OverloadedLists + | EmptyCase + | AutoDeriveTypeable + | NegativeLiterals + | BinaryLiterals + | NumDecimals + | NullaryTypeClasses + | ExplicitNamespaces + | AllowAmbiguousTypes + | JavaScriptFFI + | PatternSynonyms + | PartialTypeSignatures + | NamedWildCards + | DeriveAnyClass + | DeriveLift + | StaticPointers + | StrictData + | Strict + | ApplicativeDo + | DuplicateRecordFields + | TypeApplications + | TypeInType + | UndecidableSuperClasses + | MonadFailDesugaring + | TemplateHaskellQuotes + | OverloadedLabels + deriving (Generic, Eq, Ord, Read, Show) + +data Language = + Haskell98 + | Haskell2010 + | UnknownLanguage String + deriving (Generic, Eq, Ord, Read, Show) + +data Library = Library { + exposedModules :: [ModuleName], + reexportedModules :: [ModuleReexport], + requiredSignatures:: [ModuleName], + exposedSignatures:: [ModuleName], + libExposed :: Bool, + libBuildInfo :: BuildInfo + } + deriving (Generic, Eq, Ord, Read, Show) + +data License = + GPL (Maybe Version) + | AGPL (Maybe Version) + | LGPL (Maybe Version) + | BSD2 + | BSD3 + | BSD4 + | MIT + | ISC + | MPL Version + | Apache (Maybe Version) + | PublicDomain + | AllRightsReserved + | UnspecifiedLicense + | OtherLicense + | UnknownLicense String + deriving (Generic, Eq, Ord, Read, Show) + +newtype ModuleName = ModuleName [String] + deriving (Generic, Eq, Ord, Read, Show) + +data ModuleReexport = ModuleReexport { + moduleReexportOriginalPackage :: Maybe PackageName, + moduleReexportOriginalName :: ModuleName, + moduleReexportName :: ModuleName + } deriving (Generic, Eq, Ord, Read, Show) + +data ModuleRenaming = ModuleRenaming Bool [(ModuleName, ModuleName)] + deriving (Generic, Eq, Ord, Read, Show) + +data PackageDescription + = PackageDescription { + package :: PackageIdentifier, + license :: License, + licenseFiles :: [FilePath], + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + testedWith :: [(CompilerFlavor,VersionRange)], + homepage :: String, + pkgUrl :: String, + bugReports :: String, + sourceRepos :: [SourceRepo], + synopsis :: String, + description :: String, + category :: String, + customFieldsPD :: [(String,String)], + buildDepends :: [Dependency], + specVersionRaw :: Either Version VersionRange, + buildType :: Maybe BuildType, + setupBuildInfo :: Maybe SetupBuildInfo, + library :: Maybe Library, + executables :: [Executable], + testSuites :: [TestSuite], + benchmarks :: [Benchmark], + dataFiles :: [FilePath], + dataDir :: FilePath, + extraSrcFiles :: [FilePath], + extraTmpFiles :: [FilePath], + extraDocFiles :: [FilePath] + } deriving (Generic, Eq, Ord, Read, Show) + +data PackageIdentifier + = PackageIdentifier { + pkgName :: PackageName, + pkgVersion :: Version + } + deriving (Generic, Eq, Ord, Read, Show) + +newtype PackageName = PackageName { unPackageName :: String } + deriving (Generic, Eq, Ord, Read, Show) + +data RepoKind = + RepoHead + | RepoThis + | RepoKindUnknown String + deriving (Generic, Eq, Ord, Read, Show) + +data RepoType = Darcs | Git | SVN | CVS + | Mercurial | GnuArch | Bazaar | Monotone + | OtherRepoType String + deriving (Generic, Eq, Ord, Read, Show) + +data SetupBuildInfo = SetupBuildInfo { + setupDepends :: [Dependency], + defaultSetupDepends :: Bool + } + deriving (Generic, Eq, Ord, Read, Show) + +data SourceRepo = SourceRepo { + repoKind :: RepoKind, + repoType :: Maybe RepoType, + repoLocation :: Maybe String, + repoModule :: Maybe String, + repoBranch :: Maybe String, + repoTag :: Maybe String, + repoSubdir :: Maybe FilePath +} + deriving (Generic, Eq, Ord, Read, Show) + +data TestSuite = TestSuite { + testName :: String, + testInterface :: TestSuiteInterface, + testBuildInfo :: BuildInfo, + testEnabled :: Bool + } + deriving (Generic, Eq, Ord, Read, Show) + +data TestSuiteInterface = + TestSuiteExeV10 Version FilePath + | TestSuiteLibV09 Version ModuleName + | TestSuiteUnsupported TestType + deriving (Generic, Eq, Ord, Read, Show) + +data TestType = TestTypeExe Version + | TestTypeLib Version + | TestTypeUnknown String Version + deriving (Generic, Eq, Ord, Read, Show) + +data VersionRange + = AnyVersion + | ThisVersion Version + | LaterVersion Version + | EarlierVersion Version + | WildcardVersion Version + | UnionVersionRanges VersionRange VersionRange + | IntersectVersionRanges VersionRange VersionRange + | VersionRangeParens VersionRange + deriving (Generic, Eq, Ord, Read, Show) diff --git a/benchmarks/GenericsBench.hs b/benchmarks/GenericsBench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/GenericsBench.hs @@ -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]) diff --git a/benchmarks/GenericsBenchCache.hs b/benchmarks/GenericsBenchCache.hs new file mode 100644 --- /dev/null +++ b/benchmarks/GenericsBenchCache.hs @@ -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" diff --git a/benchmarks/GenericsBenchTypes.hs b/benchmarks/GenericsBenchTypes.hs new file mode 100644 --- /dev/null +++ b/benchmarks/GenericsBenchTypes.hs @@ -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 diff --git a/benchmarks/Get.hs b/benchmarks/Get.hs --- a/benchmarks/Get.hs +++ b/benchmarks/Get.hs @@ -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 diff --git a/benchmarks/Put.hs b/benchmarks/Put.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Put.hs @@ -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 diff --git a/binary.cabal b/binary.cabal --- a/binary.cabal +++ b/binary.cabal @@ -1,5 +1,5 @@ name: binary -version: 0.7.6.1 +version: 0.10.0.0 license: BSD3 license-file: LICENSE author: Lennart Kolmodin @@ -18,7 +18,7 @@ stability: provisional build-type: Simple cabal-version: >= 1.8 -tested-with: GHC == 7.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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 -------------- diff --git a/src/Data/Binary.hs b/src/Data/Binary.hs --- a/src/Data/Binary.hs +++ b/src/Data/Binary.hs @@ -1,7 +1,5 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Binary @@ -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 diff --git a/src/Data/Binary/Builder.hs b/src/Data/Binary/Builder.hs --- a/src/Data/Binary/Builder.hs +++ b/src/Data/Binary/Builder.hs @@ -1,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 -- 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 #-} diff --git a/src/Data/Binary/Builder/Base.hs b/src/Data/Binary/Builder/Base.hs deleted file mode 100644 --- a/src/Data/Binary/Builder/Base.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Binary/Builder/Internal.hs b/src/Data/Binary/Builder/Internal.hs deleted file mode 100644 --- a/src/Data/Binary/Builder/Internal.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Binary/Class.hs b/src/Data/Binary/Class.hs --- a/src/Data/Binary/Class.hs +++ b/src/Data/Binary/Class.hs @@ -1,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 + diff --git a/src/Data/Binary/FloatCast.hs b/src/Data/Binary/FloatCast.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/FloatCast.hs @@ -0,0 +1,45 @@ + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} + +-- | This module was written based on +-- . +-- +-- Implements casting via a 1-elemnt STUArray, as described in +-- . +module Data.Binary.FloatCast + ( floatToWord + , wordToFloat + , doubleToWord + , wordToDouble + ) where + +import Data.Word (Word32, Word64) +import Data.Array.ST (newArray, readArray, MArray, STUArray) +import Data.Array.Unsafe (castSTUArray) +import GHC.ST (runST, ST) + +-- | Reinterpret-casts a `Float` to a `Word32`. +floatToWord :: Float -> Word32 +floatToWord x = runST (cast x) +{-# INLINE floatToWord #-} + +-- | Reinterpret-casts a `Word32` to a `Float`. +wordToFloat :: Word32 -> Float +wordToFloat x = runST (cast x) +{-# INLINE wordToFloat #-} + +-- | Reinterpret-casts a `Double` to a `Word64`. +doubleToWord :: Double -> Word64 +doubleToWord x = runST (cast x) +{-# INLINE doubleToWord #-} + +-- | Reinterpret-casts a `Word64` to a `Double`. +wordToDouble :: Word64 -> Double +wordToDouble x = runST (cast x) +{-# INLINE wordToDouble #-} + +cast :: (MArray (STUArray s) a (ST s), + MArray (STUArray s) b (ST s)) => a -> ST s b +cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0 +{-# INLINE cast #-} diff --git a/src/Data/Binary/Generic.hs b/src/Data/Binary/Generic.hs --- a/src/Data/Binary/Generic.hs +++ b/src/Data/Binary/Generic.hs @@ -1,10 +1,12 @@ {-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures, ScopedTypeVariables, TypeOperators, TypeSynonymInstances #-} -#if __GLASGOW_HASKELL__ >= 701 && __GLASGOW_HASKELL__ != 702 {-# LANGUAGE Safe #-} -#endif {-# OPTIONS_GHC -fno-warn-orphans #-} +#if __GLASGOW_HASKELL__ >= 800 +#define HAS_DATA_KIND +#endif + ----------------------------------------------------------------------------- -- | -- Module : Data.Binary.Generic @@ -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) + diff --git a/src/Data/Binary/Get.hs b/src/Data/Binary/Get.hs --- a/src/Data/Binary/Get.hs +++ b/src/Data/Binary/Get.hs @@ -1,7 +1,5 @@ {-# LANGUAGE CPP, RankNTypes, MagicHash, BangPatterns #-} -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} -#endif #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) #include "MachDeps.h" @@ -43,7 +41,7 @@ -- The fields in @Trade@ are marked as strict (using @!@) since we don't need -- laziness here. In practise, you would probably consider using the UNPACK -- pragma as well. --- +-- -- -- Now, let's have a look at a decoder for this format. -- @@ -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) diff --git a/src/Data/Binary/Get/Internal.hs b/src/Data/Binary/Get/Internal.hs --- a/src/Data/Binary/Get/Internal.hs +++ b/src/Data/Binary/Get/Internal.hs @@ -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 #-} diff --git a/src/Data/Binary/Internal.hs b/src/Data/Binary/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Internal.hs @@ -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 diff --git a/src/Data/Binary/Put.hs b/src/Data/Binary/Put.hs --- a/src/Data/Binary/Put.hs +++ b/src/Data/Binary/Put.hs @@ -1,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 #-} diff --git a/tests/Action.hs b/tests/Action.hs --- a/tests/Action.hs +++ b/tests/Action.hs @@ -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] diff --git a/tests/Arbitrary.hs b/tests/Arbitrary.hs --- a/tests/Arbitrary.hs +++ b/tests/Arbitrary.hs @@ -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 diff --git a/tests/File.hs b/tests/File.hs --- a/tests/File.hs +++ b/tests/File.hs @@ -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) diff --git a/tests/QC.hs b/tests/QC.hs --- a/tests/QC.hs +++ b/tests/QC.hs @@ -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 ] diff --git a/tools/derive/BinaryDerive.hs b/tools/derive/BinaryDerive.hs --- a/tools/derive/BinaryDerive.hs +++ b/tools/derive/BinaryDerive.hs @@ -17,7 +17,7 @@ | nTypeChildren > 0 = wrap (join ", " (map ("Binary "++) typeLetters)) ++ " => " | otherwise = "" - inst = wrap $ tyConString typeName ++ concatMap (" "++) typeLetters + inst = wrap $ tyConName typeName ++ concatMap (" "++) typeLetters wrap x = if nTypeChildren > 0 then "("++x++")" else x join sep lst = concat $ intersperse sep lst nTypeChildren = length typeChildren