binary 0.5.1.1 → 0.10.0.0
raw patch · 37 files changed
Files
- .gitignore +0/−14
- README +0/−74
- README.md +93/−0
- TODO +0/−28
- benchmarks/Benchmark.hs +4/−1
- benchmarks/Builder.hs +15/−14
- benchmarks/Cabal24.hs +360/−0
- benchmarks/GenericsBench.hs +52/−0
- benchmarks/GenericsBenchCache.hs +40/−0
- benchmarks/GenericsBenchTypes.hs +35/−0
- benchmarks/Get.hs +381/−0
- benchmarks/Makefile +0/−23
- benchmarks/MemBench.hs +2/−2
- benchmarks/Put.hs +178/−0
- binary.cabal +243/−36
- changelog.md +183/−0
- index.html +0/−161
- src/Data/Binary.hs +94/−567
- src/Data/Binary/Builder.hs +226/−9
- src/Data/Binary/Builder/Base.hs +0/−512
- src/Data/Binary/Builder/Internal.hs +0/−28
- src/Data/Binary/Class.hs +1022/−0
- src/Data/Binary/FloatCast.hs +45/−0
- src/Data/Binary/Generic.hs +157/−0
- src/Data/Binary/Get.hs +516/−389
- src/Data/Binary/Get/Internal.hs +430/−0
- src/Data/Binary/Internal.hs +15/−0
- src/Data/Binary/Put.hs +200/−19
- tests/Action.hs +406/−0
- tests/Arbitrary.hs +23/−0
- tests/File.hs +43/−0
- tests/Makefile +0/−16
- tests/Parallel.hs +0/−147
- tests/QC.hs +622/−153
- tests/QuickCheckUtils.hs +0/−258
- tools/derive/BinaryDerive.hs +3/−3
- tools/derive/Example.hs +27/−23
− .gitignore
@@ -1,14 +0,0 @@-*.hi-*.o-*.p_hi-*.prof-*.tix-.hpc/-/benchmarks/bench-/benchmarks/builder-/dist/*-/tests/qc-GNUmakefile-dist-boot-dist-install-ghc.mk
− README
@@ -1,74 +0,0 @@-- binary: efficient, pure binary serialisation using lazy ByteStrings---------------------------------------------------------------------------The 'binary' package provides Data.Binary, containing the Binary class,-and associated methods, for serialising values to and from lazy-ByteStrings. --A key feature of 'binary' is that the interface is both pure, and efficient.--The 'binary' package is portable to GHC and Hugs.--Building:-- runhaskell Setup.lhs configure- runhaskell Setup.lhs build- runhaskell Setup.lhs install--First:- import Data.Binary--and then write an instance of Binary for the type you wish to serialise.-More information in the haddock documentation.--Deriving:--It is possible to mechanically derive new instances of Binary for your-types, if they support the Data and Typeable classes. A script is-provided in tools/derive. Here's an example of its use.-- $ cd binary - $ cd tools/derive -- $ ghci -fglasgow-exts BinaryDerive.hs-- *BinaryDerive> :l Example.hs -- *Main> deriveM (undefined :: Drinks)-- instance Binary Main.Drinks where- put (Beer a) = putWord8 0 >> put a- put Coffee = putWord8 1- put Tea = putWord8 2- put EnergyDrink = putWord8 3- put Water = putWord8 4- put Wine = putWord8 5- put Whisky = putWord8 6- get = do- tag_ <- getWord8- case tag_ of- 0 -> get >>= \a -> return (Beer a)- 1 -> return Coffee- 2 -> return Tea- 3 -> return EnergyDrink- 4 -> return Water- 5 -> return Wine- 6 -> return Whisky--Contributors:-- Lennart Kolmodin- Duncan Coutts- Don Stewart- Spencer Janssen- David Himmelstrup- Björn Bringert- Ross Paterson- Einar Karttunen- John Meacham- Ulf Norell- Tomasz Zielonka- Stefan Karrmann- Bryan O'Sullivan- Florian Weimer
+ README.md view
@@ -0,0 +1,93 @@+# binary package #++[](https://hackage.haskell.org/package/binary) [](https://www.stackage.org/package/binary) [](http://travis-ci.org/kolmodin/binary)++*Efficient, pure binary serialisation using lazy ByteStrings.*++The ``binary`` package provides Data.Binary, containing the Binary class,+and associated methods, for serialising values to and from lazy+ByteStrings. +A key feature of ``binary`` is that the interface is both pure, and efficient.+The ``binary`` package is portable to GHC and Hugs.++## Installing binary from Hackage ##++``binary`` is part of The Glasgow Haskell Compiler (GHC) and therefore if you+have either GHC or [The Haskell Platform](http://www.haskell.org/platform/)+installed, you already have ``binary``.++More recent versions of ``binary`` than you might have installed may be+available. You can use ``cabal-install`` to install a later version from+[Hackage](http://hackage.haskell.org/package/binary).++ $ cabal update+ $ cabal install binary++## Building binary ##++``binary`` comes with both a test suite and a set of benchmarks.+While developing, you probably want to enable both.+Here's how to get the latest version of the repository, configure and build.++ $ git clone git@github.com:kolmodin/binary.git+ $ cd binary+ $ cabal update+ $ cabal configure --enable-tests --enable-benchmarks+ $ cabal build++Run the test suite.++ $ cabal test++## Using binary ##++First:++ import Data.Binary++and then write an instance of Binary for the type you wish to serialise.+An example doing exactly this can be found in the Data.Binary module.+You can also use the Data.Binary.Builder module to efficiently build+lazy bytestrings using the ``Builder`` monoid. Or, alternatively, the+Data.Binary.Get and Data.Binary.Put to serialize/deserialize using+the ``Get`` and ``Put`` monads.++More information in the haddock documentation.++## Deriving binary instances using GHC's Generic ##++Beginning with GHC 7.2, it is possible to use binary serialization without+writing any instance boilerplate code.++```haskell+{-# LANGUAGE DeriveGeneric #-}++import Data.Binary+import GHC.Generics (Generic)++data Foo = Foo deriving (Generic)++-- GHC will automatically fill out the instance+instance Binary Foo+```++## Contributors ##++* Lennart Kolmodin+* Duncan Coutts+* Don Stewart+* Spencer Janssen+* David Himmelstrup+* Björn Bringert+* Ross Paterson+* Einar Karttunen+* John Meacham+* Ulf Norell+* Tomasz Zielonka+* Stefan Karrmann+* Bryan O'Sullivan+* Bas van Dijk+* Florian Weimer++For a full list of contributors, see+[here](https://github.com/kolmodin/binary/graphs/contributors).
− TODO
@@ -1,28 +0,0 @@-layer handling:-- bit packing- state parameters- string pools-- reading structures from the end of a stream, seek/tell behaviour--seek based protocols are too hard. - hGetContents/ interleaving.--user requests:-- get remaining bytestring after a runGet-- some kind of lookahead, or restoring parsing state, or something with- equal functionality. make it another layer on top?-- getLazyByteString takes an Int, which in Haskell98 is only guarantied to- be 29 bits, ie. 512 mb.- maybe we should have a readN64 for allowing reading of larger stuff?- (which could be implemented with readN on 64bit machines)- reference: bringerts tar archive decoder would be limitid to 0.5GB- files, alt. 2GB in GHC--SYB-deriving--investigate the UArray instance, it does not seem to compile in GHC 6.4
benchmarks/Benchmark.hs view
@@ -22,7 +22,10 @@ main :: IO () main = do- mb <- getArgs >>= readIO . head+ args <- getArgs+ mb <- case args of+ (arg:_) -> readIO arg+ _ -> return 100 memBench (mb*10) putStrLn "" putStrLn "Binary (de)serialisation benchmarks:"
benchmarks/Builder.hs view
@@ -6,30 +6,29 @@ 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.Config-import Criterion.Main hiding (run)+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 -instance NFData S.ByteString--data B = forall a. NFData a => B a--instance NFData B where- rnf (B b) = rnf b- main :: IO ()-main = defaultMainWith defaultConfig- (liftIO . evaluate $ rnf [B word8s, B smallByteString, B largeByteString])+main = do+ evaluate $ rnf+ [ rnf word8s+ , rnf smallByteString+ , rnf largeByteString+ ]+ defaultMain [ -- Test GHC loop optimization of continuation based code. bench "[Word8]" $ whnf (run . fromWord8s) word8s @@ -81,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 =@@ -190,7 +189,9 @@ ------------------------------------------------------------------------ -- Utilities +#if !MIN_VERSION_base(4,11,0) infixr 6 <> (<>) :: Monoid m => m -> m -> m (<>) = mappend+#endif
+ benchmarks/Cabal24.hs view
@@ -0,0 +1,360 @@+{-# LANGUAGE DeriveGeneric #-}++-- | This module contains type definitions copied from Cabal-1.24.2.0+-- to avoid a dependency on Cabal. Their contents for the benchmark are read+-- from a cache file using their 'Read' instance, see "GenericsBenchCache".+--+module Cabal24 where++import Data.Version (Version)+import GHC.Generics (Generic)+import Data.Map (Map)++data Benchmark = Benchmark {+ benchmarkName :: String,+ benchmarkInterface :: BenchmarkInterface,+ benchmarkBuildInfo :: BuildInfo,+ benchmarkEnabled :: Bool+ } deriving (Generic, Eq, Ord, Read, Show)++data BenchmarkInterface =+ BenchmarkExeV10 Version FilePath+ | BenchmarkUnsupported BenchmarkType+ deriving (Generic, Eq, Ord, Read, Show)++data BenchmarkType = BenchmarkTypeExe Version+ | BenchmarkTypeUnknown String Version+ deriving (Generic, Eq, Ord, Read, Show)++data BuildInfo = BuildInfo {+ buildable :: Bool,+ buildTools :: [Dependency],+ cppOptions :: [String],+ ccOptions :: [String],+ ldOptions :: [String],+ pkgconfigDepends :: [Dependency],+ frameworks :: [String],+ extraFrameworkDirs:: [String],+ cSources :: [FilePath],+ jsSources :: [FilePath],+ hsSourceDirs :: [FilePath],+ otherModules :: [ModuleName],+ defaultLanguage :: Maybe Language,+ otherLanguages :: [Language],+ defaultExtensions :: [Extension],+ otherExtensions :: [Extension],+ oldExtensions :: [Extension],+ extraLibs :: [String],+ extraGHCiLibs :: [String],+ extraLibDirs :: [String],+ includeDirs :: [FilePath],+ includes :: [FilePath],+ installIncludes :: [FilePath],+ options :: [(CompilerFlavor,[String])],+ profOptions :: [(CompilerFlavor,[String])],+ sharedOptions :: [(CompilerFlavor,[String])],+ customFieldsBI :: [(String,String)],+ targetBuildDepends :: [Dependency],+ targetBuildRenaming :: Map PackageName ModuleRenaming+ } deriving (Generic, Eq, Ord, Read, Show)++data BuildType+ = Simple+ | Configure+ | Make+ | Custom+ | UnknownBuildType String+ deriving (Generic, Eq, Ord, Read, Show)++data CompilerFlavor = GHC | GHCJS | NHC | YHC | Hugs | HBC | Helium+ | JHC | LHC | UHC+ | HaskellSuite String+ | OtherCompiler String+ deriving (Generic, Eq, Ord, Read, Show)++data Dependency = Dependency PackageName VersionRange+ deriving (Generic, Eq, Ord, Read, Show)++data Executable = Executable {+ exeName :: String,+ modulePath :: FilePath,+ buildInfo :: BuildInfo+ }+ deriving (Generic, Eq, Ord, Read, Show)++data Extension =+ EnableExtension KnownExtension+ | DisableExtension KnownExtension+ | UnknownExtension String+ deriving (Generic, Eq, Ord, Read, Show)++newtype FlagName = FlagName String+ deriving (Generic, Eq, Ord, Read, Show)++data KnownExtension =+ OverlappingInstances+ | UndecidableInstances+ | IncoherentInstances+ | DoRec+ | RecursiveDo+ | ParallelListComp+ | MultiParamTypeClasses+ | MonomorphismRestriction+ | FunctionalDependencies+ | Rank2Types+ | RankNTypes+ | PolymorphicComponents+ | ExistentialQuantification+ | ScopedTypeVariables+ | PatternSignatures+ | ImplicitParams+ | FlexibleContexts+ | FlexibleInstances+ | EmptyDataDecls+ | CPP+ | KindSignatures+ | BangPatterns+ | TypeSynonymInstances+ | TemplateHaskell+ | ForeignFunctionInterface+ | Arrows+ | Generics+ | ImplicitPrelude+ | NamedFieldPuns+ | PatternGuards+ | GeneralizedNewtypeDeriving+ | ExtensibleRecords+ | RestrictedTypeSynonyms+ | HereDocuments+ | MagicHash+ | TypeFamilies+ | StandaloneDeriving+ | UnicodeSyntax+ | UnliftedFFITypes+ | InterruptibleFFI+ | CApiFFI+ | LiberalTypeSynonyms+ | TypeOperators+ | RecordWildCards+ | RecordPuns+ | DisambiguateRecordFields+ | TraditionalRecordSyntax+ | OverloadedStrings+ | GADTs+ | GADTSyntax+ | MonoPatBinds+ | RelaxedPolyRec+ | ExtendedDefaultRules+ | UnboxedTuples+ | DeriveDataTypeable+ | DeriveGeneric+ | DefaultSignatures+ | InstanceSigs+ | ConstrainedClassMethods+ | PackageImports+ | ImpredicativeTypes+ | NewQualifiedOperators+ | PostfixOperators+ | QuasiQuotes+ | TransformListComp+ | MonadComprehensions+ | ViewPatterns+ | XmlSyntax+ | RegularPatterns+ | TupleSections+ | GHCForeignImportPrim+ | NPlusKPatterns+ | DoAndIfThenElse+ | MultiWayIf+ | LambdaCase+ | RebindableSyntax+ | ExplicitForAll+ | DatatypeContexts+ | MonoLocalBinds+ | DeriveFunctor+ | DeriveTraversable+ | DeriveFoldable+ | NondecreasingIndentation+ | SafeImports+ | Safe+ | Trustworthy+ | Unsafe+ | ConstraintKinds+ | PolyKinds+ | DataKinds+ | ParallelArrays+ | RoleAnnotations+ | OverloadedLists+ | EmptyCase+ | AutoDeriveTypeable+ | NegativeLiterals+ | BinaryLiterals+ | NumDecimals+ | NullaryTypeClasses+ | ExplicitNamespaces+ | AllowAmbiguousTypes+ | JavaScriptFFI+ | PatternSynonyms+ | PartialTypeSignatures+ | NamedWildCards+ | DeriveAnyClass+ | DeriveLift+ | StaticPointers+ | StrictData+ | Strict+ | ApplicativeDo+ | DuplicateRecordFields+ | TypeApplications+ | TypeInType+ | UndecidableSuperClasses+ | MonadFailDesugaring+ | TemplateHaskellQuotes+ | OverloadedLabels+ deriving (Generic, Eq, Ord, Read, Show)++data Language =+ Haskell98+ | Haskell2010+ | UnknownLanguage String+ deriving (Generic, Eq, Ord, Read, Show)++data Library = Library {+ exposedModules :: [ModuleName],+ reexportedModules :: [ModuleReexport],+ requiredSignatures:: [ModuleName],+ exposedSignatures:: [ModuleName],+ libExposed :: Bool,+ libBuildInfo :: BuildInfo+ }+ deriving (Generic, Eq, Ord, Read, Show)++data License =+ GPL (Maybe Version)+ | AGPL (Maybe Version)+ | LGPL (Maybe Version)+ | BSD2+ | BSD3+ | BSD4+ | MIT+ | ISC+ | MPL Version+ | Apache (Maybe Version)+ | PublicDomain+ | AllRightsReserved+ | UnspecifiedLicense+ | OtherLicense+ | UnknownLicense String+ deriving (Generic, Eq, Ord, Read, Show)++newtype ModuleName = ModuleName [String]+ deriving (Generic, Eq, Ord, Read, Show)++data ModuleReexport = ModuleReexport {+ moduleReexportOriginalPackage :: Maybe PackageName,+ moduleReexportOriginalName :: ModuleName,+ moduleReexportName :: ModuleName+ } deriving (Generic, Eq, Ord, Read, Show)++data ModuleRenaming = ModuleRenaming Bool [(ModuleName, ModuleName)]+ deriving (Generic, Eq, Ord, Read, Show)++data PackageDescription+ = PackageDescription {+ package :: PackageIdentifier,+ license :: License,+ licenseFiles :: [FilePath],+ copyright :: String,+ maintainer :: String,+ author :: String,+ stability :: String,+ testedWith :: [(CompilerFlavor,VersionRange)],+ homepage :: String,+ pkgUrl :: String,+ bugReports :: String,+ sourceRepos :: [SourceRepo],+ synopsis :: String,+ description :: String,+ category :: String,+ customFieldsPD :: [(String,String)],+ buildDepends :: [Dependency],+ specVersionRaw :: Either Version VersionRange,+ buildType :: Maybe BuildType,+ setupBuildInfo :: Maybe SetupBuildInfo,+ library :: Maybe Library,+ executables :: [Executable],+ testSuites :: [TestSuite],+ benchmarks :: [Benchmark],+ dataFiles :: [FilePath],+ dataDir :: FilePath,+ extraSrcFiles :: [FilePath],+ extraTmpFiles :: [FilePath],+ extraDocFiles :: [FilePath]+ } deriving (Generic, Eq, Ord, Read, Show)++data PackageIdentifier+ = PackageIdentifier {+ pkgName :: PackageName,+ pkgVersion :: Version+ }+ deriving (Generic, Eq, Ord, Read, Show)++newtype PackageName = PackageName { unPackageName :: String }+ deriving (Generic, Eq, Ord, Read, Show)++data RepoKind =+ RepoHead+ | RepoThis+ | RepoKindUnknown String+ deriving (Generic, Eq, Ord, Read, Show)++data RepoType = Darcs | Git | SVN | CVS+ | Mercurial | GnuArch | Bazaar | Monotone+ | OtherRepoType String+ deriving (Generic, Eq, Ord, Read, Show)++data SetupBuildInfo = SetupBuildInfo {+ setupDepends :: [Dependency],+ defaultSetupDepends :: Bool+ }+ deriving (Generic, Eq, Ord, Read, Show)++data SourceRepo = SourceRepo {+ repoKind :: RepoKind,+ repoType :: Maybe RepoType,+ repoLocation :: Maybe String,+ repoModule :: Maybe String,+ repoBranch :: Maybe String,+ repoTag :: Maybe String,+ repoSubdir :: Maybe FilePath+}+ deriving (Generic, Eq, Ord, Read, Show)++data TestSuite = TestSuite {+ testName :: String,+ testInterface :: TestSuiteInterface,+ testBuildInfo :: BuildInfo,+ testEnabled :: Bool+ }+ deriving (Generic, Eq, Ord, Read, Show)++data TestSuiteInterface =+ TestSuiteExeV10 Version FilePath+ | TestSuiteLibV09 Version ModuleName+ | TestSuiteUnsupported TestType+ deriving (Generic, Eq, Ord, Read, Show)++data TestType = TestTypeExe Version+ | TestTypeLib Version+ | TestTypeUnknown String Version+ deriving (Generic, Eq, Ord, Read, Show)++data VersionRange+ = AnyVersion+ | ThisVersion Version+ | LaterVersion Version+ | EarlierVersion Version+ | WildcardVersion Version+ | UnionVersionRanges VersionRange VersionRange+ | IntersectVersionRanges VersionRange VersionRange+ | VersionRangeParens VersionRange+ deriving (Generic, Eq, Ord, Read, Show)
+ benchmarks/GenericsBench.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DeriveGeneric, StandaloneDeriving, BangPatterns #-}+module Main where++import qualified Data.ByteString.Lazy as L+import Cabal24 (PackageDescription)++import Criterion.Main++import qualified Data.Binary as Binary+import Data.Binary.Get (Get)+import qualified Data.Binary.Get as Binary++import GenericsBenchCache++main :: IO ()+main = benchmark =<< readPackageDescriptionCache 100++benchmark :: [PackageDescription] -> IO ()+benchmark pds = do+ let lbs = encode pds+ !_ = L.length lbs+ str = show pds+ !_ = length str+ defaultMain [+ bench "encode" (nf encode pds)+ , bench "decode" (nf decode lbs)+ , bench "decode null" (nf decodeNull lbs)+ , bgroup "embarrassment" [+ bench "read" (nf readPackageDescription str)+ , bench "show" (nf show pds)+ ]+ ]++encode :: [PackageDescription] -> L.ByteString+encode = Binary.encode++decode :: L.ByteString -> Int+decode = length . (Binary.decode :: L.ByteString -> [PackageDescription])++decodeNull :: L.ByteString -> ()+decodeNull =+ Binary.runGet $ do+ n <- Binary.get :: Get Int+ go n+ where+ go 0 = return ()+ go i = do+ x <- Binary.get :: Get PackageDescription+ x `seq` go (i-1)++readPackageDescription :: String -> Int+readPackageDescription = length . (read :: String -> [PackageDescription])
+ benchmarks/GenericsBenchCache.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DeriveGeneric, StandaloneDeriving, BangPatterns, CPP #-}+module GenericsBenchCache (readPackageDescriptionCache) where++import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as LC8+import qualified Codec.Compression.GZip as GZip++import Cabal24 (PackageDescription)++import System.Directory+import System.Exit++import GenericsBenchTypes ()++#if ! MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++readPackageDescriptionCache :: Int -> IO [PackageDescription]+readPackageDescriptionCache amount = do+ cacheExists <- doesFileExist cacheFilePath+ bs <-+ if cacheExists+ then do+ putStrLn "reading the cache file, might take a moment..."+ L.readFile cacheFilePath+ else do+ -- In older versions of this benchmark, there was machinery to+ -- regenerate the cache using the data in @~/.cabal@. Now the cache is+ -- simply stored in the repo to avoid a dependency on Cabal the library.+ putStrLn (cacheFilePath ++ " missing, aborting")+ exitFailure+ let str = LC8.unpack (GZip.decompress bs)+ pds = take amount (read str)+ -- PackageDescription doesn't implement NFData, let's force with the following line+ (length (show pds)) `seq` putStrLn "done reading the cache file"+ return pds++cacheFilePath :: String+cacheFilePath = "generics-bench.cache.gz"
+ benchmarks/GenericsBenchTypes.hs view
@@ -0,0 +1,35 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module GenericsBenchTypes where++import Cabal24+import Generics.Deriving.Instances ()+import Data.Binary++instance Binary Benchmark+instance Binary BenchmarkInterface+instance Binary BenchmarkType+instance Binary BuildInfo+instance Binary BuildType+instance Binary CompilerFlavor+instance Binary Dependency+instance Binary Executable+instance Binary Extension+instance Binary FlagName+instance Binary KnownExtension+instance Binary Language+instance Binary Library+instance Binary License+instance Binary ModuleName+instance Binary ModuleReexport+instance Binary ModuleRenaming+instance Binary PackageDescription+instance Binary PackageIdentifier+instance Binary PackageName+instance Binary RepoKind+instance Binary RepoType+instance Binary SetupBuildInfo+instance Binary SourceRepo+instance Binary TestSuite+instance Binary TestSuiteInterface+instance Binary TestType+instance Binary VersionRange
+ benchmarks/Get.hs view
@@ -0,0 +1,381 @@+{-# LANGUAGE CPP, OverloadedStrings, ExistentialQuantification, BangPatterns #-}++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+#include "MachDeps.h"+#endif++module Main where++import Control.DeepSeq+import Control.Exception (evaluate)+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.List (foldl')++import Control.Applicative+import Data.Binary+import Data.Binary.Get++import qualified Data.Serialize.Get as Cereal++import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.ByteString.Lazy as AL++#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 [+ rnf brackets,+ rnf bracketsInChunks,+ rnf bracketCount,+ rnf oneMegabyte,+ rnf oneMegabyteLBS,+ rnf manyBytes,+ rnf encodedBigInteger+ ]+ defaultMain+ [ 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)++-- Defs.++oneMegabyte :: S.ByteString+oneMegabyte = S.replicate mega $ fromIntegral $ ord 'a'++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 = "((()((()()))((()(()()()()()()()(((()()()()(()()(()(()())))))()((())())))()())(((())())(()))))()(()))"+ chunksOfBrackets = 102400 `div` S.length oneChunk++bracketParser :: Get Int+bracketParser = cont <|> return 0+ where+ cont = do v <- some ( do 40 <- getWord8+ n <- many cont+ 41 <- getWord8+ return $! sum n + 1)+ return $! sum v++bracketParser_cereal :: Cereal.Get Int+bracketParser_cereal = cont <|> return 0+ where+ cont = do v <- some ( do 40 <- Cereal.getWord8+ n <- many cont+ 41 <- Cereal.getWord8+ return $! sum n + 1)+ return $! sum v++bracketParser_atto :: A.Parser Int+bracketParser_atto = cont <|> return 0+ where+ cont = do v <- some ( do _ <- A.word8 40+ n <- bracketParser_atto+ _ <- A.word8 41+ return $! n + 1)+ return $! sum v++-- Strict struct of 4 Word8s+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+ !w0 <- getWord8+ !w1 <- getWord8+ !w2 <- getWord8+ !w3 <- getWord8+ 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+ !w0 <- Cereal.getWord8+ !w1 <- Cereal.getWord8+ !w2 <- Cereal.getWord8+ !w3 <- Cereal.getWord8+ 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+ !w0 <- A.anyWord8+ !w1 <- A.anyWord8+ !w2 <- A.anyWord8+ !w3 <- A.anyWord8+ let !s = S4 w0 w1 w2 w3+ loop (s : acc) (n - 4)++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)++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)++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)++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+ let !v = S2 s0 s1+ loop (v:s) (n-2)++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 <- S2 <$> getWord8 <*> getWord8+ loop (v:s) (n-2)++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+ s0 <- getWord8+ s1 <- getWord8+ s2 <- getWord8+ s3 <- getWord8+ let !v = S4 s0 s1 s2 s3+ loop (v:s) (n-4)++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+ !v <- S4 <$> getWord8 <*> getWord8 <*> getWord8 <*> getWord8+ loop (v:s) (n-4)++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+ s0 <- getWord8+ s1 <- getWord8+ s2 <- getWord8+ s3 <- getWord8+ s4 <- getWord8+ s5 <- getWord8+ s6 <- getWord8+ s7 <- getWord8+ let !v = S8 s0 s1 s2 s3 s4 s5 s6 s7+ loop (v:s) (n-8)++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+ !v <- S8 <$> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ loop (v:s) (n-8)++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+ s0 <- getWord8+ s1 <- getWord8+ s2 <- getWord8+ s3 <- getWord8+ s4 <- getWord8+ s5 <- getWord8+ s6 <- getWord8+ s7 <- getWord8+ s8 <- getWord8+ s9 <- getWord8+ s10 <- getWord8+ s11 <- getWord8+ s12 <- getWord8+ s13 <- getWord8+ s14 <- getWord8+ s15 <- getWord8+ 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 :: Int -> Get [S16]+getWord8N16A = loop []+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ !v <- S16 <$> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ <*> getWord8+ loop (v:s) (n-16)++manyBytes :: [Word8]+manyBytes = concat $ replicate 256 [0..255]++bigInteger :: Integer+bigInteger = roll_foldl' manyBytes++encodedBigInteger :: L.ByteString+encodedBigInteger = encode bigInteger++roll_foldr :: (Integral a, Bits a) => [Word8] -> a+roll_foldr = foldr unstep 0+ where+ unstep b a = a `shiftL` 8 .|. fromIntegral b++roll_foldl' :: (Integral a, Bits a) => [Word8] -> a+roll_foldl' = foldl' unstep 0 . reverse+ where+ unstep a b = a `shiftL` 8 .|. fromIntegral b
− benchmarks/Makefile
@@ -1,23 +0,0 @@-ghc := ghc-ghc-flags :=-programs := builder bench--.PHONY: all-all: $(programs)--builder: Builder.hs- $(ghc) $(ghc-flags) --make -O2 Builder.hs -o $@ -fforce-recomp -i../src--bench: Benchmark.hs MemBench.hs CBenchmark.o- $(ghc) $(ghc-flags) --make -O2 -fliberate-case-threshold=1000 -fasm Benchmark.hs CBenchmark.o -o $@ -fforce-recomp -i../src--.PHONY: run-bench-run-bench: bench- ./bench 100--CBenchmark.o: CBenchmark.c- $(ghc) -c -optc -O3 $< -o $@--.PHONY: clean-clean:- rm -f *.o *.hi $(programs)
benchmarks/MemBench.hs view
@@ -53,7 +53,7 @@ where iterations = bytes `div` sizeOf (undefined :: CULong) loop :: Int -> CULong -> IO () loop !i !n | i == iterations = return ()- | otherwise = do pokeByteOff ptr i n+ | otherwise = do pokeElemOff ptr i n loop (i+1) (n+1) hs_wordread :: Ptr CULong -> Int -> IO CULong@@ -61,7 +61,7 @@ where iterations = bytes `div` sizeOf (undefined :: CULong) loop :: Int -> CULong -> IO CULong loop !i !n | i == iterations = return n- | otherwise = do x <- peekByteOff ptr i+ | otherwise = do x <- peekElemOff ptr i loop (i+1) (n+x)
+ benchmarks/Put.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE CPP, ExistentialQuantification #-}+{-# LANGUAGE DeriveGeneric #-}++module Main (main) where++import Control.DeepSeq+import Control.Exception (evaluate)+import Criterion.Main+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as C+import qualified Data.ByteString.Lazy as L+import Data.Monoid++import GHC.Generics++import Data.Binary+import Data.Binary.Put+import Data.ByteString.Builder as BB+import Prelude -- Silence Monoid import warning.++main :: IO ()+main = do+ evaluate $ rnf+ [ rnf bigIntegers+ , rnf smallIntegers+ , rnf smallByteStrings+ , rnf smallStrings+ , rnf doubles+ , rnf word8s+ , rnf word16s+ , rnf word32s+ , rnf word64s+ ]+ defaultMain+ [+ bench "small Integers" $ whnf (run . fromIntegers) smallIntegers,+ bench "big Integers" $ whnf (run . fromIntegers) bigIntegers,++ bench "[small Integer]" $ whnf (run . put) smallIntegers,+ bench "[big Integer]" $ whnf (run . put) bigIntegers,++ bench "small ByteStrings" $ whnf (run . fromByteStrings) smallByteStrings,+ bench "[small ByteString]" $ whnf (run . put) smallByteStrings,++ bench "small Strings" $ whnf (run . fromStrings) smallStrings,+ bench "[small String]" $ whnf (run . put) smallStrings,++ bench "Double" $ whnf (run . put) doubles,++ bench "Word8s monoid put" $ whnf (run . fromWord8s) word8s,+ bench "Word8s builder" $ whnf (L.length . toLazyByteString . fromWord8sBuilder) word8s,+ bench "[Word8]" $ whnf (run . put) word8s,+ bench "Word16s monoid put" $ whnf (run . fromWord16s) word16s,+ bench "Word16s builder" $ whnf (L.length . toLazyByteString . fromWord16sBuilder) word16s,+ bench "[Word16]" $ whnf (run . put) word16s,+ bench "Word32s monoid put" $ whnf (run . fromWord32s) word32s,+ bench "Word32s builder" $ whnf (L.length . toLazyByteString . fromWord32sBuilder) word32s,+ bench "[Word32]" $ whnf (run . put) word32s,+ bench "Word64s monoid put" $ whnf (run . fromWord64s) word64s,+ bench "Word64s builder" $ whnf (L.length . toLazyByteString . fromWord64sBuilder) word64s,+ bench "[Word64]" $ whnf (run . put) word64s++ , bgroup "Generics" [+ bench "Struct monoid put" $ whnf (run . fromStructs) structs,+ bench "Struct put as list" $ whnf (run . put) structs,+ bench "StructList monoid put" $ whnf (run . fromStructLists) structLists,+ bench "StructList put as list" $ whnf (run . put) structLists+ ]+ ]+ where+ run = L.length . runPut++data Struct = Struct Word8 Word16 Word32 Word64 deriving Generic+instance Binary Struct++data StructList = StructList [Struct] deriving Generic+instance Binary StructList++structs :: [Struct]+structs = take 10000 $ [ Struct a b 0 0 | a <- [0 .. maxBound], b <- [0 .. maxBound] ]++structLists :: [StructList]+structLists = replicate 1000 (StructList (take 10 structs))++-- Input data++smallIntegers :: [Integer]+smallIntegers = [0..10000]+{-# NOINLINE smallIntegers #-}++bigIntegers :: [Integer]+bigIntegers = [m .. m + 10000]+ where+ m :: Integer+ m = fromIntegral (maxBound :: Word64)+{-# NOINLINE bigIntegers #-}++smallByteStrings :: [S.ByteString]+smallByteStrings = replicate 10000 $ C.pack "abcdefghi"+{-# NOINLINE smallByteStrings #-}++smallStrings :: [String]+smallStrings = replicate 10000 "abcdefghi"+{-# NOINLINE smallStrings #-}++doubles :: [Double]+doubles = take 10000 $ [ sign * 2 ** n | sign <- [-1, 1], n <- [ 0, 0.2 .. 1023 ]]++word8s :: [Word8]+word8s = take 10000 $ cycle [minBound .. maxBound]+{-# NOINLINE word8s #-}++word16s :: [Word16]+word16s = take 10000 $ cycle [minBound .. maxBound]+{-# NOINLINE word16s #-}++word32s :: [Word32]+word32s = take 10000 $ cycle [minBound .. maxBound]+{-# NOINLINE word32s #-}++word64s :: [Word64]+word64s = take 10000 $ cycle [minBound .. maxBound]+{-# NOINLINE word64s #-}++------------------------------------------------------------------------+-- Benchmarks++fromIntegers :: [Integer] -> Put+fromIntegers [] = mempty+fromIntegers (x:xs) = put x `mappend` fromIntegers xs++fromByteStrings :: [S.ByteString] -> Put+fromByteStrings [] = mempty+fromByteStrings (x:xs) = put x `mappend` fromByteStrings xs++fromStrings :: [String] -> Put+fromStrings [] = mempty+fromStrings (x:xs) = put x `mappend` fromStrings xs++fromWord8s :: [Word8] -> Put+fromWord8s [] = mempty+fromWord8s (x:xs) = put x `mappend` fromWord8s xs++fromWord8sBuilder :: [Word8] -> BB.Builder+fromWord8sBuilder [] = mempty+fromWord8sBuilder (x:xs) = BB.word8 x `mappend` fromWord8sBuilder xs++fromWord16s :: [Word16] -> Put+fromWord16s [] = mempty+fromWord16s (x:xs) = put x `mappend` fromWord16s xs++fromWord16sBuilder :: [Word16] -> BB.Builder+fromWord16sBuilder [] = mempty+fromWord16sBuilder (x:xs) = BB.word16BE x `mappend` fromWord16sBuilder xs++fromWord32s :: [Word32] -> Put+fromWord32s [] = mempty+fromWord32s (x:xs) = put x `mappend` fromWord32s xs++fromWord32sBuilder :: [Word32] -> BB.Builder+fromWord32sBuilder [] = mempty+fromWord32sBuilder (x:xs) = BB.word32BE x `mappend` fromWord32sBuilder xs++fromWord64s :: [Word64] -> Put+fromWord64s [] = mempty+fromWord64s (x:xs) = put x `mappend` fromWord64s xs++fromWord64sBuilder :: [Word64] -> BB.Builder+fromWord64sBuilder [] = mempty+fromWord64sBuilder (x:xs) = BB.word64BE x `mappend` fromWord64sBuilder xs++fromStructs :: [Struct] -> Put+fromStructs [] = mempty+fromStructs (x:xs) = put x `mappend` fromStructs xs++fromStructLists :: [StructList] -> Put+fromStructLists [] = mempty+fromStructLists (x:xs) = put x `mappend` fromStructLists xs
binary.cabal view
@@ -1,13 +1,15 @@ name: binary-version: 0.5.1.1+version: 0.10.0.0 license: BSD3 license-file: LICENSE author: Lennart Kolmodin <kolmodin@gmail.com>-maintainer: Lennart Kolmodin, Don Stewart <dons@galois.com>-homepage: http://code.haskell.org/binary/+maintainer: Lennart Kolmodin, Don Stewart <dons00@gmail.com>+homepage: https://github.com/kolmodin/binary description: Efficient, pure binary serialisation using lazy ByteStrings.- Haskell values may be encoded to and from binary formats, + Haskell values may be encoded to and from binary formats, written to disk as binary, or sent over the network.+ The format used can be automatically generated, or+ you can choose to implement a custom format if needed. Serialisation speeds of over 1 G\/sec have been observed, so this library should be suitable for high performance scenarios.@@ -15,47 +17,252 @@ category: Data, Parsing stability: provisional build-type: Simple-cabal-version: >= 1.2-tested-with: GHC ==6.4.2, GHC ==6.6.1, GHC ==6.8.0, GHC ==6.10.1-extra-source-files: README index.html--flag bytestring-in-base-flag split-base-flag applicative-in-base+cabal-version: >= 1.8+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 -library- if flag(bytestring-in-base)- -- bytestring was in base-2.0 and 2.1.1- build-depends: base >= 2.0 && < 2.2- cpp-options: -DBYTESTRING_IN_BASE- else- -- in base 1.0 and 3.0 bytestring is a separate package- build-depends: base < 2.0 || >= 3, bytestring >= 0.9+-- from the benchmark 'bench'+extra-source-files:+ benchmarks/CBenchmark.h - if flag(split-base)- build-depends: base >= 3.0, containers, array- else- build-depends: base < 3.0+source-repository head+ type: git+ location: git://github.com/kolmodin/binary.git - if flag(applicative-in-base)- build-depends: base >= 2.0- cpp-options: -DAPPLICATIVE_IN_BASE- else- build-depends: base < 2.0+library+ 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-- extensions: CPP,- FlexibleContexts+ 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 < 6.5)--- ghc-options: -fallow-undecidable-instances+ 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+-- the dependencies binary has.++test-suite qc+ type: exitcode-stdio-1.0+ hs-source-dirs: src tests+ main-is: QC.hs+ 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 >= 4.5.0.0 && < 5,+ bytestring >= 0.10.4,+ random>=1.0.1.0,+ test-framework,+ test-framework-quickcheck2 >= 0.3,+ 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 >= 4.5.0.0 && < 5,+ bytestring >= 0.10.4,+ Cabal,+ directory,+ filepath,+ HUnit++ -- 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+ 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+ -- 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 >= 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 -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 >= 4.5.0.0 && < 5,+ bytestring >= 0.10.4,+ criterion == 1.*,+ deepseq,+ mtl+ -- build dependencies from using binary source rather than depending on the library+ build-depends: array, containers+ ghc-options: -O2+ if impl(ghc <= 7.6)+ -- prior to ghc-7.4 generics lived in ghc-prim+ build-depends: ghc-prim
+ changelog.md view
@@ -0,0 +1,183 @@+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+--------------++- Fix compilation for GHC == 7.2.*.++binary-0.7.6.0+--------------++- Added binary instance for GHC.Fingerprint (from GHC >= 7.4).++binary-0.7.5.0+--------------++- Fix performance bug that was noticable when you get a big strict ByteString+ and the input to the decoder consists of many small chunks.+ - https://github.com/kolmodin/binary/issues/73+ - https://github.com/kolmodin/binary/pull/76+- Fix memory leak when decoding Double and Float.+ - Commit 497a181c083fa9faf7fa3aa64d1d8deb9ac76ecb+- We now require QuickCheck >= 2.8. Remove our version of arbitrarySizedNatural.++binary-0.7.4.0+--------------++- Some invalid UTF-8 strings caused an exception when decoded. Those errors will+ now now fail in the Get monad instead. See #70.+ Patch contributed by @ttuegel.++binary-0.7.3.0+--------------++- Add Binary instance for Natural (only with base > 4.8).++binary-0.7.2.3+--------------++- Remove INLINEs from GBinary/GSum methods. These interact very badly with the+ GHC 7.9.x simplifier. See also;+ - https://github.com/kolmodin/binary/pull/62+ - https://ghc.haskell.org/trac/ghc/ticket/9630+ - https://ghc.haskell.org/trac/ghc/ticket/9583++binary-0.7.2.2+--------------++- Make import of GHC.Base future-proof (https://github.com/kolmodin/binary/pull/59).++binary-0.7.2.1+--------------++- Fix to compile on GHC 6.10.4 and older (https://github.com/kolmodin/binary/issues/55).++binary-0.7.2.0+--------------++- Add `isolate :: Int -> Get a -> Get a`.+- Add `label :: String -> Get a -> Get a`.++binary-0.7.1.0+--------------++- Add `lookAheadE :: Get (Either a b) -> Get (Either a b)`.+- Add MonadPlus instance for Get. +++binary-0.7.0.1+--------------++- Updates to documentation.++binary-0.7.0.0+--------------++- Add `lookAhead :: Get a -> Get a`.+- Add `lookAheadM :: Get (Maybe a) -> Get (Maybe a)`.+- Add Alternative instance for Get (provides `<|>`).+- Add `decodeOrFail :: Binary a => L.ByteString -> Either (L.ByteString, ByteOffset, String) (L.ByteString, ByteOffset, a)`+- Add `decodeFileOrFail :: Binary a => FilePath -> IO (Either (ByteOffset, String) a)`.+- Remove `Ord` class constraint from `Set` and `Map` Binary instances.++binary-0.6.4+------------++- Add `runGetOrFail :: Get a -> L.ByteString -> Either (L.ByteString, ByteOffset, String) (L.ByteString, ByteOffset, a)`.++binary-0.6.3+------------++- Documentation tweeks, internal restructuring, more tests.++binary-0.6.2+------------++- `some` and `many` more efficient.+- Fix bug where `bytesRead` returned the wrong value.+- Documentation improvements.++binary-0.6.1+------------++- Fix bug where a decoder could return with `Partial` after the previous reply was `Nothing`.++binary-0.6.0.0+--------------
− index.html
@@ -1,161 +0,0 @@-<?xml version="1.0" encoding="iso-8859-1"?>-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">--<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">-<head>- <title>Data.Binary - efficient, pure binary serialisation for Haskell</title>- <link rel="stylesheet" href="http://www.cse.unsw.edu.au/~dons/main.css" type="text/css" />-</head>--<body xml:lang="en" lang="en">-- <div id="content">-- <h2>Data.Binary</h2>--<table width="80%" align="center"> <tr><td>-- <h3>About</h3>- <p>- Data.Binary is a library for high performance binary serialisation- of <a href="http://haskell.org">Haskell</a> data. It uses the- <a href="http://www.cse.unsw.edu.au/~dons/fps.html"- >ByteString</a> library to achieve efficient, lazy reading and- writing of structures in binary format.- </p>-- <p>- Chris Eidhof writes on his use of Data.Binary implementing a- full-text search engine:- </p>- <pre>- "The communication with Sphinx is done using a quite low-level binary- protocol, but Data.Binary saved the day: it made it very easy for us- to parse all the binary things. Especially the use of the Get and- Put monads are a big improvement over the manual reading and keeping- track of positions, as is done in the PHP/Python clients."- </pre>-- <h3>Example</h3>- For example, to serialise an interpreter's abstract syntax tree to- binary format:-<pre><span class='keyword'>import</span> <span class='conid'>Data</span><span class='varop'>.</span><span class='conid'>Binary</span>-<span class='keyword'>import</span> <span class='conid'>Control</span><span class='varop'>.</span><span class='conid'>Monad</span>-<span class='keyword'>import</span> <span class='conid'>Codec</span><span class='varop'>.</span><span class='conid'>Compression</span><span class='varop'>.</span><span class='conid'>GZip</span>--<span class='comment'>-- A Haskell AST structure</span>-<span class='keyword'>data</span> <span class='conid'>Exp</span> <span class='keyglyph'>=</span> <span class='conid'>IntE</span> <span class='conid'>Int</span>- <span class='keyglyph'>|</span> <span class='conid'>OpE</span> <span class='conid'>String</span> <span class='conid'>Exp</span> <span class='conid'>Exp</span>- <span class='keyword'>deriving</span> <span class='conid'>Eq</span>--<span class='comment'>-- An instance of Binary to encode and decode an Exp in binary</span>-<span class='keyword'>instance</span> <span class='conid'>Binary</span> <span class='conid'>Exp</span> <span class='keyword'>where</span>- <span class='varid'>put</span> <span class='layout'>(</span><span class='conid'>IntE</span> <span class='varid'>i</span><span class='layout'>)</span> <span class='keyglyph'>=</span> <span class='varid'>put</span> <span class='layout'>(</span><span class='num'>0</span> <span class='keyglyph'>::</span> <span class='conid'>Word8</span><span class='layout'>)</span> <span class='varop'>>></span> <span class='varid'>put</span> <span class='varid'>i</span>- <span class='varid'>put</span> <span class='layout'>(</span><span class='conid'>OpE</span> <span class='varid'>s</span> <span class='varid'>e1</span> <span class='varid'>e2</span><span class='layout'>)</span> <span class='keyglyph'>=</span> <span class='varid'>put</span> <span class='layout'>(</span><span class='num'>1</span> <span class='keyglyph'>::</span> <span class='conid'>Word8</span><span class='layout'>)</span> <span class='varop'>>></span> <span class='varid'>put</span> <span class='varid'>s</span> <span class='varop'>>></span> <span class='varid'>put</span> <span class='varid'>e1</span> <span class='varop'>>></span> <span class='varid'>put</span> <span class='varid'>e2</span>- <span class='varid'>get</span> <span class='keyglyph'>=</span> <span class='keyword'>do</span> <span class='varid'>tag</span> <span class='keyglyph'><-</span> <span class='varid'>getWord8</span>- <span class='keyword'>case</span> <span class='varid'>tag</span> <span class='keyword'>of</span>- <span class='num'>0</span> <span class='keyglyph'>-></span> <span class='varid'>liftM</span> <span class='conid'>IntE</span> <span class='varid'>get</span>- <span class='num'>1</span> <span class='keyglyph'>-></span> <span class='varid'>liftM3</span> <span class='conid'>OpE</span> <span class='varid'>get</span> <span class='varid'>get</span> <span class='varid'>get</span>--<span class='comment'>-- A test expression</span>-<span class='varid'>e</span> <span class='keyglyph'>=</span> <span class='conid'>OpE</span> <span class='str'>"*"</span> <span class='layout'>(</span><span class='conid'>IntE</span> <span class='num'>7</span><span class='layout'>)</span> <span class='layout'>(</span><span class='conid'>OpE</span> <span class='str'>"/"</span> <span class='layout'>(</span><span class='conid'>IntE</span> <span class='num'>4</span><span class='layout'>)</span> <span class='layout'>(</span><span class='conid'>IntE</span> <span class='num'>2</span><span class='layout'>)</span><span class='layout'>)</span>--<span class='comment'>-- Serialise and compress with gzip, then decompress and deserialise</span>-<span class='varid'>main</span> <span class='keyglyph'>=</span> <span class='keyword'>do</span>- <span class='keyword'>let</span> <span class='varid'>t</span> <span class='keyglyph'>=</span> <span class='varid'>compress</span> <span class='layout'>(</span><span class='varid'>encode</span> <span class='varid'>e</span><span class='layout'>)</span>- <span class='varid'>print</span> <span class='varid'>t</span>- <span class='keyword'>let</span> <span class='varid'>e'</span> <span class='keyglyph'>=</span> <span class='varid'>decode</span> <span class='layout'>(</span><span class='varid'>decompress</span> <span class='varid'>t</span><span class='layout'>)</span>- <span class='varid'>print</span> <span class='layout'>(</span><span class='varid'>e</span> <span class='varop'>==</span> <span class='varid'>e'</span><span class='layout'>)</span>-</pre>-- <h3>Download</h3>-- <table width="100%"><tr valign="top">- <td><h4>stable release</h4>- <table>- <tr><td>- <a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/binary-0.4.2"- >binary 0.4.2</a> - </td><td>(Apr 2008)</td></tr>-- <tr><td>- <a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/binary-0.4.1"- >binary 0.4.1</a> - </td><td>(Oct 2007)</td></tr>-- <tr><td>- <a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/binary-0.4"- >binary 0.4</a> - </td><td>(Oct 2007)</td></tr>-- <tr><td>- <a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/binary-0.3"- >binary 0.3</a> - </td><td>(Mar 2007)</td></tr>-- <tr><td>- <a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/binary-0.3"- >binary 0.2</a> - </td><td>(Jan 2007)</td></tr>-- </table> - </td>- <td><h4>development branch</h4>- <table>- <tr><td>- darcs get <a href="http://code.haskell.org/binary"- >http://code.haskell.org/binary</a>- </td></tr>- </table>- </td> </tr> </table>-- <h3>Download</h3>- <ul>- <li>- <a href="http://hackage.haskell.org/packages/archive/binary/0.4.1/doc/html/Data-Binary.html">Documentation</a>- </li>- </ul>-- <h3>Project Activity</h3>-- <center>- <img src="http://www.cse.unsw.edu.au/~dons/images/commits/community/binary-commits.png"- alt="binary commit statistics" />- </center>-- <h3>Starring...</h3>-- The Binary Strike Force- <ul>- <li>Lennart Kolmodin </li>- <li>Duncan Coutts </li>- <li>Don Stewart </li>- <li>Spencer Janssen </li>- <li>David Himmelstrup </li>- <li>Björn Bringert </li>- <li>Ross Paterson </li>- <li>Einar Karttunen </li>- <li>John Meacham </li>- <li>Ulf Norell </li>- <li>Bryan O'Sullivan </li>- <li>Tomasz Zielonka </li>- <li>Florian Weimer </li>- <li>Judah Jacobson </li>- </ul>--</td></tr> </table>--<img src="http://xmonad.org/images/HPC.badge.jpg" alt="covered by HPC" />-<img src="http://xmonad.org/images/cabal.png" alt="built with Cabal" />-<img src="http://xmonad.org/images/quickcheck.png" alt="tested with QuickCheck" />-- </div>--- <div id="footer">-Mon Jul 14 11:37:21 PDT 2008- </div>--</body>-</html>
src/Data/Binary.hs view
@@ -1,40 +1,54 @@-{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-}-#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Binary -- Copyright : Lennart Kolmodin -- License : BSD3-style (see LICENSE)--- +-- -- Maintainer : Lennart Kolmodin <kolmodin@gmail.com> -- Stability : unstable--- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances+-- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances. ----- Binary serialisation of Haskell values to and from lazy ByteStrings.+-- Binary serialisation of Haskell values to and from lazy 'ByteString's. -- The Binary library provides methods for encoding Haskell values as--- streams of bytes directly in memory. The resulting @ByteString@ can--- then be written to disk, sent over the network, or futher processed+-- streams of bytes directly in memory. The resulting 'ByteString' can+-- then be written to disk, sent over the network, or further processed -- (for example, compressed with gzip). ----- The 'Binary' package is notable in that it provides both pure, and+-- The @binary@ package is notable in that it provides both pure, and -- high performance serialisation. ----- Values are always encoded in network order (big endian) form, and--- encoded data should be portable across machine endianess, word size,--- or compiler version. For example, data encoded using the Binary class--- could be written from GHC, and read back in Hugs.+-- Values encoded using the 'Binary' class are always encoded in network order+-- (big endian) form, and encoded data should be portable across+-- machine endianness, word size, or compiler version. For example,+-- data encoded using the 'Binary' class could be written on any machine,+-- and read back on any another. --+-- 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 '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".+-- ----------------------------------------------------------------------------- module Data.Binary ( -- * The Binary class Binary(..)-+ -- ** Example -- $example + -- * Generic support+ -- $generics+ , GBinaryGet(..)+ , GBinaryPut(..)+ -- * The Get and Put monads , Get , Put@@ -46,14 +60,12 @@ -- * Binary serialisation , encode -- :: Binary a => a -> ByteString , decode -- :: Binary a => ByteString -> a+ , decodeOrFail -- * IO functions for serialisation , encodeFile -- :: Binary a => FilePath -> a -> IO () , decodeFile -- :: Binary a => FilePath -> IO a---- Lazy put and get--- , lazyPut--- , lazyGet+ , decodeFileOrFail , module Data.Word -- useful @@ -61,63 +73,19 @@ import Data.Word +import Data.Binary.Class import Data.Binary.Put import Data.Binary.Get--import Control.Monad-import Foreign+import Data.Binary.Generic () +import qualified Data.ByteString as B ( hGet, length ) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as L--import Data.Char (chr,ord)-import Data.List (unfoldr)---- And needed for the instances:-import qualified Data.ByteString as B-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet-import qualified Data.Ratio as R--import qualified Data.Tree as T--import Data.Array.Unboxed------- 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+import qualified Data.ByteString.Lazy.Internal as L ( defaultChunkSize )+import System.IO ( withBinaryFile, IOMode(ReadMode) ) ------------------------------------------------------------------------ --- | The @Binary@ class provides 'put' and 'get', methods to encode and--- decode a Haskell value to a lazy ByteString. It mirrors the Read and--- Show classes for textual representation of Haskell types, and is--- suitable for serialising Haskell values to disk, over the network.------ For parsing and generating simple external binary formats (e.g. C--- structures), Binary may be used, but in general is not suitable--- for complex protocols. Instead use the Put and Get primitives--- directly.------ Instances of Binary should satisfy the following property:------ > decode . encode == id------ That is, the 'get' and 'put' methods should be the inverse of each--- other. A range of instances are provided for basic Haskell types. ----class Binary t where- -- | Encode a value in the Put monad.- put :: t -> Put- -- | Decode a value in the Get monad- get :: Get t- -- $example -- To serialise a custom type, an instance of Binary for that type is -- required. For example, suppose we have a data structure:@@ -131,13 +99,13 @@ -- structure to serialise: -- -- > instance Binary Exp where--- > put (IntE i) = do put (0 :: Word8)--- > put i--- > put (OpE s e1 e2) = do put (1 :: Word8)--- > put s--- > put e1--- > put e2--- > +-- > put (IntE i) = do put (0 :: Word8)+-- > put i+-- > put (OpE s e1 e2) = do put (1 :: Word8)+-- > put s+-- > put e1+-- > put e2+-- > -- > get = do t <- get :: Get Word8 -- > case t of -- > 0 -> do i <- get@@ -152,44 +120,12 @@ -- -- We can simplify the writing of 'get' instances using monadic -- combinators:--- +-- -- > get = do tag <- getWord8 -- > case tag of -- > 0 -> liftM IntE get -- > 1 -> liftM3 OpE get get get ----- The generation of Binary instances has been automated by a script--- using Scrap Your Boilerplate generics. Use the script here:--- <http://darcs.haskell.org/binary/tools/derive/BinaryDerive.hs>.------ To derive the instance for a type, load this script into GHCi, and--- bring your type into scope. Your type can then have its Binary--- instances derived as follows:------ > $ ghci -fglasgow-exts BinaryDerive.hs--- > *BinaryDerive> :l Example.hs--- > *Main> deriveM (undefined :: Drinks)--- >--- > instance Binary Main.Drinks where--- > put (Beer a) = putWord8 0 >> put a--- > put Coffee = putWord8 1--- > put Tea = putWord8 2--- > put EnergyDrink = putWord8 3--- > put Water = putWord8 4--- > put Wine = putWord8 5--- > put Whisky = putWord8 6--- > get = do--- > tag_ <- getWord8--- > case tag_ of--- > 0 -> get >>= \a -> return (Beer a)--- > 1 -> return Coffee--- > 2 -> return Tea--- > 3 -> return EnergyDrink--- > 4 -> return Water--- > 5 -> return Wine--- > 6 -> return Whisky--- >--- -- To serialise this to a bytestring, we use 'encode', which packs the -- data structure into a binary format, in a lazy bytestring --@@ -214,7 +150,7 @@ -- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2)) -- -- We can also directly serialise a value to and from a Handle, or a file:--- +-- -- > > v <- decodeFile "/tmp/exp.txt" :: IO Exp -- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2)) --@@ -233,14 +169,25 @@ {-# INLINE encode #-} -- | Decode a value from a lazy ByteString, reconstructing the original structure.--- decode :: Binary a => ByteString -> a decode = runGet get +-- | Decode a value from a lazy ByteString. Returning 'Left' on failure and+-- '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)+decodeOrFail = runGetOrFail get++ ------------------------------------------------------------------------ -- Convenience IO operations --- | Lazily serialise a value to a file+-- | Lazily serialise a value to a file. -- -- This is just a convenience function, it's defined simply as: --@@ -253,469 +200,49 @@ encodeFile :: Binary a => FilePath -> a -> IO () encodeFile f v = L.writeFile f (encode v) --- | Lazily reconstruct a value previously written to a file.------ This is just a convenience function, it's defined simply as:------ > decodeFile f = return . decode =<< B.readFile f------ So for example if you wanted to decompress as well, you could use:------ > return . decode . decompress =<< B.readFile f------ After contructing the data from the input file, 'decodeFile' checks--- if the file is empty, and in doing so will force the associated file--- handle closed, if it is indeed empty. If the file is not empty, --- it is up to the decoding instance to consume the rest of the data,--- or otherwise finalise the resource.+-- | 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- s <- L.readFile f- return $ runGet (do v <- get- m <- isEmpty- m `seq` return v) s---- needs bytestring 0.9.1.x to work ----------------------------------------------------------------------------- Lazy put and get---- lazyPut :: (Binary a) => a -> Put--- lazyPut a = put (encode a)---- lazyGet :: (Binary a) => Get a--- lazyGet = fmap decode get----------------------------------------------------------------------------- Simple instances---- The () type need never be written to disk: values of singleton type--- can be reconstructed from the type alone-instance Binary () where- put () = return ()- 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---- 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----------------------------------------------------------------------------- Words and Ints---- Words8s are written as bytes-instance Binary Word8 where- put = putWord8- get = getWord8---- Words16s are written as 2 bytes in big-endian (network) order-instance Binary Word16 where- put = putWord16be- get = getWord16be---- Words32s are written as 4 bytes in big-endian (network) order-instance Binary Word32 where- put = putWord32be- get = getWord32be---- Words64s are written as 8 bytes in big-endian (network) order-instance Binary Word64 where- put = putWord64be- 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)---- 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)---- 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)---- Int64s are written as a 4 bytes in big endian format-instance Binary Int64 where- put i = put (fromIntegral i :: Word64)- get = liftM fromIntegral (get :: Get Word64)------------------------------------------------------------------------------ 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)---- 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)----------------------------------------------------------------------------- --- Portable, and pretty efficient, serialisation of Integer------- Fixed-size type for a subset of Integer-type SmallInt = Int32---- Integers are encoded in two ways: if they fit inside a SmallInt,--- they're written as a byte tag, and that value. If the Integer value--- is too large to fit in a SmallInt, it is written as a byte array,--- along with a sign and length field.--instance Binary Integer where-- {-# INLINE put #-}- put n | n >= lo && n <= hi = do- putWord8 0- put (fromIntegral n :: SmallInt) -- fast path- where- lo = fromIntegral (minBound :: SmallInt) :: Integer- hi = fromIntegral (maxBound :: SmallInt) :: Integer-- put n = do- putWord8 1- put sign- put (unroll (abs n)) -- unroll the bytes- where- sign = fromIntegral (signum n) :: Word8-- {-# INLINE get #-}- get = do- tag <- get :: Get Word8- case tag of- 0 -> liftM fromIntegral (get :: Get SmallInt)- _ -> do sign <- get- bytes <- get- let v = roll bytes- return $! if sign == (1 :: Word8) then v else - v------- Fold and unfold an Integer to and from a list of its bytes----unroll :: Integer -> [Word8]-unroll = unfoldr step- where- step 0 = Nothing- step i = Just (fromIntegral i, i `shiftR` 8)--roll :: [Word8] -> Integer-roll = foldr unstep 0- where- unstep b a = a `shiftL` 8 .|. fromIntegral b--{-------- An efficient, raw serialisation for Integer (GHC only)------- TODO This instance is not architecture portable. GMP stores numbers as--- arrays of machine sized words, so the byte format is not portable across--- architectures with different endianess and word size.--import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy)-import GHC.Base hiding (ord, chr)-import GHC.Prim-import GHC.Ptr (Ptr(..))-import GHC.IOBase (IO(..))--instance Binary Integer where- put (S# i) = putWord8 0 >> put (I# i)- put (J# s ba) = do- putWord8 1- put (I# s)- put (BA ba)-- get = do- b <- getWord8- case b of- 0 -> do (I# i#) <- get- return (S# i#)- _ -> do (I# s#) <- get- (BA a#) <- get- return (J# s# a#)--instance Binary ByteArray where-- -- Pretty safe.- put (BA ba) =- let sz = sizeofByteArray# ba -- (primitive) in *bytes*- addr = byteArrayContents# ba- bs = unsafePackAddress (I# sz) addr- in put bs -- write as a ByteString. easy, yay!-- -- Pretty scary. Should be quick though- get = do- (fp, off, n@(I# sz)) <- liftM toForeignPtr get -- so decode a ByteString- assert (off == 0) $ return $ unsafePerformIO $ do- (MBA arr) <- newByteArray sz -- and copy it into a ByteArray#- let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe?- withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n)- freezeByteArray arr---- wrapper for ByteArray#-data ByteArray = BA {-# UNPACK #-} !ByteArray#-data MBA = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld)--newByteArray :: Int# -> IO MBA-newByteArray sz = IO $ \s ->- case newPinnedByteArray# sz s of { (# s', arr #) ->- (# s', MBA arr #) }--freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray-freezeByteArray arr = IO $ \s ->- case unsafeFreezeByteArray# arr s of { (# s', arr' #) ->- (# s', BA arr' #) }---}--instance (Binary a,Integral a) => Binary (R.Ratio a) where- put r = put (R.numerator r) >> put (R.denominator r)- get = liftM2 (R.%) get 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)-- get = do- let getByte = liftM (fromIntegral :: Word8 -> Int) get- shiftL6 = flip shiftL 6 :: Int -> Int- w <- getByte- r <- case () of- _ | w < 0x80 -> return w- | w < 0xe0 -> do- x <- liftM (xor 0x80) getByte- return (x .|. shiftL6 (xor 0xc0 w))- | w < 0xf0 -> do- x <- liftM (xor 0x80) getByte- y <- liftM (xor 0x80) getByte- return (y .|. shiftL6 (x .|. shiftL6- (xor 0xe0 w)))- | otherwise -> do- x <- liftM (xor 0x80) getByte- y <- liftM (xor 0x80) getByte- z <- liftM (xor 0x80) getByte- return (z .|. shiftL6 (y .|. shiftL6- (x .|. shiftL6 (xor 0xf0 w))))- return $! chr r----------------------------------------------------------------------------- Instances for the first few tuples--instance (Binary a, Binary b) => Binary (a,b) where- put (a,b) = put a >> put b- 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- 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- 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- get = liftM5 (,,,,) get get get get get---- --- and now just recurse:-----instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)- => Binary (a,b,c,d,e,f) where- put (a,b,c,d,e,f) = put (a,(b,c,d,e,f))- 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- put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g))- 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- put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h))- 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- put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i))- 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- put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j))- 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--instance Binary a => Binary [a] where- put l = put (length l) >> mapM_ put l- 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]-getMany n = go [] n- where- go xs 0 = return $! reverse xs- go xs i = do x <- get- -- we must seq x to avoid stack overflows due to laziness in- -- (>>=)- x `seq` go (x:xs) (i-1)-{-# INLINE getMany #-}--instance (Binary a) => Binary (Maybe a) where- put Nothing = putWord8 0- put (Just x) = putWord8 1 >> put x- get = do- w <- getWord8- case w of- 0 -> return Nothing- _ -> 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- get = do- w <- getWord8- case w of- 0 -> liftM Left get- _ -> liftM Right get----------------------------------------------------------------------------- ByteStrings (have specially efficient instances)--instance Binary B.ByteString where- put bs = do put (B.length bs)- putByteString bs- get = get >>= getByteString------- Using old versions of fps, this is a type synonym, and non portable--- --- Requires 'flexible instances'----instance Binary ByteString where- put bs = do put (fromIntegral (L.length bs) :: Int)- putLazyByteString bs- get = get >>= getLazyByteString----------------------------------------------------------------------------- Maps and Sets--instance (Ord a, Binary a) => Binary (Set.Set a) where- put s = put (Set.size s) >> mapM_ put (Set.toAscList s)- get = liftM Set.fromDistinctAscList get--instance (Ord k, Binary k, Binary e) => Binary (Map.Map k e) where- 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)- get = liftM IntSet.fromDistinctAscList get+ result <- decodeFileOrFail f+ case result of+ Right x -> return x+ Left (_,str) -> error str -instance (Binary e) => Binary (IntMap.IntMap e) where- put m = put (IntMap.size m) >> mapM_ put (IntMap.toAscList m)- get = liftM IntMap.fromDistinctAscList get+-- | Decode a value from a file. In case of success, the value will be returned+-- in 'Right'. In case of decoder errors, the error message together with+-- the byte offset will be returned.+decodeFileOrFail :: Binary a => FilePath -> IO (Either (ByteOffset, String) a)+decodeFileOrFail f =+ withBinaryFile f ReadMode $ \h -> do+ feed (runGetIncremental get) h+ where -- TODO: put in Data.Binary.Get and name pushFromHandle?+ feed (Done _ _ x) _ = return (Right x)+ feed (Fail _ pos str) _ = return (Left (pos, str))+ feed (Partial k) h = do+ chunk <- B.hGet h L.defaultChunkSize+ case B.length chunk of+ 0 -> feed (k Nothing) h+ _ -> feed (k (Just chunk)) h --------------------------------------------------------------------------- Queues and Sequences--#if __GLASGOW_HASKELL__ >= 606------ This is valid Hugs, but you need the most recent Hugs+-- $generics ----instance (Binary e) => Binary (Seq.Seq e) where- 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- rep xs n g = xs `seq` n `seq` do- x <- g- rep (xs Seq.|> x) (n-1) g--#endif----------------------------------------------------------------------------- Floating point--instance Binary Double where- put d = put (decodeFloat d)- get = liftM2 encodeFloat get get--instance Binary Float where- put f = put (decodeFloat f)- get = liftM2 encodeFloat get get----------------------------------------------------------------------------- Trees--instance (Binary e) => Binary (T.Tree e) where- 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 (bounds a)- put (rangeSize $ bounds a) -- write the length- mapM_ put (elems a) -- now the elems.- get = do- bs <- get- n <- get -- read the length- xs <- getMany n -- now the elems.- return (listArray bs xs)-+-- Beginning with GHC 7.2, it is possible to use binary serialization+-- without writing any instance boilerplate code. ----- The IArray UArray e constraint is non portable. Requires flexible instances+-- > {-# LANGUAGE DeriveGeneric #-}+-- >+-- > import Data.Binary+-- > import GHC.Generics (Generic)+-- >+-- > data Foo = Foo+-- > deriving (Generic)+-- >+-- > -- GHC will automatically fill out the instance+-- > instance Binary Foo ---instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where- put a = do- put (bounds a)- put (rangeSize $ bounds a) -- now write the length- mapM_ put (elems a)- get = do- bs <- get- n <- get- xs <- getMany n- return (listArray bs xs)+-- This mechanism makes use of GHC's efficient built-in generics+-- support.
src/Data/Binary/Builder.hs view
@@ -1,23 +1,23 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE CPP, MagicHash #-} {-# LANGUAGE Safe #-}-#endif+ ----------------------------------------------------------------------------- -- | -- Module : Data.Binary.Builder -- Copyright : Lennart Kolmodin, Ross Paterson -- License : BSD3-style (see LICENSE)--- +-- -- Maintainer : Lennart Kolmodin <kolmodin@gmail.com> -- Stability : experimental -- Portability : portable to Hugs and GHC ----- Efficient construction of lazy bytestrings.+-- Efficient constructions of lazy bytestrings. --+-- This now re-exports 'Data.ByteString.Lazy.Builder'.+-- ----------------------------------------------------------------------------- module Data.Binary.Builder (- -- * The Builder type Builder , toLazyByteString@@ -28,7 +28,9 @@ , append , fromByteString -- :: S.ByteString -> Builder , fromLazyByteString -- :: L.ByteString -> Builder-+#if MIN_VERSION_bytestring(0,10,4)+ , fromShortByteString -- :: T.ByteString -> Builder+#endif -- * Flushing the buffer state , flush @@ -37,21 +39,236 @@ , putWord16be -- :: Word16 -> Builder , putWord32be -- :: Word32 -> Builder , putWord64be -- :: Word64 -> Builder+ , putInt16be -- :: Int16 -> Builder+ , putInt32be -- :: Int32 -> Builder+ , putInt64be -- :: Int64 -> Builder -- ** Little-endian writes , putWord16le -- :: Word16 -> Builder , putWord32le -- :: Word32 -> Builder , putWord64le -- :: Word64 -> Builder+ , putInt16le -- :: Int16 -> Builder+ , putInt32le -- :: Int32 -> Builder+ , putInt64le -- :: Int64 -> Builder -- ** Host-endian, unaligned writes , putWordhost -- :: Word -> Builder , putWord16host -- :: Word16 -> Builder , putWord32host -- :: Word32 -> Builder , putWord64host -- :: Word64 -> Builder+ , putInthost -- :: Int -> Builder+ , putInt16host -- :: Int16 -> Builder+ , putInt32host -- :: Int32 -> Builder+ , putInt64host -- :: Int64 -> Builder -- ** Unicode , putCharUtf8+ , putStringUtf8+ ) where - ) where+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L -import Data.Binary.Builder.Base+#if MIN_VERSION_bytestring(0,10,4)+import qualified Data.ByteString.Short as T+#endif++import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Builder.Prim as Prim+import Data.ByteString.Builder ( Builder, toLazyByteString )+import Data.ByteString.Builder.Extra ( flush )+import Data.Monoid+import Data.Word+import Data.Int+import Prelude -- Silence AMP warning.++------------------------------------------------------------------------++-- | /O(1)./ The empty Builder, satisfying+--+-- * @'toLazyByteString' 'empty' = 'L.empty'@+--+empty :: Builder+empty = mempty+{-# INLINE empty #-}++-- | /O(1)./ A Builder taking a single byte, satisfying+--+-- * @'toLazyByteString' ('singleton' b) = 'L.singleton' b@+--+singleton :: Word8 -> Builder+singleton = B.word8+{-# INLINE singleton #-}++------------------------------------------------------------------------++-- | /O(1)./ The concatenation of two Builders, an associative operation+-- with identity 'empty', satisfying+--+-- * @'toLazyByteString' ('append' x y) = 'L.append' ('toLazyByteString' x) ('toLazyByteString' y)@+--+append :: Builder -> Builder -> Builder+append = mappend+{-# INLINE append #-}++-- | /O(1)./ A Builder taking a 'S.ByteString', satisfying+--+-- * @'toLazyByteString' ('fromByteString' bs) = 'L.fromChunks' [bs]@+--+fromByteString :: S.ByteString -> Builder+fromByteString = B.byteString+{-# INLINE fromByteString #-}++-- | /O(1)./ A Builder taking a lazy 'L.ByteString', satisfying+--+-- * @'toLazyByteString' ('fromLazyByteString' bs) = bs@+--+fromLazyByteString :: L.ByteString -> Builder+fromLazyByteString = B.lazyByteString+{-# INLINE fromLazyByteString #-}++#if MIN_VERSION_bytestring(0,10,4)+-- | /O(n)./ A builder taking 'T.ShortByteString' and copy it to a Builder,+-- satisfying+--+-- * @'toLazyByteString' ('fromShortByteString' bs) = 'L.fromChunks' ['T.fromShort' bs]+fromShortByteString :: T.ShortByteString -> Builder+fromShortByteString = B.shortByteString+{-# INLINE fromShortByteString #-}+#endif++------------------------------------------------------------------------++-- | Write a Word16 in big endian format+putWord16be :: Word16 -> Builder+putWord16be = B.word16BE+{-# INLINE putWord16be #-}++-- | Write a Word16 in little endian format+putWord16le :: Word16 -> Builder+putWord16le = B.word16LE+{-# INLINE putWord16le #-}++-- | Write a Word32 in big endian format+putWord32be :: Word32 -> Builder+putWord32be = B.word32BE+{-# INLINE putWord32be #-}++-- | Write a Word32 in little endian format+putWord32le :: Word32 -> Builder+putWord32le = B.word32LE+{-# INLINE putWord32le #-}++-- | Write a Word64 in big endian format+putWord64be :: Word64 -> Builder+putWord64be = B.word64BE+{-# INLINE putWord64be #-}++-- | Write a Word64 in little endian format+putWord64le :: Word64 -> Builder+putWord64le = B.word64LE+{-# INLINE putWord64le #-}++-- | Write a Int16 in big endian format+putInt16be :: Int16 -> Builder+putInt16be = B.int16BE+{-# INLINE putInt16be #-}++-- | Write a Int16 in little endian format+putInt16le :: Int16 -> Builder+putInt16le = B.int16LE+{-# INLINE putInt16le #-}++-- | Write a Int32 in big endian format+putInt32be :: Int32 -> Builder+putInt32be = B.int32BE+{-# INLINE putInt32be #-}++-- | Write a Int32 in little endian format+putInt32le :: Int32 -> Builder+putInt32le = B.int32LE+{-# INLINE putInt32le #-}++-- | Write a Int64 in big endian format+putInt64be :: Int64 -> Builder+putInt64be = B.int64BE++-- | Write a Int64 in little endian format+putInt64le :: Int64 -> Builder+putInt64le = B.int64LE+++------------------------------------------------------------------------+-- Unaligned, word size ops++-- | /O(1)./ A Builder taking a single native machine word. The word is+-- written in host order, host endian form, for the machine you're on.+-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine,+-- 4 bytes. Values written this way are not portable to+-- different endian or word sized machines, without conversion.+--+putWordhost :: Word -> Builder+putWordhost = Prim.primFixed Prim.wordHost+{-# INLINE putWordhost #-}++-- | Write a Word16 in native host order and host endianness.+-- 2 bytes will be written, unaligned.+putWord16host :: Word16 -> Builder+putWord16host = Prim.primFixed Prim.word16Host+{-# INLINE putWord16host #-}++-- | Write a Word32 in native host order and host endianness.+-- 4 bytes will be written, unaligned.+putWord32host :: Word32 -> Builder+putWord32host = Prim.primFixed Prim.word32Host+{-# INLINE putWord32host #-}++-- | Write a Word64 in native host order.+-- On a 32 bit machine we write two host order Word32s, in big endian form.+-- 8 bytes will be written, unaligned.+putWord64host :: Word64 -> Builder+putWord64host = Prim.primFixed Prim.word64Host+{-# INLINE putWord64host #-}++-- | /O(1)./ A Builder taking a single native machine word. The word is+-- written in host order, host endian form, for the machine you're on.+-- On a 64 bit machine the Int is an 8 byte value, on a 32 bit machine,+-- 4 bytes. Values written this way are not portable to+-- different endian or word sized machines, without conversion.+--+putInthost :: Int -> Builder+putInthost = Prim.primFixed Prim.intHost+{-# INLINE putInthost #-}++-- | Write a Int16 in native host order and host endianness.+-- 2 bytes will be written, unaligned.+putInt16host :: Int16 -> Builder+putInt16host = Prim.primFixed Prim.int16Host+{-# INLINE putInt16host #-}++-- | Write a Int32 in native host order and host endianness.+-- 4 bytes will be written, unaligned.+putInt32host :: Int32 -> Builder+putInt32host = Prim.primFixed Prim.int32Host+{-# INLINE putInt32host #-}++-- | Write a Int64 in native host order.+-- On a 32 bit machine we write two host order Int32s, in big endian form.+-- 8 bytes will be written, unaligned.+putInt64host :: Int64 -> Builder+putInt64host = Prim.primFixed Prim.int64Host+{-# INLINE putInt64host #-}+++------------------------------------------------------------------------+-- Unicode++-- | Write a character using UTF-8 encoding.+putCharUtf8 :: Char -> Builder+putCharUtf8 = Prim.primBounded Prim.charUtf8+{-# INLINE putCharUtf8 #-}++-- | Write a String using UTF-8 encoding.+putStringUtf8 :: String -> Builder+putStringUtf8 = Prim.primMapListBounded Prim.charUtf8+{-# INLINE putStringUtf8 #-}
− src/Data/Binary/Builder/Base.hs
@@ -1,512 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, MagicHash #-}-#if __GLASGOW_HASKELL__ >= 701-{-# LANGUAGE Trustworthy #-}-#endif---------------------------------------------------------------------------------- |--- Module : Data.Binary.Builder.Base--- Copyright : Lennart Kolmodin, Ross Paterson--- License : BSD3-style (see LICENSE)------ Maintainer : Lennart Kolmodin <kolmodin@gmail.com>--- Stability : experimental--- Portability : portable to Hugs and GHC------ A module exporting types and functions that are shared by--- 'Data.Binary.Builder' and 'Data.Binary.Builder.Internal'.-----------------------------------------------------------------------------------#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)-#include "MachDeps.h"-#endif--module Data.Binary.Builder.Base (- -- * The Builder type- Builder- , toLazyByteString-- -- * Constructing Builders- , empty- , singleton- , append- , fromByteString -- :: S.ByteString -> Builder- , fromLazyByteString -- :: L.ByteString -> Builder-- -- * Flushing the buffer state- , flush-- -- * Derived Builders- -- ** Big-endian writes- , putWord16be -- :: Word16 -> Builder- , putWord32be -- :: Word32 -> Builder- , putWord64be -- :: Word64 -> Builder-- -- ** Little-endian writes- , putWord16le -- :: Word16 -> Builder- , putWord32le -- :: Word32 -> Builder- , putWord64le -- :: Word64 -> Builder-- -- ** Host-endian, unaligned writes- , putWordhost -- :: Word -> Builder- , putWord16host -- :: Word16 -> Builder- , putWord32host -- :: Word32 -> Builder- , putWord64host -- :: Word64 -> Builder-- -- ** Unicode- , putCharUtf8-- -- * Low-level construction of Builders- , writeN- , writeAtMost- ) where--import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import Data.Monoid-import Data.Word-import Foreign--#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-import GHC.Word (Word32(..),Word16(..),Word64(..))-# if WORD_SIZE_IN_BITS < 64-import GHC.Word (uncheckedShiftRL64#)-# endif-#endif------------------------------------------------------------------------------ | 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 = unsafePerformIO $ do- buf <- newBuffer defaultSize- runBuilder (m `append` flush) (const (return L.Empty)) buf-{-# INLINE toLazyByteString #-}---- | /O(1)./ Pop the 'S.ByteString' we have constructed so far, if any,--- yielding a new chunk in the result lazy 'L.ByteString'.-flush :: Builder-flush = Builder $ \ k buf@(Buffer p o u l) ->- if u == 0 -- Invariant (from Data.ByteString.Lazy)- then k buf- else let !b = Buffer p (o+u) 0 l- !bs = S.PS p o u- in return $! L.Chunk bs (inlinePerformIO (k b))--------------------------------------------------------------------------------- copied from Data.ByteString.Lazy----defaultSize :: Int-defaultSize = 32 * k - overhead- where k = 1024- overhead = 2 * sizeOf (undefined :: Int)------------------------------------------------------------------------------ | Sequence an IO operation on the buffer-withBuffer :: (Buffer -> IO Buffer) -> Builder-withBuffer f = Builder $ \ k buf -> f buf >>= k-{-# INLINE withBuffer #-}---- | Get the size of the buffer-withSize :: (Int -> Builder) -> Builder-withSize f = Builder $ \ k buf@(Buffer _ _ _ l) ->- runBuilder (f l) k buf---- | Map the resulting list of bytestrings.-mapBuilder :: (L.ByteString -> L.ByteString) -> Builder-mapBuilder f = Builder (fmap f .)------------------------------------------------------------------------------ | Ensure that there are at least @n@ many bytes available.-ensureFree :: Int -> Builder-ensureFree n = n `seq` withSize $ \ l ->- if n <= l then empty else- flush `append` withBuffer (const (newBuffer (max n defaultSize)))-{-# INLINE [0] ensureFree #-}---- | Ensure that @n@ bytes are available, and then use @f@ to write at--- most @n@ bytes into memory. @f@ must return the actual number of--- bytes written.-writeAtMost :: Int -> (Ptr Word8 -> IO Int) -> Builder-writeAtMost n f = ensureFree n `append` withBuffer (writeBuffer f)-{-# INLINE [0] writeAtMost #-}---- | Ensure that @n@ bytes are available, and then use @f@ to write--- exactly @n@ bytes into memory.-writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder-writeN n f = writeAtMost n (\ p -> f p >> return n)-{-# INLINE writeN #-}--writeBuffer :: (Ptr Word8 -> IO Int) -> Buffer -> IO Buffer-writeBuffer f (Buffer fp o u l) = do- n <- withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))- return $! Buffer fp o (u+n) (l-n)-{-# INLINE writeBuffer #-}--newBuffer :: Int -> IO Buffer-newBuffer size = do- fp <- S.mallocByteString size- return $! Buffer fp 0 0 size-{-# INLINE newBuffer #-}--------------------------------------------------------------------------------- We rely on the fromIntegral to do the right masking for us.--- The inlining here is critical, and can be worth 4x performance------- | Write a Word16 in big endian format-putWord16be :: Word16 -> Builder-putWord16be w = writeN 2 $ \p -> do- poke p (fromIntegral (shiftr_w16 w 8) :: Word8)- poke (p `plusPtr` 1) (fromIntegral (w) :: Word8)-{-# INLINE putWord16be #-}---- | Write a Word16 in little endian format-putWord16le :: Word16 -> Builder-putWord16le w = writeN 2 $ \p -> do- poke p (fromIntegral (w) :: Word8)- poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8)-{-# INLINE putWord16le #-}---- putWord16le w16 = writeN 2 (\p -> poke (castPtr p) w16)---- | Write a Word32 in big endian format-putWord32be :: Word32 -> Builder-putWord32be w = writeN 4 $ \p -> do- poke p (fromIntegral (shiftr_w32 w 24) :: Word8)- poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8)- poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8)- poke (p `plusPtr` 3) (fromIntegral (w) :: Word8)-{-# INLINE putWord32be #-}------- a data type to tag Put/Check. writes construct these which are then--- inlined and flattened. matching Checks will be more robust with rules.------- | Write a Word32 in little endian format-putWord32le :: Word32 -> Builder-putWord32le w = writeN 4 $ \p -> do- poke p (fromIntegral (w) :: Word8)- poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 8) :: Word8)- poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 16) :: Word8)- poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 w 24) :: Word8)-{-# INLINE putWord32le #-}---- on a little endian machine:--- putWord32le w32 = writeN 4 (\p -> poke (castPtr p) w32)---- | Write a Word64 in big endian format-putWord64be :: Word64 -> Builder-#if WORD_SIZE_IN_BITS < 64------ To avoid expensive 64 bit shifts on 32 bit machines, we cast to--- Word32, and write that----putWord64be w =- let a = fromIntegral (shiftr_w64 w 32) :: Word32- b = fromIntegral w :: Word32- in writeN 8 $ \p -> do- poke p (fromIntegral (shiftr_w32 a 24) :: Word8)- poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8)- poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 8) :: Word8)- poke (p `plusPtr` 3) (fromIntegral (a) :: Word8)- poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8)- poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8)- poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 8) :: Word8)- poke (p `plusPtr` 7) (fromIntegral (b) :: Word8)-#else-putWord64be w = writeN 8 $ \p -> do- poke p (fromIntegral (shiftr_w64 w 56) :: Word8)- poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8)- poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8)- poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 32) :: Word8)- poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 24) :: Word8)- poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 16) :: Word8)- poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 8) :: Word8)- poke (p `plusPtr` 7) (fromIntegral (w) :: Word8)-#endif-{-# INLINE putWord64be #-}---- | Write a Word64 in little endian format-putWord64le :: Word64 -> Builder--#if WORD_SIZE_IN_BITS < 64-putWord64le w =- let b = fromIntegral (shiftr_w64 w 32) :: Word32- a = fromIntegral w :: Word32- in writeN 8 $ \p -> do- poke (p) (fromIntegral (a) :: Word8)- poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 8) :: Word8)- poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 16) :: Word8)- poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 a 24) :: Word8)- poke (p `plusPtr` 4) (fromIntegral (b) :: Word8)- poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 8) :: Word8)- poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8)- poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8)-#else-putWord64le w = writeN 8 $ \p -> do- poke p (fromIntegral (w) :: Word8)- poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 8) :: Word8)- poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 16) :: Word8)- poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 24) :: Word8)- poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 32) :: Word8)- poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 40) :: Word8)- poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 48) :: Word8)- poke (p `plusPtr` 7) (fromIntegral (shiftr_w64 w 56) :: Word8)-#endif-{-# INLINE putWord64le #-}---- on a little endian machine:--- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64)----------------------------------------------------------------------------- Unaligned, word size ops---- | /O(1)./ A Builder taking a single native machine word. The word is--- written in host order, host endian form, for the machine you're on.--- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine,--- 4 bytes. Values written this way are not portable to--- different endian or word sized machines, without conversion.----putWordhost :: Word -> Builder-putWordhost w =- writeN (sizeOf (undefined :: Word)) (\p -> poke (castPtr p) w)-{-# INLINE putWordhost #-}---- | Write a Word16 in native host order and host endianness.--- 2 bytes will be written, unaligned.-putWord16host :: Word16 -> Builder-putWord16host w16 =- writeN (sizeOf (undefined :: Word16)) (\p -> poke (castPtr p) w16)-{-# INLINE putWord16host #-}---- | Write a Word32 in native host order and host endianness.--- 4 bytes will be written, unaligned.-putWord32host :: Word32 -> Builder-putWord32host w32 =- writeN (sizeOf (undefined :: Word32)) (\p -> poke (castPtr p) w32)-{-# INLINE putWord32host #-}---- | Write a Word64 in native host order.--- On a 32 bit machine we write two host order Word32s, in big endian form.--- 8 bytes will be written, unaligned.-putWord64host :: Word64 -> Builder-putWord64host w =- writeN (sizeOf (undefined :: Word64)) (\p -> poke (castPtr p) w)-{-# INLINE putWord64host #-}----------------------------------------------------------------------------- Unicode---- Code lifted from the text package by Bryan O'Sullivan.---- | Write a character using UTF-8 encoding.-putCharUtf8 :: Char -> Builder-putCharUtf8 x = writeAtMost 4 $ \ p -> case undefined of- _ | n <= 0x7F -> poke p c >> return 1- | n <= 0x07FF -> do- poke p a2- poke (p `plusPtr` 1) b2- return 2- | n <= 0xFFFF -> do- poke p a3- poke (p `plusPtr` 1) b3- poke (p `plusPtr` 2) c3- return 3- | otherwise -> do- poke p a4- poke (p `plusPtr` 1) b4- poke (p `plusPtr` 2) c4- poke (p `plusPtr` 3) d4- return 4- where- n = ord x- c = fromIntegral n- (a2,b2) = ord2 x- (a3,b3,c3) = ord3 x- (a4,b4,c4,d4) = ord4 x--ord2 :: Char -> (Word8,Word8)-ord2 c = (x1,x2)- where- n = ord c- x1 = fromIntegral $ (n `shiftR` 6) + 0xC0- x2 = fromIntegral $ (n .&. 0x3F) + 0x80--ord3 :: Char -> (Word8,Word8,Word8)-ord3 c = (x1,x2,x3)- where- n = ord c- x1 = fromIntegral $ (n `shiftR` 12) + 0xE0- x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80- x3 = fromIntegral $ (n .&. 0x3F) + 0x80--ord4 :: Char -> (Word8,Word8,Word8,Word8)-ord4 c = (x1,x2,x3,x4)- where- n = ord c- x1 = fromIntegral $ (n `shiftR` 18) + 0xF0- x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80- x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80- x4 = fromIntegral $ (n .&. 0x3F) + 0x80----------------------------------------------------------------------------- Unchecked shifts--{-# INLINE shiftr_w16 #-}-shiftr_w16 :: Word16 -> Int -> Word16-{-# INLINE shiftr_w32 #-}-shiftr_w32 :: Word32 -> Int -> Word32-{-# INLINE shiftr_w64 #-}-shiftr_w64 :: Word64 -> Int -> Word64--#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)-shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i)-shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i)--# if WORD_SIZE_IN_BITS < 64-shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)-# else-shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)-# endif--#else-shiftr_w16 = shiftR-shiftr_w32 = shiftR-shiftr_w64 = shiftR-#endif----------------------------------------------------------------------------- Some nice rules for Builder--#if __GLASGOW_HASKELL__ >= 700--- In versions of GHC prior to 7.0 these rules would make GHC believe--- that 'writeN' and 'ensureFree' are recursive and the rules wouldn't--- fire.-{-# RULES--"append/writeAtMost" forall a b (f::Ptr Word8 -> IO Int)- (g::Ptr Word8 -> IO Int) ws.- append (writeAtMost a f) (append (writeAtMost b g) ws) =- append (writeAtMost (a+b) (\p -> f p >>= \n ->- g (p `plusPtr` n) >>= \m ->- let s = n+m in s `seq` return s)) ws--"writeAtMost/writeAtMost" forall a b (f::Ptr Word8 -> IO Int)- (g::Ptr Word8 -> IO Int).- append (writeAtMost a f) (writeAtMost b g) =- writeAtMost (a+b) (\p -> f p >>= \n ->- g (p `plusPtr` n) >>= \m ->- let s = n+m in s `seq` return s)--"ensureFree/ensureFree" forall a b .- append (ensureFree a) (ensureFree b) = ensureFree (max a b)--"flush/flush"- append flush flush = flush-- #-}-#endif
− src/Data/Binary/Builder/Internal.hs
@@ -1,28 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 701-{-# LANGUAGE Trustworthy #-}-#endif--------------------------------------------------------------------------------- |--- Module : Data.Binary.Builder.Internal--- Copyright : Lennart Kolmodin, Ross Paterson--- License : BSD3-style (see LICENSE)--- --- Maintainer : Lennart Kolmodin <kolmodin@gmail.com>--- Stability : experimental--- Portability : portable to Hugs and GHC------ A module containing semi-public 'Builder' internals that exposes--- low level construction functions. Modules which extend the--- 'Builder' system will need to use this module while ideally most--- users will be able to make do with the public interface modules.-----------------------------------------------------------------------------------module Data.Binary.Builder.Internal (- -- * Low-level construction of Builders- writeN- , writeAtMost- ) where--import Data.Binary.Builder.Base
+ src/Data/Binary/Class.hs view
@@ -0,0 +1,1022 @@+{-# LANGUAGE CPP, FlexibleContexts #-}+{-# 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 MIN_VERSION_base(4,7,0)+#define HAS_FIXED_CONSTRUCTOR+#endif++-----------------------------------------------------------------------------+-- |+-- Module : Data.Binary.Class+-- Copyright : Lennart Kolmodin+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Lennart Kolmodin <kolmodin@gmail.com>+-- Stability : unstable+-- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances+--+-- Typeclass and instances for binary serialization.+--+-----------------------------------------------------------------------------++module Data.Binary.Class (++ -- * The Binary class+ Binary(..)++ -- * Support for generics+ , 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.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+import qualified Data.IntSet as IntSet+import qualified Data.Ratio as R++import qualified Data.Tree as T++import Data.Array.Unboxed++import GHC.Generics++#ifdef HAS_NATURAL+import Numeric.Natural+#endif++import qualified Data.Fixed as Fixed++--+-- This isn't available in older Hugs or older GHC+--+import qualified Data.Sequence as Seq+import qualified Data.Foldable as Fold++import GHC.Fingerprint++import Data.Version (Version(..))++------------------------------------------------------------------------++-- 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)++-- | The 'Binary' class provides 'put' and 'get', methods to encode and+-- decode a Haskell value to a lazy 'ByteString'. It mirrors the 'Read' and+-- 'Show' classes for textual representation of Haskell types, and is+-- suitable for serialising Haskell values to disk, over the network.+--+-- For decoding and generating simple external binary formats (e.g. C+-- structures), Binary may be used, but in general is not suitable+-- for complex protocols. Instead use the 'Put' and 'Get' primitives+-- directly.+--+-- Instances of Binary should satisfy the following property:+--+-- > decode . encode == id+--+-- That is, the 'get' and 'put' methods should be the inverse of each+-- other. A range of instances are provided for basic Haskell types.+--+class Binary t where+ -- | Encode a value in the Put monad.+ put :: t -> Put+ -- | Decode a value in the Get monad+ get :: Get t++ -- | 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, GBinaryGet (Rep t)) => Get t+ get = to `fmap` gget++{-# 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 () = mempty+ get = return ()++-- Bools are encoded as a byte in the range 0 .. 1+instance Binary Bool where+ put = putWord8 . fromIntegral . fromEnum+ 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 = 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++-- 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 = 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 = 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 = 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 = 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 = 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 = putInt64be . fromIntegral+ {-# INLINE putList #-}+ putList xs =+ put (length xs)+ <> putBuilder (Prim.primMapListFixed Prim.int64BE (map fromIntegral xs))+ get = liftM fromIntegral getInt64be++------------------------------------------------------------------------+--+-- Portable, and pretty efficient, serialisation of Integer+--++-- Fixed-size type for a subset of Integer+type SmallInt = Int32++-- Integers are encoded in two ways: if they fit inside a SmallInt,+-- they're written as a byte tag, and that value. If the Integer value+-- is too large to fit in a SmallInt, it is written as a byte array,+-- along with a sign and length field.++instance Binary Integer where++ {-# INLINE put #-}+ 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 =+ putWord8 1+ <> put sign+ <> put (unroll (abs n)) -- unroll the bytes+ where+ sign = fromIntegral (signum n) :: Word8++ {-# INLINE get #-}+ get = do+ tag <- get :: Get Word8+ case tag of+ 0 -> liftM fromIntegral (get :: Get SmallInt)+ _ -> do sign <- get+ bytes <- get+ 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, Bits a) => a -> [Word8]+unroll = unfoldr step+ where+ step 0 = Nothing+ step i = Just (fromIntegral i, i `shiftR` 8)++roll :: (Integral a, Bits a) => [Word8] -> a+roll = foldl' unstep 0 . reverse+ where+ 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 =+ putWord8 0+ <> put (fromIntegral n :: NaturalWord) -- fast path+ where+ hi = fromIntegral (maxBound :: NaturalWord) :: Natural++ put n =+ putWord8 1+ <> put (unroll (abs n)) -- unroll the bytes++ {-# INLINE get #-}+ get = do+ tag <- get :: Get Word8+ case tag of+ 0 -> liftM fromIntegral (get :: Get NaturalWord)+ _ -> do bytes <- get+ return $! roll bytes+#endif++{-++--+-- An efficient, raw serialisation for Integer (GHC only)+--++-- TODO This instance is not architecture portable. GMP stores numbers as+-- arrays of machine sized words, so the byte format is not portable across+-- architectures with different endianness and word size.++import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy)+import GHC.Base hiding (ord, chr)+import GHC.Prim+import GHC.Ptr (Ptr(..))+import GHC.IOBase (IO(..))++instance Binary Integer where+ put (S# i) = putWord8 0 >> put (I# i)+ put (J# s ba) = do+ putWord8 1+ put (I# s)+ put (BA ba)++ get = do+ b <- getWord8+ case b of+ 0 -> do (I# i#) <- get+ return (S# i#)+ _ -> do (I# s#) <- get+ (BA a#) <- get+ return (J# s# a#)++instance Binary ByteArray where++ -- Pretty safe.+ put (BA ba) =+ let sz = sizeofByteArray# ba -- (primitive) in *bytes*+ addr = byteArrayContents# ba+ bs = unsafePackAddress (I# sz) addr+ in put bs -- write as a ByteString. easy, yay!++ -- Pretty scary. Should be quick though+ get = do+ (fp, off, n@(I# sz)) <- liftM toForeignPtr get -- so decode a ByteString+ assert (off == 0) $ return $ unsafePerformIO $ do+ (MBA arr) <- newByteArray sz -- and copy it into a ByteArray#+ let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe?+ withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n)+ freezeByteArray arr++-- wrapper for ByteArray#+data ByteArray = BA {-# UNPACK #-} !ByteArray#+data MBA = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld)++newByteArray :: Int# -> IO MBA+newByteArray sz = IO $ \s ->+ case newPinnedByteArray# sz s of { (# s', arr #) ->+ (# s', MBA arr #) }++freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray+freezeByteArray arr = IO $ \s ->+ case unsafeFreezeByteArray# arr s of { (# s', arr' #) ->+ (# s', BA arr' #) }++-}++instance (Binary a,Integral a) => Binary (R.Ratio a) where+ 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 = putCharUtf8+ putList str = put (length str) <> putStringUtf8 str+ get = do+ let getByte = liftM (fromIntegral :: Word8 -> Int) get+ shiftL6 = flip shiftL 6 :: Int -> Int+ w <- getByte+ r <- case () of+ _ | w < 0x80 -> return w+ | w < 0xe0 -> do+ x <- liftM (xor 0x80) getByte+ return (x .|. shiftL6 (xor 0xc0 w))+ | w < 0xf0 -> do+ x <- liftM (xor 0x80) getByte+ y <- liftM (xor 0x80) getByte+ return (y .|. shiftL6 (x .|. shiftL6+ (xor 0xe0 w)))+ | otherwise -> do+ x <- liftM (xor 0x80) getByte+ y <- liftM (xor 0x80) getByte+ z <- liftM (xor 0x80) getByte+ return (z .|. shiftL6 (y .|. shiftL6+ (x .|. shiftL6 (xor 0xf0 w))))+ getChr r+ where+ getChr w+ | w <= 0x10ffff = return $! toEnum $ fromEnum w+ | otherwise = fail "Not a valid Unicode code point!"++------------------------------------------------------------------------+-- Instances for the first few tuples++instance (Binary a, Binary b) => Binary (a,b) where+ {-# INLINE put #-}+ put (a,b) = put a <> put b+ {-# INLINE get #-}+ get = liftM2 (,) get get++instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where+ {-# INLINE put #-}+ put (a,b,c) = put a <> put b <> put c+ {-# INLINE get #-}+ get = liftM3 (,,) get get get++instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where+ {-# INLINE put #-}+ put (a,b,c,d) = put a <> put b <> put c <> put d+ {-# INLINE get #-}+ get = liftM4 (,,,) get get get get++instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where+ {-# INLINE put #-}+ put (a,b,c,d,e) = put a <> put b <> put c <> put d <> put e+ {-# INLINE get #-}+ get = liftM5 (,,,,) get get get get get++--+-- and now just recurse:+--++instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)+ => Binary (a,b,c,d,e,f) where+ {-# INLINE put #-}+ put (a,b,c,d,e,f) = put (a,(b,c,d,e,f))+ {-# INLINE get #-}+ get = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f)++instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g)+ => Binary (a,b,c,d,e,f,g) where+ {-# INLINE put #-}+ put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g))+ {-# INLINE get #-}+ get = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g)++instance (Binary a, Binary b, Binary c, Binary d, Binary e,+ Binary f, Binary g, Binary h)+ => Binary (a,b,c,d,e,f,g,h) where+ {-# INLINE put #-}+ put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h))+ {-# INLINE get #-}+ get = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h)++instance (Binary a, Binary b, Binary c, Binary d, Binary e,+ Binary f, Binary g, Binary h, Binary i)+ => Binary (a,b,c,d,e,f,g,h,i) where+ {-# INLINE put #-}+ put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i))+ {-# INLINE get #-}+ get = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i)++instance (Binary a, Binary b, Binary c, Binary d, Binary e,+ Binary f, Binary g, Binary h, Binary i, Binary j)+ => Binary (a,b,c,d,e,f,g,h,i,j) where+ {-# INLINE put #-}+ put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j))+ {-# INLINE get #-}+ get = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j)++------------------------------------------------------------------------+-- Container types++#if MIN_VERSION_base(4,8,0)+instance Binary a => Binary (Identity a) where+ put (Identity x) = put x+ get = Identity <$> get+#endif++instance Binary a => Binary [a] where+ put = putList+ get = do n <- get :: Get Int+ getMany n++-- | 'getMany n' get 'n' elements in order, without blowing the stack.+getMany :: Binary a => Int -> Get [a]+getMany n = go [] n+ where+ go xs 0 = return $! reverse xs+ go xs i = do x <- get+ -- we must seq x to avoid stack overflows due to laziness in+ -- (>>=)+ x `seq` go (x:xs) (i-1)+{-# INLINE getMany #-}++instance (Binary a) => Binary (Maybe a) where+ put Nothing = putWord8 0+ put (Just x) = putWord8 1 <> put x+ get = do+ w <- getWord8+ case w of+ 0 -> return Nothing+ _ -> 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+ get = do+ w <- getWord8+ case w of+ 0 -> liftM Left get+ _ -> liftM Right get++------------------------------------------------------------------------+-- ByteStrings (have specially efficient instances)++instance Binary B.ByteString where+ put bs = put (B.length bs)+ <> putByteString bs+ get = get >>= getByteString++--+-- Using old versions of fps, this is a type synonym, and non portable+--+-- Requires 'flexible instances'+--+instance Binary ByteString where+ 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)+ 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)+ get = liftM Map.fromDistinctAscList get++instance Binary IntSet.IntSet where+ 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)+ get = liftM IntMap.fromDistinctAscList get++------------------------------------------------------------------------+-- Queues and Sequences++--+-- 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+ get = do n <- get :: Get Int+ rep Seq.empty n get+ where rep xs 0 _ = return $! xs+ rep xs n g = xs `seq` n `seq` do+ x <- g+ rep (xs Seq.|> x) (n-1) g++------------------------------------------------------------------------+-- Floating point++instance Binary Double where+ put d = put (decodeFloat d)+ get = do+ x <- get+ y <- get+ return $! encodeFloat x y++instance Binary Float where+ put f = put (decodeFloat f)+ get = do+ x <- get+ y <- get+ return $! encodeFloat x y++------------------------------------------------------------------------+-- Trees++instance (Binary e) => Binary (T.Tree e) where+ 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 =+ put (bounds a)+ <> put (rangeSize $ bounds a) -- write the length+ <> mapM_ put (elems a) -- now the elems.+ get = do+ bs <- get+ n <- get -- read the length+ xs <- getMany n -- now the elems.+ return (listArray bs xs)++--+-- 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 =+ put (bounds a)+ <> put (rangeSize $ bounds a) -- now write the length+ <> mapM_ put (elems a)+ get = do+ bs <- get+ n <- get+ xs <- getMany n+ return (listArray bs xs)++------------------------------------------------------------------------+-- Fingerprints++-- | /Since: 0.7.6.0/+instance Binary Fingerprint where+ put (Fingerprint x1 x2) = put x1 <> put x2+ get = do+ x1 <- get+ x2 <- get+ return $! Fingerprint x1 x2++------------------------------------------------------------------------+-- Version++-- | /Since: 0.8.0.0/+instance Binary Version where+ put (Version br tags) = put br <> put tags+ get = Version <$> get <*> get++------------------------------------------------------------------------+-- Data.Monoid datatypes++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Monoid.Dual a) where+ get = fmap Monoid.Dual get+ put = put . Monoid.getDual++-- | /Since: 0.8.4.0/+instance Binary Monoid.All where+ get = fmap Monoid.All get+ put = put . Monoid.getAll++-- | /Since: 0.8.4.0/+instance Binary Monoid.Any where+ get = fmap Monoid.Any get+ put = put . Monoid.getAny++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Monoid.Sum a) where+ get = fmap Monoid.Sum get+ put = put . Monoid.getSum++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Monoid.Product a) where+ get = fmap Monoid.Product get+ put = put . Monoid.getProduct++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Monoid.First a) where+ get = fmap Monoid.First get+ put = put . Monoid.getFirst++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Monoid.Last a) where+ get = fmap Monoid.Last get+ put = put . Monoid.getLast++#if MIN_VERSION_base(4,8,0)+-- | /Since: 0.8.4.0/+instance Binary (f a) => Binary (Monoid.Alt f a) where+ get = fmap Monoid.Alt get+ put = put . Monoid.getAlt+#endif++#if MIN_VERSION_base(4,9,0)+------------------------------------------------------------------------+-- Data.Semigroup datatypes++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Semigroup.Min a) where+ get = fmap Semigroup.Min get+ put = put . Semigroup.getMin++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Semigroup.Max a) where+ get = fmap Semigroup.Max get+ put = put . Semigroup.getMax++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Semigroup.First a) where+ get = fmap Semigroup.First get+ put = put . Semigroup.getFirst++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Semigroup.Last a) where+ get = fmap Semigroup.Last get+ put = put . Semigroup.getLast++-- | /Since: 0.8.4.0/+instance Binary a => Binary (Semigroup.Option a) where+ get = fmap Semigroup.Option get+ put = put . Semigroup.getOption++-- | /Since: 0.8.4.0/+instance Binary m => Binary (Semigroup.WrappedMonoid m) where+ get = fmap Semigroup.WrapMonoid get+ put = put . Semigroup.unwrapMonoid++-- | /Since: 0.8.4.0/+instance (Binary a, Binary b) => Binary (Semigroup.Arg a b) where+ get = liftM2 Semigroup.Arg get get+ put (Semigroup.Arg a b) = put a <> put b++------------------------------------------------------------------------+-- Non-empty lists++-- | /Since: 0.8.4.0/+instance Binary a => Binary (NE.NonEmpty a) where+ get = fmap NE.fromList get+ put = put . NE.toList+#endif++------------------------------------------------------------------------+-- Typeable/Reflection++#if MIN_VERSION_base(4,10,0)++-- $typeable-instances+--+-- 'Binary' instances for GHC's "Type.Reflection", "Data.Typeable", and+-- kind-system primitives are only provided with @base-4.10.0@ (shipped with GHC+-- 8.2.1). In prior GHC releases some of these instances were provided by+-- 'GHCi.TH.Binary' in the @ghci@ package.+--+-- These include instances for,+--+-- * 'VecCount'+-- * 'VecElem'+-- * 'RuntimeRep'+-- * 'KindRep'+-- * 'TypeLitSort'+-- * 'TyCon'+-- * 'TypeRep'+-- * 'SomeTypeRep' (also known as 'Data.Typeable.TypeRep')+--++-- | @since 0.8.5.0. See #typeable-instances#+instance Binary VecCount where+ put = putWord8 . fromIntegral . fromEnum+ get = toEnum . fromIntegral <$> getWord8++-- | @since 0.8.5.0. See #typeable-instances#+instance Binary VecElem where+ put = putWord8 . fromIntegral . fromEnum+ get = toEnum . fromIntegral <$> getWord8++-- | @since 0.8.5.0. See #typeable-instances#+instance Binary RuntimeRep where+ put (VecRep a b) = putWord8 0 >> put a >> put b+ put (TupleRep reps) = putWord8 1 >> put reps+ put (SumRep reps) = putWord8 2 >> put reps+ put LiftedRep = putWord8 3+ put UnliftedRep = putWord8 4+ put IntRep = putWord8 5+ put WordRep = putWord8 6+ put Int64Rep = putWord8 7+ put Word64Rep = putWord8 8+ put AddrRep = putWord8 9+ put FloatRep = putWord8 10+ put DoubleRep = putWord8 11++ get = do+ tag <- getWord8+ case tag of+ 0 -> VecRep <$> get <*> get+ 1 -> TupleRep <$> get+ 2 -> SumRep <$> get+ 3 -> pure LiftedRep+ 4 -> pure UnliftedRep+ 5 -> pure IntRep+ 6 -> pure WordRep+ 7 -> pure Int64Rep+ 8 -> pure Word64Rep+ 9 -> pure AddrRep+ 10 -> pure FloatRep+ 11 -> pure DoubleRep+ _ -> fail "GHCi.TH.Binary.putRuntimeRep: invalid tag"++-- | @since 0.8.5.0. See #typeable-instances#+instance Binary TyCon where+ put tc = do+ put (tyConPackage tc)+ put (tyConModule tc)+ put (tyConName tc)+ put (tyConKindArgs tc)+ put (tyConKindRep tc)+ get = mkTyCon <$> get <*> get <*> get <*> get <*> get++-- | @since 0.8.5.0. See #typeable-instances#+instance Binary KindRep where+ put (KindRepTyConApp tc k) = putWord8 0 >> put tc >> put k+ put (KindRepVar bndr) = putWord8 1 >> put bndr+ put (KindRepApp a b) = putWord8 2 >> put a >> put b+ put (KindRepFun a b) = putWord8 3 >> put a >> put b+ put (KindRepTYPE r) = putWord8 4 >> put r+ put (KindRepTypeLit sort r) = putWord8 5 >> put sort >> put r++ get = do+ tag <- getWord8+ case tag of+ 0 -> KindRepTyConApp <$> get <*> get+ 1 -> KindRepVar <$> get+ 2 -> KindRepApp <$> get <*> get+ 3 -> KindRepFun <$> get <*> get+ 4 -> KindRepTYPE <$> get+ 5 -> KindRepTypeLit <$> get <*> get+ _ -> fail "GHCi.TH.Binary.putKindRep: invalid tag"++-- | @since 0.8.5.0. See #typeable-instances#+instance Binary TypeLitSort where+ put TypeLitSymbol = putWord8 0+ put TypeLitNat = putWord8 1+ get = do+ tag <- getWord8+ case tag of+ 0 -> pure TypeLitSymbol+ 1 -> pure TypeLitNat+ _ -> fail "GHCi.TH.Binary.putTypeLitSort: invalid tag"++putTypeRep :: TypeRep a -> Put+-- Special handling for TYPE, (->), and RuntimeRep due to recursive kind+-- relations.+-- See Note [Mutually recursive representations of primitive types]+putTypeRep rep -- Handle Type specially since it's so common+ | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)+ = put (0 :: Word8)+putTypeRep (Con' con ks) = do+ put (1 :: Word8)+ put con+ put ks+putTypeRep (App f x) = do+ put (2 :: Word8)+ putTypeRep f+ putTypeRep x+putTypeRep (Fun arg res) = do+ put (3 :: Word8)+ putTypeRep arg+ putTypeRep res+putTypeRep _ = fail "GHCi.TH.Binary.putTypeRep: Impossible"++getSomeTypeRep :: Get SomeTypeRep+getSomeTypeRep = do+ tag <- get :: Get Word8+ case tag of+ 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)+ 1 -> do con <- get :: Get TyCon+ ks <- get :: Get [SomeTypeRep]+ return $ SomeTypeRep $ mkTrCon con ks+ 2 -> do SomeTypeRep f <- getSomeTypeRep+ SomeTypeRep x <- getSomeTypeRep+ case typeRepKind f of+ Fun arg res ->+ case arg `eqTypeRep` typeRepKind x of+ Just HRefl -> do+ case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of+ Just HRefl -> return $ SomeTypeRep $ mkTrApp f x+ _ -> failure "Kind mismatch" []+ _ -> failure "Kind mismatch"+ [ "Found argument of kind: " ++ show (typeRepKind x)+ , "Where the constructor: " ++ show f+ , "Expects an argument of kind: " ++ show arg+ ]+ _ -> failure "Applied non-arrow type"+ [ "Applied type: " ++ show f+ , "To argument: " ++ show x+ ]+ 3 -> do SomeTypeRep arg <- getSomeTypeRep+ SomeTypeRep res <- getSomeTypeRep+ case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of+ Just HRefl ->+ case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of+ Just HRefl -> return $ SomeTypeRep $ Fun arg res+ Nothing -> failure "Kind mismatch" []+ Nothing -> failure "Kind mismatch" []+ _ -> failure "Invalid SomeTypeRep" []+ where+ failure description info =+ fail $ unlines $ [ "GHCi.TH.Binary.getSomeTypeRep: "++description ]+ ++ map (" "++) info++instance Typeable a => Binary (TypeRep (a :: k)) where+ put = putTypeRep+ get = do+ SomeTypeRep rep <- getSomeTypeRep+ case rep `eqTypeRep` expected of+ Just HRefl -> pure rep+ Nothing -> fail $ unlines+ [ "GHCi.TH.Binary: Type mismatch"+ , " Deserialized type: " ++ show rep+ , " Expected type: " ++ show expected+ ]+ where expected = typeRep :: TypeRep a++instance Binary SomeTypeRep where+ put (SomeTypeRep rep) = putTypeRep rep+ get = getSomeTypeRep+#endif+
+ src/Data/Binary/FloatCast.hs view
@@ -0,0 +1,45 @@++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Trustworthy #-}++-- | This module was written based on+-- <http://hackage.haskell.org/package/reinterpret-cast-0.1.0/docs/src/Data-ReinterpretCast-Internal-ImplArray.html>.+--+-- Implements casting via a 1-elemnt STUArray, as described in+-- <http://stackoverflow.com/a/7002812/263061>.+module Data.Binary.FloatCast+ ( floatToWord+ , wordToFloat+ , doubleToWord+ , wordToDouble+ ) where++import Data.Word (Word32, Word64)+import Data.Array.ST (newArray, readArray, MArray, STUArray)+import Data.Array.Unsafe (castSTUArray)+import GHC.ST (runST, ST)++-- | Reinterpret-casts a `Float` to a `Word32`.+floatToWord :: Float -> Word32+floatToWord x = runST (cast x)+{-# INLINE floatToWord #-}++-- | Reinterpret-casts a `Word32` to a `Float`.+wordToFloat :: Word32 -> Float+wordToFloat x = runST (cast x)+{-# INLINE wordToFloat #-}++-- | Reinterpret-casts a `Double` to a `Word64`.+doubleToWord :: Double -> Word64+doubleToWord x = runST (cast x)+{-# INLINE doubleToWord #-}++-- | Reinterpret-casts a `Word64` to a `Double`.+wordToDouble :: Word64 -> Double+wordToDouble x = runST (cast x)+{-# INLINE wordToDouble #-}++cast :: (MArray (STUArray s) a (ST s),+ MArray (STUArray s) b (ST s)) => a -> ST s b+cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0+{-# INLINE cast #-}
+ src/Data/Binary/Generic.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures,+ ScopedTypeVariables, TypeOperators, TypeSynonymInstances #-}+{-# LANGUAGE Safe #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++#if __GLASGOW_HASKELL__ >= 800+#define HAS_DATA_KIND+#endif++-----------------------------------------------------------------------------+-- |+-- Module : Data.Binary.Generic+-- Copyright : Bryan O'Sullivan+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Bryan O'Sullivan <bos@serpentine.com>+-- Stability : unstable+-- Portability : Only works with GHC 7.2 and newer+--+-- Instances for supporting GHC generics.+--+-----------------------------------------------------------------------------+module Data.Binary.Generic+ (+ ) where++import Control.Applicative+import Data.Binary.Class+import Data.Binary.Get+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 GBinaryPut V1 where+ gput _ = pure ()++instance GBinaryGet V1 where+ gget = return undefined++-- Constructor without arguments+instance GBinaryPut U1 where+ gput U1 = pure ()++instance GBinaryGet U1 where+ gget = return U1++-- Product: constructor with parameters+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 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 => GBinaryPut (K1 i a) where+ gput = put . unK1++instance Binary a => GBinaryGet (K1 i a) where+ gget = K1 <$> get++-- Borrowed from the cereal package.++-- The following GBinary instance for sums has support for serializing+-- types with up to 2^64-1 constructors. It will use the minimal+-- number of bytes needed to encode the constructor. For example when+-- a type has 2^8 constructors or less it will use a single byte to+-- encode the constructor. If it has 2^16 constructors or less it will+-- use two bytes, and so on till 2^64-1.++#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD)+#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size)+#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)++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+ size = unTagged (sumSize :: Tagged (a :+: b) Word64)++sizeError :: Show size => String -> size -> error+sizeError s size =+ error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors"++------------------------------------------------------------------------++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 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 (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+ where+ sizeL = size `shiftR` 1+ sizeR = size - sizeL++instance GBinaryGet a => GSumGet (C1 c a) where+ getSum _ _ = gget++instance GBinaryPut a => GSumPut (C1 c a) where+ putSum !code _ x = put code <> gput x++------------------------------------------------------------------------++class SumSize f where+ sumSize :: Tagged f Word64++#ifdef HAS_DATA_KIND+newtype Tagged (s :: Type -> Type) b = Tagged {unTagged :: b}+#else+newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b}+#endif++instance (SumSize a, SumSize b) => SumSize (a :+: b) where+ sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) ++ unTagged (sumSize :: Tagged b Word64)++instance SumSize (C1 c a) where+ sumSize = Tagged 1
src/Data/Binary/Get.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}--- MagicHash, UnboxedTuples for unboxed shifts-#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE CPP, RankNTypes, MagicHash, BangPatterns #-} {-# LANGUAGE Trustworthy #-}++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+#include "MachDeps.h" #endif -----------------------------------------------------------------------------@@ -9,43 +10,156 @@ -- Module : Data.Binary.Get -- Copyright : Lennart Kolmodin -- License : BSD3-style (see LICENSE)--- +-- -- Maintainer : Lennart Kolmodin <kolmodin@gmail.com> -- Stability : experimental -- Portability : portable to Hugs and GHC. ----- The Get monad. A monad for efficiently building structures from--- encoded lazy ByteStrings+-- The 'Get' monad. A monad for efficiently building structures from+-- encoded lazy ByteStrings. --+-- Primitives are available to decode words of various sizes, both big and+-- little endian.+--+-- Let's decode binary data representing illustrated here.+-- In this example the values are in little endian.+--+-- > +------------------+--------------+-----------------++-- > | 32 bit timestamp | 32 bit price | 16 bit quantity |+-- > +------------------+--------------+-----------------++--+-- A corresponding Haskell value looks like this:+--+-- @+--data Trade = Trade+-- { timestamp :: !'Word32'+-- , price :: !'Word32'+-- , qty :: !'Word16'+-- } deriving ('Show')+-- @+--+-- 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.+-- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#unpack-pragma>+--+-- Now, let's have a look at a decoder for this format.+--+-- @+--getTrade :: 'Get' Trade+--getTrade = do+-- timestamp <- 'getWord32le'+-- price <- 'getWord32le'+-- quantity <- 'getWord16le'+-- return '$!' Trade timestamp price quantity+-- @+--+-- Or even simpler using applicative style:+--+-- @+--getTrade' :: 'Get' Trade+--getTrade' = Trade '<$>' 'getWord32le' '<*>' 'getWord32le' '<*>' 'getWord16le'+-- @+--+-- 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.+--+-- Let's first define a function that decodes many @Trade@s.+--+-- @+--getTrades :: Get [Trade]+--getTrades = do+-- empty <- 'isEmpty'+-- if empty+-- then return []+-- else do trade <- getTrade+-- trades <- getTrades+-- return (trade:trades)+-- @+--+-- Finally, we run the decoder:+--+-- @+--lazyIOExample :: IO [Trade]+--lazyIOExample = do+-- input <- BL.readFile \"trades.bin\"+-- return ('runGet' getTrades input)+-- @+--+-- This decoder has the downside that it will need to read all the input before+-- it can return. On the other hand, it will not return anything until+-- it knows it could decode without any decoder errors.+--+-- You could also refactor to a left-fold, to decode in a more streaming fashion,+-- and get the following decoder. It will start to return data without knowing+-- that it can decode all input.+--+-- @+--incrementalExample :: BL.ByteString -> [Trade]+--incrementalExample input0 = go decoder input0+-- where+-- decoder = 'runGetIncremental' getTrade+-- go :: 'Decoder' Trade -> BL.ByteString -> [Trade]+-- go ('Done' leftover _consumed trade) input =+-- trade : go decoder (BL.chunk leftover input)+-- go ('Partial' k) input =+-- go (k . takeHeadChunk $ input) (dropHeadChunk input)+-- go ('Fail' _leftover _consumed msg) _input =+-- error msg+--+--takeHeadChunk :: BL.ByteString -> Maybe BS.ByteString+--takeHeadChunk lbs =+-- case lbs of+-- (BL.Chunk bs _) -> Just bs+-- _ -> Nothing+--+--dropHeadChunk :: BL.ByteString -> BL.ByteString+--dropHeadChunk lbs =+-- case lbs of+-- (BL.Chunk _ lbs') -> lbs'+-- _ -> BL.Empty+-- @+--+-- The @lazyIOExample@ uses lazy I/O to read the file from the disk, which is+-- not suitable in all applications, and certainly not if you need to read+-- from a socket which has higher likelihood to fail. To address these needs,+-- use the incremental input method like in @incrementalExample@.+-- For an example of how to read incrementally from a Handle,+-- see the implementation of 'decodeFileOrFail' in "Data.Binary". ----------------------------------------------------------------------------- -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)-#include "MachDeps.h"-#endif module Data.Binary.Get ( - -- * The Get type+ -- * The Get monad Get++ -- * The lazy input interface+ -- $lazyinterface , runGet- , runGetState+ , runGetOrFail+ , ByteOffset - -- * Parsing+ -- * The incremental input interface+ -- $incrementalinterface+ , Decoder(..)+ , runGetIncremental++ -- ** Providing input+ , pushChunk+ , pushChunks+ , pushEndOfInput++ -- * Decoding , skip- , uncheckedSkip+ , isEmpty+ , bytesRead+ , isolate , lookAhead , lookAheadM , lookAheadE- , uncheckedLookAhead-- -- * Utility- , bytesRead- , getBytes- , remaining- , isEmpty-- -- * Parsing particular types- , getWord8+ , label -- ** ByteStrings , getByteString@@ -53,447 +167,411 @@ , getLazyByteStringNul , getRemainingLazyByteString - -- ** Big-endian reads+ -- ** Decoding Words+ , getWord8++ -- *** Big-endian decoding , getWord16be , getWord32be , getWord64be - -- ** Little-endian reads+ -- *** Little-endian decoding , getWord16le , getWord32le , getWord64le - -- ** Host-endian, unaligned reads+ -- *** Host-endian, unaligned decoding , getWordhost , getWord16host , getWord32host , getWord64host - ) where+ -- ** Decoding Ints+ , getInt8 -import Control.Monad (when,liftM,ap)-import Control.Monad.Fix-import Data.Maybe (isNothing)+ -- *** Big-endian decoding+ , getInt16be+ , getInt32be+ , getInt64be -import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L+ -- *** Little-endian decoding+ , getInt16le+ , getInt32le+ , getInt64le -#ifdef BYTESTRING_IN_BASE-import qualified Data.ByteString.Base as B-#else-import qualified Data.ByteString.Internal as B-import qualified Data.ByteString.Lazy.Internal as L-#endif+ -- *** Host-endian, unaligned decoding+ , getInthost+ , getInt16host+ , getInt32host+ , getInt64host -#ifdef APPLICATIVE_IN_BASE-import Control.Applicative (Applicative(..))+ -- ** 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+import qualified Data.ByteString.Unsafe as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Internal as L --- used by splitAtST-import Control.Monad.ST-import Data.STRef+import Data.Binary.Get.Internal hiding ( Decoder(..), runGetIncremental )+import qualified Data.Binary.Get.Internal as I #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+-- needed for (# unboxing #) with magic hash import GHC.Base import GHC.Word-import GHC.Int #endif --- | The parse state-data S = S {-# UNPACK #-} !B.ByteString -- current chunk- L.ByteString -- the rest of the input- {-# UNPACK #-} !Int64 -- bytes read---- | The Get monad is just a State monad carrying around the input ByteString--- We treat it as a strict state monad. -newtype Get a = Get { unGet :: S -> (# a, S #) }--instance Functor Get where- fmap f m = Get (\s -> case unGet m s of- (# a, s' #) -> (# f a, s' #))- {-# INLINE fmap #-}+-- needed for casting words to float/double+import Data.Binary.FloatCast (wordToFloat, wordToDouble) -#ifdef APPLICATIVE_IN_BASE-instance Applicative Get where- pure = return- (<*>) = ap-#endif+-- $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+-- parsing, unless lazy I/O is used.+--+-- There is no way to provide more input other than the initial data. To be+-- able to incrementally give more data, see the incremental input interface. --- Definition directly from Control.Monad.State.Strict-instance Monad Get where- return a = Get $ \s -> (# a, s #)- {-# INLINE return #-}+-- $incrementalinterface+-- The incremental interface gives you more control over how input is+-- provided during parsing. This lets you e.g. interleave parsing and+-- I\/O.+--+-- The incremental interface consumes a strict 'B.ByteString' at a time, each+-- being part of the total amount of input. If your decoder needs more input to+-- finish it will return a 'Partial' with a continuation.+-- If there is no more input, provide it 'Nothing'.+--+-- 'Fail' will be returned if it runs into an error, together with a message,+-- the position and the remaining input.+-- If it succeeds it will return 'Done' with the resulting value,+-- the position and the remaining input. - m >>= k = Get $ \s -> case unGet m s of- (# a, s' #) -> unGet (k a) s'- {-# INLINE (>>=) #-}+-- | A decoder procuced by running a 'Get' monad.+data Decoder a = Fail !B.ByteString {-# UNPACK #-} !ByteOffset String+ -- ^ The decoder ran into an error. The decoder either used+ -- 'fail' or was not provided enough input. Contains any+ -- unconsumed input and the number of bytes consumed.+ | Partial (Maybe B.ByteString -> Decoder a)+ -- ^ The decoder has consumed the available input and needs+ -- more to continue. Provide 'Just' if more input is available+ -- and 'Nothing' otherwise, and you will get a new 'Decoder'.+ | Done !B.ByteString {-# UNPACK #-} !ByteOffset a+ -- ^ The decoder has successfully finished. Except for the+ -- output value you also get any unused input as well as the+ -- number of bytes consumed. - fail = failDesc+-- | Run a 'Get' monad. See 'Decoder' for what to do next, like providing+-- input, handling decoder errors and to get the output value.+-- Hint: Use the helper functions 'pushChunk', 'pushChunks' and+-- 'pushEndOfInput'.+runGetIncremental :: Get a -> Decoder a+runGetIncremental = calculateOffset . I.runGetIncremental -instance MonadFix Get where- mfix f = Get $ \s -> let (a,s') = case unGet (f a) s of- (# a', s'' #) -> (a',s'')- in (# a,s' #)+calculateOffset :: I.Decoder a -> Decoder a+calculateOffset r0 = go r0 0+ where+ go r !acc = case r of+ I.Done inp a -> Done inp (acc - fromIntegral (B.length inp)) a+ I.Fail inp s -> Fail inp (acc - fromIntegral (B.length inp)) s+ I.Partial k ->+ Partial $ \ms ->+ case ms of+ Nothing -> go (k Nothing) acc+ Just i -> go (k ms) (acc + fromIntegral (B.length i))+ I.BytesRead unused k ->+ go (k $! (acc - unused)) acc -------------------------------------------------------------------------+-- | DEPRECATED. Provides compatibility with previous versions of this library.+-- Run a 'Get' monad and return a tuple with three values.+-- The first value is the result of the decoder. The second and third are the+-- unused input, and the number of consumed bytes.+{-# DEPRECATED runGetState "Use runGetIncremental instead. This function will be removed." #-}+runGetState :: Get a -> L.ByteString -> ByteOffset -> (a, L.ByteString, ByteOffset)+runGetState g lbs0 pos' = go (runGetIncremental g) lbs0+ where+ go (Done s pos a) lbs = (a, L.chunk s lbs, pos+pos')+ go (Partial k) lbs = go (k (takeHeadChunk lbs)) (dropHeadChunk lbs)+ go (Fail _ pos msg) _ =+ error ("Data.Binary.Get.runGetState at position " ++ show pos ++ ": " ++ msg) -get :: Get S-get = Get $ \s -> (# s, s #)+takeHeadChunk :: L.ByteString -> Maybe B.ByteString+takeHeadChunk lbs =+ case lbs of+ (L.Chunk bs _) -> Just bs+ _ -> Nothing -put :: S -> Get ()-put s = Get $ \_ -> (# (), s #)+dropHeadChunk :: L.ByteString -> L.ByteString+dropHeadChunk lbs =+ case lbs of+ (L.Chunk _ lbs') -> lbs'+ _ -> L.Empty ------------------------------------------------------------------------------- dons, GHC 6.10: explicit inlining disabled, was killing performance.--- Without it, GHC seems to do just fine. And we get similar--- performance with 6.8.2 anyway.+-- | Run a 'Get' monad and return 'Left' on failure and 'Right' on+-- 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+ where+ feedAll (Done bs pos x) lbs = Right (L.chunk bs lbs, pos, x)+ feedAll (Partial k) lbs = feedAll (k (takeHeadChunk lbs)) (dropHeadChunk lbs)+ feedAll (Fail x pos msg) xs = Left (L.chunk x xs, pos, msg) -initState :: L.ByteString -> S-initState xs = mkState xs 0-{- INLINE initState -}+-- | An offset, counted in bytes.+type ByteOffset = Int64 -{--initState (B.LPS xs) =- case xs of- [] -> S B.empty L.empty 0- (x:xs') -> S x (B.LPS xs') 0--}+-- | The simplest interface to run a 'Get' decoder. If the decoder runs into+-- an error, calls 'fail', or runs out of input, it will call 'error'.+runGet :: Get a -> L.ByteString -> a+runGet g lbs0 = feedAll (runGetIncremental g) lbs0+ where+ feedAll (Done _ _ x) _ = x+ feedAll (Partial k) lbs = feedAll (k (takeHeadChunk lbs)) (dropHeadChunk lbs)+ feedAll (Fail _ pos msg) _ =+ error ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg) -#ifndef BYTESTRING_IN_BASE-mkState :: L.ByteString -> Int64 -> S-mkState l = case l of- L.Empty -> S B.empty L.empty- L.Chunk x xs -> S x xs-{- INLINE mkState -} -#else-mkState :: L.ByteString -> Int64 -> S-mkState (B.LPS xs) =- case xs of- [] -> S B.empty L.empty- (x:xs') -> S x (B.LPS xs')-#endif+-- | Feed a 'Decoder' with more input. If the 'Decoder' is 'Done' or 'Fail' it+-- will add the input to 'B.ByteString' of unconsumed input.+--+-- @+-- 'runGetIncremental' myParser \`pushChunk\` myInput1 \`pushChunk\` myInput2+-- @+pushChunk :: Decoder a -> B.ByteString -> Decoder a+pushChunk r inp =+ case r of+ Done inp0 p a -> Done (inp0 `B.append` inp) p a+ Partial k -> k (Just inp)+ Fail inp0 p s -> Fail (inp0 `B.append` inp) p s --- | Run the Get monad applies a 'get'-based parser on the input ByteString-runGet :: Get a -> L.ByteString -> a-runGet m str = case unGet m (initState str) of (# a, _ #) -> a --- | Run the Get monad applies a 'get'-based parser on the input--- ByteString. Additional to the result of get it returns the number of--- consumed bytes and the rest of the input.-runGetState :: Get a -> L.ByteString -> Int64 -> (a, L.ByteString, Int64)-runGetState m str off =- case unGet m (mkState str off) of- (# a, ~(S s ss newOff) #) -> (a, s `join` ss, newOff)--------------------------------------------------------------------------+-- | Feed a 'Decoder' with more input. If the 'Decoder' is 'Done' or 'Fail' it+-- will add the input to 'ByteString' of unconsumed input.+--+-- @+-- 'runGetIncremental' myParser \`pushChunks\` myLazyByteString+-- @+pushChunks :: Decoder a -> L.ByteString -> Decoder a+pushChunks r0 = go r0 . L.toChunks+ where+ go r [] = r+ go (Done inp pos a) xs = Done (B.concat (inp:xs)) pos a+ go (Fail inp pos s) xs = Fail (B.concat (inp:xs)) pos s+ go (Partial k) (x:xs) = go (k (Just x)) xs -failDesc :: String -> Get a-failDesc err = do- S _ _ bytes <- get- Get (error (err ++ ". Failed reading at byte position " ++ show bytes))+-- | Tell a 'Decoder' that there is no more input. This passes 'Nothing' to a+-- 'Partial' decoder, otherwise returns the decoder unchanged.+pushEndOfInput :: Decoder a -> Decoder a+pushEndOfInput r =+ case r of+ Done _ _ _ -> r+ Partial k -> k Nothing+ Fail _ _ _ -> r -- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available. skip :: Int -> Get ()-skip n = readN (fromIntegral n) (const ())---- | Skip ahead @n@ bytes. No error if there isn't enough bytes.-uncheckedSkip :: Int64 -> Get ()-uncheckedSkip n = do- S s ss bytes <- get- if fromIntegral (B.length s) >= n- then put (S (B.drop (fromIntegral n) s) ss (bytes + n))- else do- let rest = L.drop (n - fromIntegral (B.length s)) ss- put $! mkState rest (bytes + n)---- | Run @ga@, but return without consuming its input.--- Fails if @ga@ fails.-lookAhead :: Get a -> Get a-lookAhead ga = do- s <- get- a <- ga- put s- return a---- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'.--- Fails if @gma@ fails.-lookAheadM :: Get (Maybe a) -> Get (Maybe a)-lookAheadM gma = do- s <- get- ma <- gma- when (isNothing ma) $- put s- return ma---- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'.--- Fails if @gea@ fails.-lookAheadE :: Get (Either a b) -> Get (Either a b)-lookAheadE gea = do- s <- get- ea <- gea- case ea of- Left _ -> put s- _ -> return ()- return ea---- | Get the next up to @n@ bytes as a lazy ByteString, without consuming them. -uncheckedLookAhead :: Int64 -> Get L.ByteString-uncheckedLookAhead n = do- S s ss _ <- get- if n <= fromIntegral (B.length s)- then return (L.fromChunks [B.take (fromIntegral n) s])- else return $ L.take n (s `join` ss)----------------------------------------------------------------------------- Utility---- | Get the total number of bytes read to this point.-bytesRead :: Get Int64-bytesRead = do- S _ _ b <- get- return b+skip n = withInputChunks (fromIntegral n) consumeBytes (const ()) failOnEOF --- | Get the number of remaining unparsed bytes.--- Useful for checking whether all input has been consumed.--- Note that this forces the rest of the input.-remaining :: Get Int64-remaining = do- S s ss _ <- get- return (fromIntegral (B.length s) + L.length ss)+-- | An efficient get method for lazy ByteStrings. Fails if fewer than @n@+-- bytes are left in the input.+getLazyByteString :: Int64 -> Get L.ByteString+getLazyByteString n0 = withInputChunks n0 consumeBytes L.fromChunks failOnEOF --- | Test whether all input has been consumed,--- i.e. there are no remaining unparsed bytes.-isEmpty :: Get Bool-isEmpty = do- S s ss _ <- get- return (B.null s && L.null ss)+consumeBytes :: Consume Int64+consumeBytes n str+ | fromIntegral (B.length str) >= n = Right (B.splitAt (fromIntegral n) str)+ | otherwise = Left (n - fromIntegral (B.length str)) ---------------------------------------------------------------------------- Utility with ByteStrings+consumeUntilNul :: Consume ()+consumeUntilNul _ str =+ case B.break (==0) str of+ (want, rest) | B.null rest -> Left ()+ | otherwise -> Right (want, B.drop 1 rest) --- | An efficient 'get' method for strict ByteStrings. Fails if fewer--- than @n@ bytes are left in the input.-getByteString :: Int -> Get B.ByteString-getByteString n = readN n id-{-# INLINE getByteString #-}+consumeAll :: Consume ()+consumeAll _ _ = Left () --- | An efficient 'get' method for lazy ByteStrings. Does not fail if fewer than--- @n@ bytes are left in the input.-getLazyByteString :: Int64 -> Get L.ByteString-getLazyByteString n = do- S s ss bytes <- get- let big = s `join` ss- case splitAtST n big of- (consume, rest) -> do put $ mkState rest (bytes + n)- return consume-{-# INLINE getLazyByteString #-}+resumeOnEOF :: [B.ByteString] -> Get L.ByteString+resumeOnEOF = return . L.fromChunks --- | Get a lazy ByteString that is terminated with a NUL byte. Fails--- if it reaches the end of input without hitting a NUL.+-- | Get a lazy ByteString that is terminated with a NUL byte.+-- The returned string does not contain the NUL byte. Fails+-- if it reaches the end of input without finding a NUL. getLazyByteStringNul :: Get L.ByteString-getLazyByteStringNul = do- S s ss bytes <- get- let big = s `join` ss- (consume, t) = L.break (== 0) big- (h, rest) = L.splitAt 1 t- if L.null h- then fail "too few bytes"- else do- put $ mkState rest (bytes + L.length consume + 1)- return consume-{-# INLINE getLazyByteStringNul #-}+getLazyByteStringNul = withInputChunks () consumeUntilNul L.fromChunks failOnEOF --- | Get the remaining bytes as a lazy ByteString+-- | Get the remaining bytes as a lazy ByteString.+-- Note that this can be an expensive function to use as it forces reading+-- all input and keeping the string in-memory. getRemainingLazyByteString :: Get L.ByteString-getRemainingLazyByteString = do- S s ss _ <- get- return (s `join` ss)----------------------------------------------------------------------------- Helpers---- | Pull @n@ bytes from the input, as a strict ByteString.-getBytes :: Int -> Get B.ByteString-getBytes n = do- S s ss bytes <- get- if n <= B.length s- then do let (consume,rest) = B.splitAt n s- put $! S rest ss (bytes + fromIntegral n)- return $! consume- else- case L.splitAt (fromIntegral n) (s `join` ss) of- (consuming, rest) ->- do let now = B.concat . L.toChunks $ consuming- put $! mkState rest (bytes + fromIntegral n)- -- forces the next chunk before this one is returned- if (B.length now < n)- then- fail "too few bytes"- else- return now-{- INLINE getBytes -}--- ^ important--#ifndef BYTESTRING_IN_BASE-join :: B.ByteString -> L.ByteString -> L.ByteString-join bb lb- | B.null bb = lb- | otherwise = L.Chunk bb lb--#else-join :: B.ByteString -> L.ByteString -> L.ByteString-join bb (B.LPS lb)- | B.null bb = B.LPS lb- | otherwise = B.LPS (bb:lb)-#endif- -- don't use L.append, it's strict in it's second argument :/-{- INLINE join -}---- | Split a ByteString. If the first result is consumed before the ----- second, this runs in constant heap space.------ You must force the returned tuple for that to work, e.g.--- --- > case splitAtST n xs of--- > (ys,zs) -> consume ys ... consume zs----splitAtST :: Int64 -> L.ByteString -> (L.ByteString, L.ByteString)-splitAtST i ps | i <= 0 = (L.empty, ps)-#ifndef BYTESTRING_IN_BASE-splitAtST i ps = runST (- do r <- newSTRef undefined- xs <- first r i ps- ys <- unsafeInterleaveST (readSTRef r)- return (xs, ys))-- where- first :: STRef s L.ByteString -> Int64 -> L.ByteString -> ST s L.ByteString- first r 0 xs@(L.Chunk _ _) = writeSTRef r xs >> return L.Empty- first r _ L.Empty = writeSTRef r L.Empty >> return L.Empty-- first r n (L.Chunk x xs)- | n < l = do writeSTRef r (L.Chunk (B.drop (fromIntegral n) x) xs)- return $ L.Chunk (B.take (fromIntegral n) x) L.Empty- | otherwise = do writeSTRef r (L.drop (n - l) xs)- liftM (L.Chunk x) $ unsafeInterleaveST (first r (n - l) xs)- where - l = fromIntegral (B.length x)-#else-splitAtST i (B.LPS ps) = runST (- do r <- newSTRef undefined- xs <- first r i ps- ys <- unsafeInterleaveST (readSTRef r)- return (B.LPS xs, B.LPS ys))-- where first r 0 xs = writeSTRef r xs >> return []- first r _ [] = writeSTRef r [] >> return []- first r n (x:xs)- | n < l = do writeSTRef r (B.drop (fromIntegral n) x : xs)- return [B.take (fromIntegral n) x]- | otherwise = do writeSTRef r (L.toChunks (L.drop (n - l) (B.LPS xs)))- fmap (x:) $ unsafeInterleaveST (first r (n - l) xs)-- where l = fromIntegral (B.length x)-#endif-{- INLINE splitAtST -}---- Pull n bytes from the input, and apply a parser to those bytes,--- yielding a value. If less than @n@ bytes are available, fail with an--- error. This wraps @getBytes@.-readN :: Int -> (B.ByteString -> a) -> Get a-readN n f = fmap f $ getBytes n-{- INLINE readN -}--- ^ important+getRemainingLazyByteString = withInputChunks () consumeAll L.fromChunks resumeOnEOF ------------------------------------------------------------------------ -- Primtives -- helper, get a raw Ptr onto a strict ByteString copied out of the--- underlying lazy byteString. So many indirections from the raw parser--- state that my head hurts...+-- underlying lazy byteString. getPtr :: Storable a => Int -> Get a-getPtr n = do- (fp,o,_) <- readN n B.toForeignPtr- return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)-{- INLINE getPtr -}--------------------------------------------------------------------------+getPtr n = readNWith n peek+{-# INLINE getPtr #-} -- | Read a Word8 from the monad state getWord8 :: Get Word8-getWord8 = getPtr (sizeOf (undefined :: Word8))-{- INLINE getWord8 -}+getWord8 = readN 1 B.unsafeHead+{-# 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+"getWord16be/readN" getWord16be = readN 2 word16be+"getWord16le/readN" getWord16le = readN 2 word16le+"getWord32be/readN" getWord32be = readN 4 word32be+"getWord32le/readN" getWord32le = readN 4 word32le+"getWord64be/readN" getWord64be = readN 8 word64be+"getWord64le/readN" getWord64le = readN 8 word64le #-}+ -- | Read a Word16 in big endian format getWord16be :: Get Word16-getWord16be = do- s <- readN 2 id- return $! (fromIntegral (s `B.index` 0) `shiftl_w16` 8) .|.- (fromIntegral (s `B.index` 1))-{- INLINE getWord16be -}+getWord16be = readN 2 word16be +word16be :: B.ByteString -> Word16+word16be = \s ->+ (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w16` 8) .|.+ (fromIntegral (s `B.unsafeIndex` 1))+{-# INLINE[2] getWord16be #-}+{-# INLINE word16be #-}+ -- | Read a Word16 in little endian format getWord16le :: Get Word16-getWord16le = do- s <- readN 2 id- return $! (fromIntegral (s `B.index` 1) `shiftl_w16` 8) .|.- (fromIntegral (s `B.index` 0) )-{- INLINE getWord16le -}+getWord16le = readN 2 word16le +word16le :: B.ByteString -> Word16+word16le = \s ->+ (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w16` 8) .|.+ (fromIntegral (s `B.unsafeIndex` 0) )+{-# INLINE[2] getWord16le #-}+{-# INLINE word16le #-}+ -- | Read a Word32 in big endian format getWord32be :: Get Word32-getWord32be = do- s <- readN 4 id- return $! (fromIntegral (s `B.index` 0) `shiftl_w32` 24) .|.- (fromIntegral (s `B.index` 1) `shiftl_w32` 16) .|.- (fromIntegral (s `B.index` 2) `shiftl_w32` 8) .|.- (fromIntegral (s `B.index` 3) )-{- INLINE getWord32be -}+getWord32be = readN 4 word32be +word32be :: B.ByteString -> Word32+word32be = \s ->+ (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w32` 24) .|.+ (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 16) .|.+ (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 8) .|.+ (fromIntegral (s `B.unsafeIndex` 3) )+{-# INLINE[2] getWord32be #-}+{-# INLINE word32be #-}+ -- | Read a Word32 in little endian format getWord32le :: Get Word32-getWord32le = do- s <- readN 4 id- return $! (fromIntegral (s `B.index` 3) `shiftl_w32` 24) .|.- (fromIntegral (s `B.index` 2) `shiftl_w32` 16) .|.- (fromIntegral (s `B.index` 1) `shiftl_w32` 8) .|.- (fromIntegral (s `B.index` 0) )-{- INLINE getWord32le -}+getWord32le = readN 4 word32le +word32le :: B.ByteString -> Word32+word32le = \s ->+ (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w32` 24) .|.+ (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 16) .|.+ (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 8) .|.+ (fromIntegral (s `B.unsafeIndex` 0) )+{-# INLINE[2] getWord32le #-}+{-# INLINE word32le #-}+ -- | Read a Word64 in big endian format getWord64be :: Get Word64-getWord64be = do- s <- readN 8 id- return $! (fromIntegral (s `B.index` 0) `shiftl_w64` 56) .|.- (fromIntegral (s `B.index` 1) `shiftl_w64` 48) .|.- (fromIntegral (s `B.index` 2) `shiftl_w64` 40) .|.- (fromIntegral (s `B.index` 3) `shiftl_w64` 32) .|.- (fromIntegral (s `B.index` 4) `shiftl_w64` 24) .|.- (fromIntegral (s `B.index` 5) `shiftl_w64` 16) .|.- (fromIntegral (s `B.index` 6) `shiftl_w64` 8) .|.- (fromIntegral (s `B.index` 7) )-{- INLINE getWord64be -}+getWord64be = readN 8 word64be +word64be :: B.ByteString -> Word64+word64be = \s ->+ (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w64` 56) .|.+ (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 48) .|.+ (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 40) .|.+ (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 32) .|.+ (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 24) .|.+ (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 16) .|.+ (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 8) .|.+ (fromIntegral (s `B.unsafeIndex` 7) )+{-# INLINE[2] getWord64be #-}+{-# INLINE word64be #-}+ -- | Read a Word64 in little endian format getWord64le :: Get Word64-getWord64le = do- s <- readN 8 id- return $! (fromIntegral (s `B.index` 7) `shiftl_w64` 56) .|.- (fromIntegral (s `B.index` 6) `shiftl_w64` 48) .|.- (fromIntegral (s `B.index` 5) `shiftl_w64` 40) .|.- (fromIntegral (s `B.index` 4) `shiftl_w64` 32) .|.- (fromIntegral (s `B.index` 3) `shiftl_w64` 24) .|.- (fromIntegral (s `B.index` 2) `shiftl_w64` 16) .|.- (fromIntegral (s `B.index` 1) `shiftl_w64` 8) .|.- (fromIntegral (s `B.index` 0) )-{- INLINE getWord64le -}+getWord64le = readN 8 word64le +word64le :: B.ByteString -> Word64+word64le = \s ->+ (fromIntegral (s `B.unsafeIndex` 7) `shiftl_w64` 56) .|.+ (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 48) .|.+ (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 40) .|.+ (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 32) .|.+ (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 24) .|.+ (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 16) .|.+ (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 8) .|.+ (fromIntegral (s `B.unsafeIndex` 0) )+{-# INLINE[2] getWord64le #-}+{-# INLINE word64le #-}+++-- | 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 @@ -502,24 +580,79 @@ -- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes. getWordhost :: Get Word getWordhost = getPtr (sizeOf (undefined :: Word))-{- INLINE getWordhost -}+{-# INLINE getWordhost #-} -- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness. getWord16host :: Get Word16 getWord16host = getPtr (sizeOf (undefined :: Word16))-{- INLINE getWord16host -}+{-# INLINE getWord16host #-} -- | /O(1)./ Read a Word32 in native host order and host endianness. getWord32host :: Get Word32 getWord32host = getPtr (sizeOf (undefined :: Word32))-{- INLINE getWord32host -}+{-# INLINE getWord32host #-} -- | /O(1)./ Read a Word64 in native host order and host endianess. getWord64host :: Get Word64 getWord64host = getPtr (sizeOf (undefined :: Word64))-{- INLINE getWord64host -}+{-# 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@@ -532,12 +665,6 @@ #if WORD_SIZE_IN_BITS < 64 shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)--#if __GLASGOW_HASKELL__ <= 606--- Exported by GHC.Word in GHC 6.8 and higher-foreign import ccall unsafe "stg_uncheckedShiftL64"- uncheckedShiftL64# :: Word64# -> Int# -> Word64#-#endif #else shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)
+ src/Data/Binary/Get/Internal.hs view
@@ -0,0 +1,430 @@+{-# LANGUAGE CPP, RankNTypes, MagicHash, BangPatterns, TypeFamilies #-}++-- CPP C style pre-precessing, the #if defined lines+-- RankNTypes forall r. statement+-- MagicHash the (# unboxing #), also needs GHC.primitives++module Data.Binary.Get.Internal (++ -- * The Get type+ Get+ , runCont+ , Decoder(..)+ , runGetIncremental++ , readN+ , readNWith++ -- * Parsing+ , bytesRead+ , isolate++ -- * With input chunks+ , withInputChunks+ , Consume+ , failOnEOF++ , get+ , put+ , ensureN++ -- * Utility+ , remaining+ , getBytes+ , isEmpty+ , lookAhead+ , lookAheadM+ , lookAheadE+ , label++ -- ** ByteStrings+ , getByteString++ ) where++import Foreign+import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B++import Control.Applicative+import Control.Monad+#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,+-- and it should not terminate the decoding (empty would mean eof).+-- However, I'd say that it's also a risk that you get stuck in a loop,+-- where you keep providing an empty string. Anyway, no new input should be+-- rare, as the RTS should only wake you up if you actually have some data+-- to read from your fd.++-- | A decoder produced by running a 'Get' monad.+data Decoder a = Fail !B.ByteString String+ -- ^ The decoder ran into an error. The decoder either used+ -- 'fail' or was not provided enough input.+ | Partial (Maybe B.ByteString -> Decoder a)+ -- ^ The decoder has consumed the available input and needs+ -- more to continue. Provide 'Just' if more input is available+ -- and 'Nothing' otherwise, and you will get a new 'Decoder'.+ | Done !B.ByteString a+ -- ^ The decoder has successfully finished. Except for the+ -- output value you also get the unused input.+ | BytesRead {-# UNPACK #-} !Int64 (Int64 -> Decoder a)+ -- ^ The decoder needs to know the current position in the input.+ -- Given the number of bytes remaning in the decoder, the outer+ -- decoder runner needs to calculate the position and+ -- resume the decoding.++-- unrolled codensity/state monad+newtype Get a = C { runCont :: forall r.+ B.ByteString ->+ Success a r ->+ Decoder r }++type Success a r = B.ByteString -> a -> Decoder r++instance Monad Get where+ return = pure+ (>>=) = bindG+#if MIN_VERSION_base(4,9,0)+ fail = Fail.fail++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)+{-# INLINE bindG #-}++failG :: String -> Get a+failG str = C $ \i _ks -> Fail i str++apG :: Get (a -> b) -> Get a -> Get b+apG d e = do+ b <- d+ a <- e+ return (b a)+{-# INLINE [0] apG #-}++fmapG :: (a -> b) -> Get a -> Get b+fmapG f m = C $ \i ks -> runCont m i (\i' a -> ks i' (f a))+{-# INLINE fmapG #-}++instance Applicative Get where+ 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 = (<|>)++instance Functor Get where+ fmap = fmapG++instance Functor Decoder where+ fmap f (Done s a) = Done s (f a)+ fmap f (Partial k) = Partial (fmap f . k)+ fmap _ (Fail s msg) = Fail s msg+ fmap f (BytesRead b k) = BytesRead b (fmap f . k)++instance (Show a) => Show (Decoder a) where+ show (Fail _ msg) = "Fail: " ++ msg+ show (Partial _) = "Partial _"+ show (Done _ a) = "Done: " ++ show a+ show (BytesRead _ _) = "BytesRead"++-- | Run a 'Get' monad. See 'Decoder' for what to do next, like providing+-- input, handling decoding errors and to get the output value.+runGetIncremental :: Get a -> Decoder a+runGetIncremental g = noMeansNo $+ runCont g B.empty (\i a -> Done i a)++-- | Make sure we don't have to pass Nothing to a Partial twice.+-- This way we don't need to pass around an EOF value in the Get monad, it+-- can safely ask several times if it needs to.+noMeansNo :: Decoder a -> Decoder a+noMeansNo r0 = go r0+ where+ go r =+ case r of+ Partial k -> Partial $ \ms ->+ case ms of+ Just _ -> go (k ms)+ Nothing -> neverAgain (k ms)+ BytesRead n k -> BytesRead n (go . k)+ Done _ _ -> r+ Fail _ _ -> r+ neverAgain r =+ case r of+ Partial k -> neverAgain (k Nothing)+ BytesRead n k -> BytesRead n (neverAgain . k)+ Fail _ _ -> r+ Done _ _ -> r++prompt :: B.ByteString -> Decoder a -> (B.ByteString -> Decoder a) -> Decoder a+prompt inp kf ks = prompt' kf (\inp' -> ks (inp `B.append` inp'))++prompt' :: Decoder a -> (B.ByteString -> Decoder a) -> Decoder a+prompt' kf ks =+ let loop =+ Partial $ \sm ->+ case sm of+ Just s | B.null s -> loop+ | otherwise -> ks s+ Nothing -> kf+ in loop++-- | Get the total number of bytes read to this point.+bytesRead :: Get Int64+bytesRead = C $ \inp k -> BytesRead (fromIntegral $ B.length inp) (k inp)++-- | Isolate a decoder to operate with a fixed number of bytes, and fail if+-- fewer bytes were consumed, or more bytes were attempted to be consumed.+-- 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+isolate n0 act+ | n0 < 0 = fail "isolate: negative size"+ | otherwise = go n0 (runCont act B.empty Done)+ where+ go !n (Done left x)+ | n == 0 && B.null left = return x+ | otherwise = do+ pushFront left+ let consumed = n0 - n - B.length left+ fail $ "isolate: the decoder consumed " ++ show consumed ++ " bytes" +++ " which is less than the expected " ++ show n0 ++ " bytes"+ go 0 (Partial resume) = go 0 (resume Nothing)+ go n (Partial resume) = do+ inp <- C $ \inp k -> do+ let takeLimited str =+ let (inp', out) = B.splitAt n str+ in k out (Just inp')+ case not (B.null inp) of+ True -> takeLimited inp+ False -> prompt inp (k B.empty Nothing) takeLimited+ case inp of+ Nothing -> go n (resume Nothing)+ Just str -> go (n - B.length str) (resume (Just str))+ go _ (Fail bs err) = pushFront bs >> fail err+ go n (BytesRead r resume) =+ go n (resume $! fromIntegral n0 - fromIntegral n - r)++type Consume s = s -> B.ByteString -> Either s (B.ByteString, B.ByteString)++withInputChunks :: s -> Consume s -> ([B.ByteString] -> b) -> ([B.ByteString] -> Get b) -> Get b+withInputChunks initS consume onSucc onFail = go initS []+ where+ go state acc = C $ \inp ks ->+ case consume state inp of+ Left state' -> do+ let acc' = inp : acc+ prompt'+ (runCont (onFail (reverse acc')) B.empty ks)+ (\str' -> runCont (go state' acc') str' ks)+ Right (want,rest) -> do+ ks rest (onSucc (reverse (want:acc)))++failOnEOF :: [B.ByteString] -> Get a+failOnEOF bs = C $ \_ _ -> Fail (B.concat bs) "not enough bytes"++-- | Test whether all input has been consumed, i.e. there are no remaining+-- undecoded bytes.+isEmpty :: Get Bool+isEmpty = C $ \inp ks ->+ if B.null inp+ then prompt inp (ks inp True) (\inp' -> ks inp' False)+ else ks inp False++-- | DEPRECATED. Same as 'getByteString'.+{-# DEPRECATED getBytes "Use 'getByteString' instead of 'getBytes'." #-}+getBytes :: Int -> Get B.ByteString+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"+ {-# 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+ {-# 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'),+-- 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.+runAndKeepTrack :: Get a -> Get (Decoder a, [B.ByteString])+runAndKeepTrack g = C $ \inp ks ->+ let r0 = runCont g inp (\inp' a -> Done inp' a)+ go !acc r = case r of+ Done inp' a -> ks inp (Done inp' a, reverse acc)+ Partial k -> Partial $ \minp -> go (maybe acc (:acc) minp) (k minp)+ Fail inp' s -> ks inp (Fail inp' s, reverse acc)+ BytesRead unused k -> BytesRead unused (go acc . k)+ in go [] r0+{-# INLINE runAndKeepTrack #-}++pushBack :: [B.ByteString] -> Get ()+pushBack [] = C $ \ inp ks -> ks inp ()+pushBack bs = C $ \ inp ks -> ks (B.concat (inp : bs)) ()+{-# INLINE pushBack #-}++pushFront :: B.ByteString -> Get ()+pushFront bs = C $ \ inp ks -> ks (B.append bs inp) ()+{-# INLINE pushFront #-}++-- | 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+ case decoder of+ Done _ a -> pushBack bs >> return a+ Fail inp s -> C $ \_ _ -> Fail inp s+ _ -> error "Binary: impossible"++-- | 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+ either (const Nothing) Just <$> lookAheadE g'++-- | 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+ case decoder of+ Done _ (Left x) -> pushBack bs >> return (Left x)+ Done inp (Right x) -> C $ \_ ks -> ks inp (Right x)+ Fail inp s -> C $ \_ _ -> Fail inp s+ _ -> error "Binary: impossible"++-- | 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)+ go r = case r of+ Done inp' a -> ks inp' a+ Partial k -> Partial (go . k)+ Fail inp' s -> Fail inp' (s ++ "\n" ++ msg)+ BytesRead u k -> BytesRead u (go . k)+ in go r0++-- | DEPRECATED. Get the number of bytes of remaining input.+-- Note that this is an expensive function to use as in order to calculate how+-- much input remains, all input has to be read and kept in-memory.+-- The decoder keeps the input as a strict bytestring, so you are likely better+-- off by calculating the remaining input in another way.+{-# DEPRECATED remaining "This will force all remaining input, don't use it." #-}+remaining :: Get Int64+remaining = C $ \ inp ks ->+ let loop acc = Partial $ \ minp ->+ case minp of+ Nothing -> let all_inp = B.concat (inp : (reverse acc))+ in ks all_inp (fromIntegral $ B.length all_inp)+ Just inp' -> loop (inp':acc)+ in loop []++------------------------------------------------------------------------+-- ByteStrings+--++-- | An efficient get method for strict ByteStrings. Fails if fewer than @n@+-- bytes are left in the input. If @n <= 0@ then the empty string is returned.+getByteString :: Int -> Get B.ByteString+getByteString n | n > 0 = readN n (B.unsafeTake n)+ | otherwise = return B.empty+{-# INLINE getByteString #-}++-- | Get the current chunk.+get :: Get B.ByteString+get = C $ \inp ks -> ks inp inp++-- | Replace the current chunk.+put :: B.ByteString -> Get ()+put s = C $ \_inp ks -> ks s ()++-- | Return at least @n@ bytes, maybe more. If not enough data is available+-- the computation will escape with 'Partial'.+readN :: Int -> (B.ByteString -> a) -> Get a+readN !n f = ensureN n >> unsafeReadN n f+{-# INLINE [0] readN #-}++{-# RULES++"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)) #-}++-- | Ensure that there are at least @n@ bytes available. If not, the+-- computation will escape with 'Partial'.+ensureN :: Int -> Get ()+ensureN !n0 = C $ \inp ks -> do+ if B.length inp >= n0+ then ks inp ()+ else runCont (withInputChunks n0 enoughChunks onSucc onFail >>= put) inp ks+ where -- might look a bit funny, but plays very well with GHC's inliner.+ -- GHC won't inline recursive functions, so we make ensureN non-recursive+ enoughChunks n str+ | B.length str >= n = Right (str,B.empty)+ | otherwise = Left (n - B.length str)+ -- 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 #-}++unsafeReadN :: Int -> (B.ByteString -> a) -> Get a+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+ -- It should be safe to use accursedUnutterablePerformIO here.+ -- The action must be deterministic and not have any external side effects.+ -- It depends on the value of the ByteString so the value dependencies look OK.+ readN n $ \s -> accursedUnutterablePerformIO $ B.unsafeUseAsCString s (f . castPtr)+{-# INLINE readNWith #-}
+ src/Data/Binary/Internal.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE CPP #-}++module Data.Binary.Internal + ( accursedUnutterablePerformIO ) where++#if MIN_VERSION_bytestring(0,10,6)+import Data.ByteString.Internal( accursedUnutterablePerformIO )+#else+import Data.ByteString.Internal( inlinePerformIO )++{-# INLINE accursedUnutterablePerformIO #-}+-- | You must be truly desperate to come to me for help.+accursedUnutterablePerformIO :: IO a -> a+accursedUnutterablePerformIO = inlinePerformIO+#endif
src/Data/Binary/Put.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 701-{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Safe #-}++#if MIN_VERSION_base(4,9,0)+#define HAS_SEMIGROUP #endif -----------------------------------------------------------------------------@@ -8,7 +11,7 @@ -- Module : Data.Binary.Put -- Copyright : Lennart Kolmodin -- License : BSD3-style (see LICENSE)--- +-- -- Maintainer : Lennart Kolmodin <kolmodin@gmail.com> -- Stability : stable -- Portability : Portable to Hugs and GHC. Requires MPTCs@@ -32,43 +35,76 @@ -- * 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 APPLICATIVE_IN_BASE-import Control.Applicative+#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)+ ------------------------------------------------------------------------ --- XXX Strict in buffer only. +-- XXX Strict in buffer only. data PairS a = PairS a !Builder sndS :: PairS a -> Builder@@ -84,32 +120,59 @@ fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w {-# INLINE fmap #-} -#ifdef APPLICATIVE_IN_BASE 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')-#endif+ 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 #-}@@ -146,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@@ -158,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@@ -188,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@@ -218,3 +324,78 @@ putWord64host :: Word64 -> Put putWord64host = tell . B.putWord64host {-# INLINE putWord64host #-}++-- | /O(1)./ Write a single native machine word. The word is+-- written in host order, host endian form, for the machine you're on.+-- On a 64 bit machine the Int is an 8 byte value, on a 32 bit machine,+-- 4 bytes. Values written this way are not portable to+-- different endian or word sized machines, without conversion.+--+putInthost :: Int -> Put+putInthost = tell . B.putInthost+{-# INLINE putInthost #-}++-- | /O(1)./ Write an Int16 in native host order and host endianness.+-- For portability issues see @putInthost@.+putInt16host :: Int16 -> Put+putInt16host = tell . B.putInt16host+{-# INLINE putInt16host #-}++-- | /O(1)./ Write an Int32 in native host order and host endianness.+-- For portability issues see @putInthost@.+putInt32host :: Int32 -> Put+putInt32host = tell . B.putInt32host+{-# INLINE putInt32host #-}++-- | /O(1)./ Write an Int64 in native host order+-- On a 32 bit machine we write two host order Int32s, in big endian form.+-- For portability issues see @putInthost@.+putInt64host :: Int64 -> Put+putInt64host = tell . B.putInt64host+{-# INLINE putInt64host #-}++------------------------------------------------------------------------+-- Floats/Doubles++-- | Write a 'Float' in big endian IEEE-754 format.+putFloatbe :: Float -> Put+putFloatbe = putWord32be . floatToWord+{-# INLINE putFloatbe #-}++-- | Write a 'Float' in little endian IEEE-754 format.+putFloatle :: Float -> Put+putFloatle = putWord32le . floatToWord+{-# INLINE putFloatle #-}++-- | Write a 'Float' in native in IEEE-754 format and host endian.+putFloathost :: Float -> Put+putFloathost = putWord32host . floatToWord+{-# INLINE putFloathost #-}++-- | Write a 'Double' in big endian IEEE-754 format.+putDoublebe :: Double -> Put+putDoublebe = putWord64be . doubleToWord+{-# INLINE putDoublebe #-}++-- | Write a 'Double' in little endian IEEE-754 format.+putDoublele :: Double -> Put+putDoublele = putWord64le . doubleToWord+{-# INLINE putDoublele #-}++-- | Write a 'Double' in native in IEEE-754 format and host endian.+putDoublehost :: Double -> Put+putDoublehost = putWord64host . doubleToWord+{-# INLINE putDoublehost #-}++------------------------------------------------------------------------+-- Unicode++-- | Write a character using UTF-8 encoding.+putCharUtf8 :: Char -> Put+putCharUtf8 = tell . B.putCharUtf8+{-# INLINE putCharUtf8 #-}++-- | Write a String using UTF-8 encoding.+putStringUtf8 :: String -> Put+putStringUtf8 = tell . B.putStringUtf8+{-# INLINE putStringUtf8 #-}
+ tests/Action.hs view
@@ -0,0 +1,406 @@+{-# LANGUAGE PatternGuards #-}+module Action where++import Control.Applicative+import Control.Monad+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Char+import Data.List (intersperse, nub)++import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck++import Arbitrary ()+import qualified Data.Binary.Get as Binary++tests :: [Test]+tests = [ testProperty "action" prop_action+ , testProperty "label" prop_label+ , testProperty "fail" prop_fail ]++data Action+ = Actions [Action]+ | GetByteString Int+ | GetByteStringL Int+ | Skip Int+ | Isolate Int [Action]+ | Try [Action] [Action]+ | Label String [Action]+ | LookAhead [Action]+ -- | First argument is True if this action returns Just, otherwise False.+ | LookAheadM Bool [Action]+ -- | First argument is True if this action returns Right, otherwise Left.+ | LookAheadE Bool [Action]+ | BytesRead+ | Fail+ deriving (Show, Eq)++instance Arbitrary Action where+ arbitrary = fmap Actions (gen_actions False)+ shrink action =+ case action of+ Actions [a] -> [a]+ Actions as -> [ Actions as' | as' <- shrink as ]+ BytesRead -> []+ Fail -> []+ GetByteString n -> [ GetByteString n' | n' <- shrink n ]+ GetByteStringL n -> [ GetByteStringL n' | n' <- shrink n ]+ Skip n -> [ Skip n' | n' <- shrink n ]+ Isolate n as -> nub $ Actions as :+ [ Isolate n' as' | (n',as') <- shrink (n,as)+ , n' >= 0+ , n' <= max_len as' + 1 ]+ Label str a -> Actions a : [ Label str a' | a' <- shrink a ]+ LookAhead a -> Actions a : [ LookAhead a' | a' <- shrink a ]+ LookAheadM b a -> Actions a : [ LookAheadM b a' | a' <- shrink a ]+ LookAheadE b a -> Actions a : [ LookAheadE b a' | a' <- shrink a ]+ Try [Fail] b -> Actions b : [ Try [Fail] b' | b' <- shrink b ]+ Try a b ->+ [Actions a | not (willFail' a)]+ ++ [ Try a' b' | (a',b') <- shrink (a,b) ]++willFail :: Int -> [Action] -> Bool+willFail inp xxs =+ case eval inp xxs of+ EFail {} -> True+ _ -> False++willFail' :: [Action] -> Bool+willFail' = willFail maxBound++-- | The maximum length of input decoder can request.+-- The decoder may end up using less, but never more.+-- This way, you know how much input to generate for running a decoder test.+max_len :: [Action] -> Int+max_len [] = 0+max_len (x:xs) =+ case x of+ Actions xs' -> max_len (xs' ++ xs)+ BytesRead -> max_len xs+ Fail -> 0+ GetByteString n -> n + max_len xs+ GetByteStringL n -> n + max_len xs+ Skip n -> n + max_len xs+ Isolate n xs'+ | Just _ <- actual_len' [Isolate n xs'] -> n + max_len xs+ | otherwise -> n+ Label _ xs' -> max_len (xs' ++ xs)+ LookAhead xs'+ | willFail' xs' -> max_len xs'+ | otherwise -> max (max_len xs') (max_len xs)+ LookAheadM consume xs'+ | consume -> max_len (xs' ++ xs)+ | otherwise -> max_len (LookAhead xs' : xs)+ LookAheadE consume xs'+ | consume -> max_len (xs' ++ xs)+ | otherwise -> max_len (LookAhead xs' : xs)+ Try a b+ | willFail' a && willFail' b -> max (max_len a) (max_len b)+ | willFail' a -> max (max_len a) (max_len b) + max_len xs+ | otherwise -> max_len (a ++ xs)++-- | The actual length of input that will be consumed when+-- a decoder is executed, or Nothing if the decoder will fail.+actual_len :: Int -> [Action] -> Maybe Int+actual_len inp xs =+ case eval inp xs of+ ESuccess inp' -> Just (inp - inp')+ _ -> Nothing++actual_len' :: [Action] -> Maybe Int+actual_len' = actual_len maxBound++randomInput :: Int -> Gen L.ByteString+randomInput 0 = return L.empty+randomInput n = do+ m <- choose (1, min n 10)+ s <- vectorOf m $ choose ('a', 'z')+ let b = B.pack $ map (fromIntegral.ord) s+ rest <- randomInput (n-m)+ return (L.append (L.fromChunks [b]) rest)++-- | Build binary programs and compare running them to running a (hopefully)+-- identical model.+-- Tests that 'bytesRead' returns correct values when used together with '<|>'+-- and 'fail'.+prop_action :: Property+prop_action =+ forAllShrink (gen_actions False) shrink $ \ actions ->+ let max_len_input = max_len actions in+ forAll (randomInput max_len_input) $ \ lbs ->+ let allInput = B.concat (L.toChunks lbs) in+ case Binary.runGetOrFail (execute allInput actions) lbs of+ Right (_inp, _off, _x) -> True+ Left (_inp, _off, _msg) -> True++-- | When a decoder aborts with 'fail', check that all relevant uses of 'label'+-- are respected.+prop_label :: Property+prop_label =+ forAllShrink (gen_actions True) shrink $ \ actions ->+ let max_len_input = max_len actions in+ forAll (randomInput max_len_input) $ \ lbs ->+ let allInput = B.concat (L.toChunks lbs) in+ collect (failReason $ eval max_len_input actions) $+ case Binary.runGetOrFail (execute allInput actions) lbs of+ Left (_inp, _off, msg) ->+ let lbls = case collectLabels max_len_input actions of+ Just lbls' -> lbls'+ Nothing -> error ("expected labels, got: " ++ msg)+ expectedMsg = concat $ intersperse "\n" lbls+ in expectedMsg === msg+ Right (_inp, _off, _value) -> label "test case without 'fail'" $ True++-- | When a decoder aborts with 'fail', check the fail position and+-- remaining input.+prop_fail :: Property+prop_fail =+ forAllShrink (gen_actions True) shrink $ \ actions ->+ let max_len_input = max_len actions in+ forAll (randomInput max_len_input) $ \ lbs ->+ let allInput = B.concat (L.toChunks lbs) in+ collect (failReason $ eval max_len_input actions) $+ case Binary.runGetOrFail (execute allInput actions) lbs of+ Left (inp, off, _msg) ->+ case () of+ _ | Just off /= findFailPosition max_len_input actions ->+ error ("fail position incorrect, expected " +++ show (findFailPosition max_len_input actions) +++ " but got " ++ show off)+ | inp /= L.drop (fromIntegral off) lbs ->+ error $ "remaining output incorrect, was: " ++ show inp +++ ", should hav been: " ++ show (L.drop (fromIntegral off) lbs)+ | otherwise -> property True+ Right (_inp, _off, _value) -> label "test case without 'fail'" $ property True++-- | Collect all the labels up to a 'fail', or Nothing if the+-- decoder will not fail.+collectLabels :: Int -> [Action] -> Maybe [String]+collectLabels inp xxs =+ case eval inp xxs of+ EFail _ lbls _ -> Just lbls+ _ -> Nothing++-- | Finds at which byte offset the decoder will fail,+-- or Nothing if it won't fail.+findFailPosition :: Int -> [Action] -> Maybe Binary.ByteOffset+findFailPosition inp xxs =+ case eval inp xxs of+ EFail _ _ inp' -> return (fromIntegral (inp-inp'))+ _ -> Nothing++failReason :: Eval -> String+failReason (EFail fr _ _) = show fr+failReason _ = "NoFail"++-- | The result of an evaluation.+data Eval = ESuccess Int+ -- ^ The evalutation completed successfully. Contains the number of+ -- remaining bytes of the input.+ | EFail FailReason [String] Int+ -- ^ The evaluation completed with a failure. Contains the labels up+ -- to the failure, and the number of remaining bytes of the input.+ deriving (Show,Eq)++data FailReason+ = FRFail+ | FRIsolateTooMuch+ | FRIsolateTooLittle+ | FRTooMuch+ deriving (Show,Eq)++-- | Given the number of input bytes and a list of actions, evaluate the+-- actions and return whether the actions succeeed or fail.+eval :: Int -> [Action] -> Eval+eval inp0 = go inp0 []+ where+ step :: Int -> Int -> [String] -> [Action] -> Eval+ step inp n lbls xs+ | inp - n < 0 =+ let msg = "not enough bytes"+ in EFail FRTooMuch (msg:lbls) inp+ | otherwise = go (inp-n) lbls xs+ go :: Int -> [String] -> [Action] -> Eval+ go inp _lbls [] = ESuccess inp+ go inp lbls (x:xs) =+ case x of+ Actions xs' -> go inp lbls (xs'++xs)+ BytesRead -> go inp lbls xs+ Fail -> EFail FRFail ("fail":lbls) inp+ GetByteString n -> step inp n lbls xs+ GetByteStringL n -> step inp n lbls xs+ Skip n -> step inp n lbls xs+ Isolate n xs'+ | n > inp ->+ case go inp lbls xs' of+ ESuccess inp' ->+ let msg = "isolate: the decoder consumed " ++ show (inp - inp') +++ " bytes which is less than the expected " ++ (show n) +++ " bytes"+ in EFail FRTooMuch (msg:lbls) inp'+ efail -> efail+ | otherwise ->+ case go n lbls xs' of+ EFail fr lbls' inp' -> EFail fr lbls' (inp - n + inp')+ ESuccess 0 -> go (inp-n) lbls xs+ ESuccess inp' ->+ let msg = "isolate: the decoder consumed " ++ show (n - inp') +++ " bytes which is less than the expected " ++ (show n) +++ " bytes"+ in EFail FRIsolateTooLittle (msg:lbls) (inp - n + inp')+ Label str xs' ->+ case go inp (str:lbls) xs' of+ EFail fr lbls' inp' -> EFail fr lbls' inp'+ ESuccess inp' -> go inp' lbls xs+ LookAhead xs'+ | EFail fr lbls' inp' <- go inp lbls xs' -> EFail fr lbls' inp'+ | otherwise -> go inp lbls xs+ LookAheadM consume xs'+ | consume -> go inp lbls (xs'++xs)+ | otherwise -> go inp lbls (LookAhead xs' : xs)+ LookAheadE consume xs'+ | consume -> go inp lbls (xs'++xs)+ | otherwise -> go inp lbls (LookAhead xs' : xs)+ Try a b ->+ case go inp lbls a of+ ESuccess inp' -> go inp' lbls xs+ EFail {} -> go inp lbls (b++xs)+ +-- | Execute (run) the model.+-- First argument is all the input that will be used when executing+-- this decoder. It is used in this function to compare the expected+-- value with the actual value from the decoder functions.+-- The second argument is the model - the actions we will execute.+execute :: B.ByteString -> [Action] -> Binary.Get ()+execute inp acts0 = go 0 acts0 >> return ()+ where+ inp_len = B.length inp+ go _ [] = return ()+ go pos (x:xs) =+ case x of+ Actions a -> go pos (a++xs)+ GetByteString n -> do+ -- Run the operation in the Get monad...+ actual <- Binary.getByteString n+ let expected = B.take n . B.drop pos $ inp+ -- ... and compare that we got what we expected.+ when (actual /= expected) $ error $+ "execute(getByteString): actual /= expected at pos " ++ show pos +++ ", got: " ++ show actual ++ ", expected: " ++ show expected+ go (pos+n) xs+ GetByteStringL n -> do+ -- Run the operation in the Get monad...+ actual <- L.toStrict <$> Binary.getLazyByteString (fromIntegral n)+ let expected = B.take n . B.drop pos $ inp+ -- ... and compare that we got what we expected.+ when (actual /= expected) $ error $+ "execute(getLazyByteString): actual /= expected at pos " ++ show pos +++ ", got: " ++ show actual ++ ", expected: " ++ show expected+ go (pos+n) xs+ Skip n -> do+ Binary.skip n+ go (pos+n) xs+ BytesRead -> do+ pos' <- Binary.bytesRead+ if pos == fromIntegral pos'+ then go pos xs+ else error $ "execute(bytesRead): expected " +++ show pos ++ " but got " ++ show pos'+ Fail -> fail "fail"+ Isolate n as -> do+ let str = B.take n (B.drop pos inp)+ _ <- Binary.isolate n (execute str as)+ when (willFail (inp_len - pos) [Isolate n as]) $+ error "expected isolate to fail"+ go (pos + n) xs+ Label str as -> do+ len <- Binary.label str (leg pos as)+ go (pos+len) xs+ LookAhead a -> do+ _ <- Binary.lookAhead (go pos a)+ go pos xs+ LookAheadM b a -> do+ let f True = Just <$> leg pos a+ f False = go pos a >> return Nothing+ len <- Binary.lookAheadM (f b)+ case len of+ Nothing -> go pos xs+ Just offset -> go (pos+offset) xs+ LookAheadE b a -> do+ let f True = Right <$> leg pos a+ f False = go pos a >> return (Left ())+ len <- Binary.lookAheadE (f b)+ case len of+ Left _ -> go pos xs+ Right offset -> go (pos+offset) xs+ Try a b -> do+ offset <- leg pos a <|> leg pos b+ go (pos+offset) xs+ leg pos t = do+ go pos t+ case actual_len (inp_len - pos) t of+ Nothing -> error "impossible: branch should have failed"+ Just offset -> return offset++gen_actions :: Bool -> Gen [Action]+gen_actions genFail = do+ acts <- sized (go False)+ return acts+ where+ go :: Bool -> Int -> Gen [Action]+ go _ 0 = return []+ go inTry s = oneof $ [ do n <- choose (0,10)+ (:) (GetByteString n) <$> go inTry (s-1)+ , do n <- choose (0,10)+ (:) (GetByteStringL n) <$> go inTry (s-1)+ , do n <- choose (0,10)+ (:) (Skip n) <$> go inTry (s-1)+ , do (:) BytesRead <$> go inTry (s-1)+ , do t1 <- go True (s `div` 2)+ t2 <- go inTry (s `div` 2)+ (:) (Try t1 t2) <$> go inTry (s `div` 2)+ , do t <- go inTry (s`div`2)+ (:) (LookAhead t) <$> go inTry (s-1)+ , do t <- go inTry (s`div`2)+ b <- arbitrary+ (:) (LookAheadM b t) <$> go inTry (s-1)+ , do t <- go inTry (s`div`2)+ b <- arbitrary+ (:) (LookAheadE b t) <$> go inTry (s-1)+ , do t <- go inTry (s`div`2)+ Positive n <- arbitrary :: Gen (Positive Int)+ (:) (Label ("some label: " ++ show n) t) <$> go inTry (s-1)+ , do t <- resize (s`div`2) (gen_isolate (genFail || inTry))+ (:) t <$> go inTry (s-1)+ ] ++ [frequency [(if inTry || genFail then 1 else 0, return [Fail])+ ,(9 , go inTry s)]]++gen_isolate :: Bool -> Gen Action+gen_isolate genFail = gen_actions genFail >>= go+ where+ go t0 = do+ -- We can isolate the decoder with three different ranges;+ -- * give too few bytes -> isolate will fail+ -- * give exactly right amount of bytes -> isolate+ -- will succeed if the given decoder succeeds+ -- * give too many bytes -> isolate will fail+ -- Here we generate Isolates that belong to the different+ -- buckets.+ let t = t0+ tooFewBytes n = do+ n' <- choose (0, n)+ return (n',t)+ requiredBytes n = return (n,t)+ tooManyBytes n = do+ n' <- choose (n+1, n+10)+ return (n+n',t)+ let trees+ | Just n <- actual_len' t = oneof $+ [ requiredBytes n ] +++ [ tooFewBytes n | genFail ] +++ [ tooManyBytes n | genFail ]+ | otherwise = return (max_len t, t)+ (n,t') <- trees+ return (Isolate n t')
+ tests/Arbitrary.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Arbitrary where++import Test.QuickCheck++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++instance Arbitrary B.ByteString where+ arbitrary = B.pack `fmap` arbitrary++#if MIN_VERSION_bytestring(0,10,4)+instance Arbitrary S.ShortByteString where+ arbitrary = S.toShort `fmap` arbitrary+#endif
+ tests/File.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE CPP #-}+module Main where++#if ! MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++import System.Directory (getTemporaryDirectory)+import System.FilePath ((</>))+import Test.HUnit++import Distribution.Simple.Utils (withTempDirectory)+import Distribution.Verbosity (silent)++import Data.Binary++data Foo = Bar !Word32 !Word32 !Word32 deriving (Eq, Show)++instance Binary Foo where+ get = Bar <$> get <*> get <*> get+ put (Bar a b c) = put (a,b,c)++exampleData :: [Foo]+exampleData = make bytes+ where+ make (a:b:c:xs) = Bar a b c : make xs+ make _ = []+ bytes = take (256*1024) (cycle [minBound..maxBound])++readWriteTest :: Test+readWriteTest = TestCase $ do+ tmpDir <- getTemporaryDirectory+ withTempDirectory silent tmpDir "foo-dir" $ \dir -> do+ let fn = dir </> "foo.bin"+ encodeFile fn exampleData+ content <- decodeFile fn+ -- It'd be nice to use lsof to verify that 'fn' isn't still open.+ exampleData @=? content++main :: IO ()+main = do + _ <- runTestTT readWriteTest+ return ()
− tests/Makefile
@@ -1,16 +0,0 @@-all: compiled--interpreted:- runhaskell QC.hs 1000--compiled:- ghc --make -fhpc -O QC.hs -o qc -threaded -package QuickCheck-1.2.0.1 -i../src- ./qc 500--hugs:- runhugs -98 QC.hs --clean:- rm -f *.o *.hi qc *.tix *~--.PHONY: clean
− tests/Parallel.hs
@@ -1,147 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Test.QuickCheck.Parallel--- Copyright : (c) Don Stewart 2006--- License : BSD-style (see the file LICENSE)--- --- Maintainer : dons@cse.unsw.edu.au--- Stability : experimental--- Portability : non-portable (uses Control.Exception, Control.Concurrent)------ A parallel batch driver for running QuickCheck on threaded or SMP systems.--- See the /Example.hs/ file for a complete overview.-----module Parallel (- pRun,- pDet,- pNon- ) where--import Test.QuickCheck-import Data.List-import Control.Concurrent-import Control.Exception hiding (evaluate)-import System.Random-import System.IO (hFlush,stdout)-import Text.Printf--type Name = String-type Depth = Int-type Test = (Name, Depth -> IO String)---- | Run a list of QuickCheck properties in parallel chunks, using--- 'n' Haskell threads (first argument), and test to a depth of 'd'--- (second argument). Compile your application with '-threaded' and run--- with the SMP runtime's '-N4' (or however many OS threads you want to--- donate), for best results.------ > import Test.QuickCheck.Parallel--- >--- > do n <- getArgs >>= readIO . head--- > pRun n 1000 [ ("sort1", pDet prop_sort1) ]------ Will run 'n' threads over the property list, to depth 1000.----pRun :: Int -> Int -> [Test] -> IO ()-pRun n depth tests = do- chan <- newChan- ps <- getChanContents chan- work <- newMVar tests-- forM_ [1..n] $ forkIO . thread work chan-- let wait xs i- | i >= n = return () -- done- | otherwise = case xs of- Nothing : xs -> wait xs $! i+1- Just s : xs -> putStr s >> hFlush stdout >> wait xs i- wait ps 0-- where- thread :: MVar [Test] -> Chan (Maybe String) -> Int -> IO ()- thread work chan me = loop- where- loop = do- job <- modifyMVar work $ \jobs -> return $ case jobs of- [] -> ([], Nothing)- (j:js) -> (js, Just j)- case job of- Nothing -> writeChan chan Nothing -- done- Just (name,prop) -> do- v <- prop depth- writeChan chan . Just $ printf "%d: %-25s: %s" me name v- loop----- | Wrap a property, and run it on a deterministic set of data-pDet :: Testable a => a -> Int -> IO String-pDet a n = mycheck Det defaultConfig- { configMaxTest = n- , configEvery = \n args -> unlines args } a---- | Wrap a property, and run it on a non-deterministic set of data-pNon :: Testable a => a -> Int -> IO String-pNon a n = mycheck NonDet defaultConfig- { configMaxTest = n- , configEvery = \n args -> unlines args } a--data Mode = Det | NonDet----------------------------------------------------------------------------mycheck :: Testable a => Mode -> Config -> a -> IO String-mycheck Det config a = do- let rnd = mkStdGen 99 -- deterministic- mytests config (evaluate a) rnd 0 0 []--mycheck NonDet config a = do- rnd <- newStdGen -- different each run- mytests config (evaluate a) rnd 0 0 []--mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO String-mytests config gen rnd0 ntest nfail stamps- | ntest == configMaxTest config = do done "OK," ntest stamps- | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps- | otherwise = do- case ok result of- Nothing ->- mytests config gen rnd1 ntest (nfail+1) stamps- Just True ->- mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps)- Just False ->- return ( "Falsifiable after "- ++ show ntest- ++ " tests:\n"- ++ unlines (arguments result)- )- where- result = generate (configSize config ntest) rnd2 gen- (rnd1,rnd2) = split rnd0--done :: String -> Int -> [[String]] -> IO String-done mesg ntest stamps =- return ( mesg ++ " " ++ show ntest ++ " tests" ++ table )- where- table = display- . map entry- . reverse- . sort- . map pairLength- . group- . sort- . filter (not . null)- $ stamps-- display [] = ".\n"- display [x] = " (" ++ x ++ ").\n"- display xs = ".\n" ++ unlines (map (++ ".") xs)-- pairLength xss@(xs:_) = (length xss, xs)- entry (n, xs) = percentage n ntest- ++ " "- ++ concat (intersperse ", " xs)-- percentage n m = show ((100 * n) `div` m) ++ "%"--forM_ = flip mapM_
tests/QC.hs view
@@ -1,78 +1,436 @@-{-# OPTIONS_GHC -fglasgow-exts #-}-module Main where+{-# LANGUAGE CPP, ScopedTypeVariables, DataKinds, TypeSynonymInstances #-}+module Main ( main ) where -import Data.Binary-import Data.Binary.Put-import Data.Binary.Get+#if MIN_VERSION_base(4,8,0)+#define HAS_NATURAL+#endif -import Parallel+#if MIN_VERSION_base(4,7,0)+#define HAS_FIXED_CONSTRUCTOR+#endif -import qualified Data.ByteString as B-import qualified Data.ByteString.Internal as B-import qualified Data.ByteString.Unsafe as B-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Lazy.Internal as L-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet+import Control.Applicative+import Control.Exception as C (SomeException,+ catch, evaluate)+import Control.Monad (unless, liftM2)+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 -import Data.Array (Array)-import Data.Array.IArray-import Data.Array.Unboxed (UArray)+#ifdef HAS_NATURAL+import Numeric.Natural+#endif -import qualified Control.OldException as C (catch,evaluate)-import Control.Monad-import Foreign-import System.Environment-import System.IO-import System.IO.Unsafe+import GHC.Fingerprint -import Test.QuickCheck hiding (test)-import QuickCheckUtils-import Text.Printf+import qualified Data.Fixed as Fixed --- import qualified Data.Sequence as Seq+import Test.Framework+import Test.Framework.Providers.QuickCheck2+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+ ------------------------------------------------------------------------ roundTrip :: (Eq a, Binary a) => a -> (L.ByteString -> L.ByteString) -> Bool roundTrip a f = a == {-# SCC "decode.refragment.encode" #-} decode (f (encode a)) -roundTripWith put get x =+roundTripWith :: Eq a => (a -> Put) -> Get a -> a -> Property+roundTripWith putter getter x = forAll positiveList $ \xs ->- x == runGet get (refragment xs (runPut (put x)))+ x == runGet getter (refragment xs (runPut (putter x))) -- make sure that a test fails-errorish :: B a-errorish a = unsafePerformIO $- C.catch (do C.evaluate a+mustThrowError :: B a+mustThrowError a = unsafePerformIO $+ C.catch (do _ <- C.evaluate a return False)- (\_ -> return True)+ (\(_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++prop_Word16le :: Word16 -> Property prop_Word16le = roundTripWith putWord16le getWord16le++prop_Word16host :: Word16 -> Property prop_Word16host = roundTripWith putWord16host getWord16host +prop_Word32be :: Word32 -> Property prop_Word32be = roundTripWith putWord32be getWord32be++prop_Word32le :: Word32 -> Property prop_Word32le = roundTripWith putWord32le getWord32le++prop_Word32host :: Word32 -> Property prop_Word32host = roundTripWith putWord32host getWord32host +prop_Word64be :: Word64 -> Property prop_Word64be = roundTripWith putWord64be getWord64be++prop_Word64le :: Word64 -> Property prop_Word64le = roundTripWith putWord64le getWord64le++prop_Word64host :: Word64 -> Property prop_Word64host = roundTripWith putWord64host getWord64host +prop_Wordhost :: Word -> Property prop_Wordhost = roundTripWith putWordhost getWordhost --- read too much:+-- Ints -prop_bookworm x = errorish $ x == a && x /= b+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.+-- May or may not use the whole input, check conditions for the different+-- outcomes.+prop_partial :: L.ByteString -> Property+prop_partial lbs = forAll (choose (0, L.length lbs * 2)) $ \skipN ->+ let result = pushChunks (runGetIncremental decoder) lbs+ decoder = do+ s <- getByteString (fromIntegral skipN)+ return (L.fromChunks [s])+ in case result of+ Partial _ -> L.length lbs < skipN+ Done unused _pos value ->+ and [ L.length value == skipN+ , L.append value (L.fromChunks [unused]) == lbs+ ]+ Fail _ _ _ -> False++-- | Fail a decoder and make sure the result is sane.+prop_fail :: L.ByteString -> String -> Property+prop_fail lbs msg = forAll (choose (0, L.length lbs)) $ \pos ->+ let result = pushChunks (runGetIncremental decoder) lbs+ decoder = do+ -- use part of the input...+ _ <- getByteString (fromIntegral pos)+ -- ... then fail+ fail msg+ in case result of+ Fail unused pos' msg' ->+ and [ pos == pos'+ , msg == msg'+ , L.length lbs - pos == fromIntegral (B.length unused)+ , L.fromChunks [unused] `L.isSuffixOf` lbs+ ]+ _ -> False -- wuut?++-- read negative length+prop_getByteString_negative :: Int -> Property+prop_getByteString_negative n =+ n < 1 ==>+ runGet (getByteString n) L.empty == B.empty+++prop_bytesRead :: L.ByteString -> Property+prop_bytesRead lbs =+ forAll (makeChunks 0 totalLength) $ \chunkSizes ->+ let result = pushChunks (runGetIncremental decoder) lbs+ decoder = do+ -- Read some data and invoke bytesRead several times.+ -- Each time, check that the values are what we expect.+ flip mapM_ chunkSizes $ \(total, step) -> do+ _ <- getByteString (fromIntegral step)+ n <- bytesRead+ unless (n == total) $ fail "unexpected position"+ bytesRead+ in case result of+ Done unused pos value ->+ and [ value == totalLength+ , pos == value+ , B.null unused+ ]+ Partial _ -> False+ Fail _ _ _ -> False where+ totalLength = L.length lbs+ makeChunks total i+ | i == 0 = return []+ | otherwise = do+ n <- choose (0,i)+ let total' = total + n+ rest <- makeChunks total' (i - n)+ return ((total',n):rest)+++-- | We're trying to guarantee that the Decoder will not ask for more input+-- with Partial if it has been given Nothing once.+-- In this test we're making the decoder return 'Partial' to get more+-- input, and to get knownledge of the current position using 'BytesRead'.+-- Both of these operations, when used with the <|> operator, result internally+-- in that the decoder return with Partial and BytesRead multiple times,+-- in which case we need to keep track of if the user has passed Nothing to a+-- Partial in the past.+prop_partialOnlyOnce :: Property+prop_partialOnlyOnce = property $+ let result = runGetIncremental (decoder <|> decoder)+ decoder = do+ 0 <- bytesRead+ _ <- getWord8 -- this will make the decoder return with Partial+ return "shouldn't get here"+ in case result of+ -- we expect Partial followed by Fail+ Partial k -> case k Nothing of -- push down a Nothing+ Fail _ _ _ -> True+ Partial _ -> error $ "partial twice! oh noes!"+ Done _ _ _ -> error $ "we're not supposed to be done."+ _ -> error $ "not partial, error!"++-- read too much+prop_readTooMuch :: (Eq a, Binary a) => a -> Bool+prop_readTooMuch x = mustThrowError $ x == a && x /= b+ where+ -- encode 'a', but try to read 'b' too (a,b) = decode (encode x)+ _types = [a,b] +-- In binary-0.5 the Get monad looked like+--+-- > data S = S {-# UNPACK #-} !B.ByteString+-- > L.ByteString+-- > {-# UNPACK #-} !Int64+-- >+-- > newtype Get a = Get { unGet :: S -> (# a, S #) }+--+-- with a helper function+--+-- > mkState :: L.ByteString -> Int64 -> S+-- > mkState l = case l of+-- > L.Empty -> S B.empty L.empty+-- > L.Chunk x xs -> S x xs+--+-- Note that mkState is strict in its first argument. This goes wrong in this+-- function:+--+-- > getBytes :: Int -> Get B.ByteString+-- > getBytes n = do+-- > S s ss bytes <- traceNumBytes n $ get+-- > if n <= B.length s+-- > then do let (consume,rest) = B.splitAt n s+-- > put $! S rest ss (bytes + fromIntegral n)+-- > return $! consume+-- > else+-- > case L.splitAt (fromIntegral n) (s `join` ss) of+-- > (consuming, rest) ->+-- > do let now = B.concat . L.toChunks $ consuming+-- > put $ mkState rest (bytes + fromIntegral n)+-- > -- forces the next chunk before this one is returned+-- > if (B.length now < n)+-- > then+-- > fail "too few bytes"+-- > else+-- > return now+--+-- Consider the else-branch of this function; suppose we ask for n bytes;+-- the call to L.splitAt gives us a lazy bytestring 'consuming' of precisely @n@+-- bytes (unless we don't have enough data, in which case we fail); but then+-- the strict evaluation of mkState on 'rest' means we look ahead too far.+--+-- Although this is all done completely differently in binary-0.7 it is+-- important that the same bug does not get introduced in some other way. The+-- test is basically the same test that already exists in this test suite,+-- verifying that+--+-- > decode . refragment . encode == id+--+-- However, we use a different 'refragment', one that introduces an exception+-- as the tail of the bytestring after rechunking. If we don't look ahead too+-- far then this should make no difference, but if we do then this will throw+-- an exception (for instance, in binary-0.5, this will throw an exception for+-- certain rechunkings, but not for others).+--+-- To make sure that the property holds no matter what refragmentation we use,+-- we test exhaustively for a single chunk, and all ways to break the string+-- into 2, 3 and 4 chunks.+prop_lookAheadIndepOfChunking :: (Eq a, Binary a) => a -> Property+prop_lookAheadIndepOfChunking testInput =+ forAll (testCuts (L.length (encode testInput))) $+ roundTrip testInput . rechunk+ where+ testCuts :: forall a. (Num a, Enum a) => a -> Gen [a]+ testCuts len = elements $ [ [] ]+ ++ [ [i]+ | i <- [0 .. len] ]+ ++ [ [i, j]+ | i <- [0 .. len]+ , j <- [0 .. len - i] ]+ ++ [ [i, j, k]+ | i <- [0 .. len]+ , j <- [0 .. len - i]+ , k <- [0 .. len - i - j] ]++ -- Rechunk a bytestring, leaving the tail as an exception rather than Empty+ rechunk :: forall a. Integral a => [a] -> L.ByteString -> L.ByteString+ rechunk cuts = fromChunks . cut cuts . B.concat . L.toChunks+ where+ cut :: [a] -> B.ByteString -> [B.ByteString]+ cut [] bs = [bs]+ cut (i:is) bs = let (bs0, bs1) = B.splitAt (fromIntegral i) bs+ in bs0 : cut is bs1++ fromChunks :: [B.ByteString] -> L.ByteString+ fromChunks [] = error "Binary should not have to ask for this chunk!"+ fromChunks (bs:bss) = L.Chunk bs (fromChunks bss)++-- String utilities++prop_getLazyByteString :: L.ByteString -> Property+prop_getLazyByteString lbs = forAll (choose (0, 2 * L.length lbs)) $ \len ->+ let result = pushChunks (runGetIncremental decoder) lbs+ decoder = getLazyByteString len+ in case result of+ Done unused _pos value ->+ and [ value == L.take len lbs+ , L.fromChunks [unused] == L.drop len lbs+ ]+ Partial _ -> len > L.length lbs+ _ -> False++prop_getLazyByteStringNul :: Word16 -> [Int] -> Property+prop_getLazyByteStringNul count0 fragments = count >= 0 ==>+ forAll (choose (0, count)) $ \pos ->+ let lbs = case L.splitAt pos (L.replicate count 65) of+ (start,end) -> refragment fragments $ L.concat [start, L.singleton 0, end]+ result = pushEndOfInput $ pushChunks (runGetIncremental getLazyByteStringNul) lbs+ in case result of+ Done unused pos' value ->+ and [ value == L.take pos lbs+ , pos + 1 == pos' -- 1 for the NUL+ , L.fromChunks [unused] == L.drop (pos + 1) lbs+ ]+ _ -> False+ where+ count = fromIntegral count0 -- to make the generated numbers a bit smaller++-- | Same as prop_getLazyByteStringNul, but without any NULL in the string.+prop_getLazyByteStringNul_noNul :: Word16 -> [Int] -> Property+prop_getLazyByteStringNul_noNul count0 fragments = count >= 0 ==>+ let lbs = refragment fragments $ L.replicate count 65+ result = pushEndOfInput $ pushChunks (runGetIncremental getLazyByteStringNul) lbs+ in case result of+ Fail _ _ _ -> True+ _ -> False+ where+ count = fromIntegral count0 -- to make the generated numbers a bit smaller++prop_getRemainingLazyByteString :: L.ByteString -> Property+prop_getRemainingLazyByteString lbs = property $+ let result = pushEndOfInput $ pushChunks (runGetIncremental getRemainingLazyByteString) lbs+ in case result of+ Done unused pos value ->+ and [ value == lbs+ , B.null unused+ , fromIntegral pos == L.length lbs+ ]+ _ -> False+ -- sanity: invariant_lbs :: L.ByteString -> Bool@@ -82,163 +440,274 @@ prop_invariant :: (Binary a) => a -> Bool prop_invariant = invariant_lbs . encode --- be lazy!---- doesn't do fair testing of lazy put/get.--- tons of untested cases---- lazyTrip :: (Binary a, Eq a) => a -> Property--- lazyTrip a = forAll positiveList $ \xs ->--- a == (runGet lazyGet . refragment xs . runPut . lazyPut $ a)- -- refragment a lazy bytestring's chunks refragment :: [Int] -> L.ByteString -> L.ByteString-refragment [] lps = lps-refragment (x:xs) lps =+refragment [] lbs = lbs+refragment (x:xs) lbs = let x' = fromIntegral . (+1) . abs $ x- rest = refragment xs (L.drop x' lps) in- L.append (L.fromChunks [B.concat . L.toChunks . L.take x' $ lps]) rest+ rest = refragment xs (L.drop x' lbs) in+ L.append (L.fromChunks [B.concat . L.toChunks . L.take x' $ lbs]) rest -- check identity of refragmentation-prop_refragment lps xs = lps == refragment xs lps+prop_refragment :: L.ByteString -> [Int] -> Bool+prop_refragment lbs xs = lbs == refragment xs lbs -- check that refragmention still hold invariant-prop_refragment_inv lps xs = invariant_lbs $ refragment xs lps+prop_refragment_inv :: L.ByteString -> [Int] -> Bool+prop_refragment_inv lbs xs = invariant_lbs $ refragment xs lbs main :: IO ()-main = do- hSetBuffering stdout NoBuffering- s <- getArgs- let x = if null s then 100 else read (head s)- pRun 2 x tests+main = defaultMain tests -{--run :: [(String, Int -> IO ())] -> IO ()-run tests = do- x <- getArgs- let n = if null x then 100 else read . head $ x- mapM_ (\(s,a) -> printf "%-50s" s >> a n) tests--}+------------------------------------------------------------------------ +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+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+ ------------------------------------------------------------------------ -type T a = a -> Property-type B a = a -> Bool+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 -p :: Testable a => a -> Int -> IO String-p = pNon+------------------------------------------------------------------------ -test :: (Eq a, Binary a) => a -> Property-test a = forAll positiveList (roundTrip a . refragment)+#ifdef HAS_FIXED_CONSTRUCTOR -positiveList :: Gen [Int]-positiveList = fmap (filter (/=0) . map abs) $ arbitrary+fixedPut :: forall a. Fixed.HasResolution a => Fixed.Fixed a -> Put+fixedPut x = put (truncate (x * fromInteger (Fixed.resolution (undefined :: Maybe a))) :: Integer) --- tests :: [(String, Int -> IO String)]-tests =--- utils- [ ("refragment id", p prop_refragment )- , ("refragment invariant", p prop_refragment_inv )+fixedGet :: forall a. Fixed.HasResolution a => Get (Fixed.Fixed a)+fixedGet = (\x -> fromInteger x / fromInteger (Fixed.resolution (undefined :: Maybe a))) `liftA` get --- boundaries- , ("read to much", p (prop_bookworm :: B Word8 ))+-- | 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) --- Primitives- , ("Word16be", p prop_Word16be)- , ("Word16le", p prop_Word16le)- , ("Word16host", p prop_Word16host)- , ("Word32be", p prop_Word32be)- , ("Word32le", p prop_Word32le)- , ("Word32host", p prop_Word32host)- , ("Word64be", p prop_Word64be)- , ("Word64le", p prop_Word64le)- , ("Word64host", p prop_Word64host)- , ("Wordhost", p prop_Wordhost)+-- | 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 --- higher level ones using the Binary class- ,("()", p (test :: T () ))- ,("Bool", p (test :: T Bool ))- ,("Ordering", p (test :: T Ordering ))+-- | 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 - ,("Word8", p (test :: T Word8 ))- ,("Word16", p (test :: T Word16 ))- ,("Word32", p (test :: T Word32 ))- ,("Word64", p (test :: T Word64 ))+#endif - ,("Int8", p (test :: T Int8 ))- ,("Int16", p (test :: T Int16 ))- ,("Int32", p (test :: T Int32 ))- ,("Int64", p (test :: T Int64 ))+------------------------------------------------------------------------ - ,("Word", p (test :: T Word ))- ,("Int", p (test :: T Int ))- ,("Integer", p (test :: T Integer ))+type T a = a -> Property+type B a = a -> Bool - ,("Float", p (test :: T Float ))- ,("Double", p (test :: T Double ))+p :: (Testable p) => p -> Property+p = property - ,("Char", p (test :: T Char ))+test :: (Eq a, Binary a) => a -> Property+test a = forAll positiveList (roundTrip a . refragment) - ,("[()]", 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 ))+test' :: (Show a, Arbitrary a) => String -> (a -> Property) -> ([a] -> Property) -> Test+test' desc prop propList =+ testGroup desc [+ testProperty desc prop,+ testProperty ("[" ++ desc ++ "]") propList+ ] - ,("((), ())", p (test :: T ((), ()) ))- ,("(Word8, Word32)", p (test :: T (Word8, Word32) ))- ,("(Int8, Int32)", p (test :: T (Int8, Int32) ))- ,("(Int32, [Int])", p (test :: T (Int32, [Int]) ))+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)+ ] - ,("Maybe Int8", p (test :: T (Maybe Int8) ))- ,("Either Int8 Int16", p (test :: T (Either Int8 Int16) ))+positiveList :: Gen [Int]+positiveList = fmap (filter (/=0) . map abs) $ arbitrary - ,("(Maybe Word8, Bool, [Int], Either Bool Word8)",- p (test :: T (Maybe Word8, Bool, [Int], Either Bool Word8) ))+tests :: [Test]+tests =+ [ testGroup "Utils"+ [ testProperty "refragment id" (p prop_refragment)+ , testProperty "refragment invariant" (p prop_refragment_inv)+ ] - ,("(Int, ByteString)", p (test :: T (Int, B.ByteString) ))--- ,("Lazy (Int, ByteString)", p (lazyTrip :: T (Int, B.ByteString) ))- ,("[(Int, ByteString)]", p (test :: T [(Int, B.ByteString)] ))--- ,("Lazy [(Int, ByteString)]", p (lazyTrip :: T [(Int, B.ByteString)] ))+ , testGroup "Boundaries"+ [ testProperty "read to much" (p (prop_readTooMuch :: B Word8))+ , testProperty "read negative length" (p (prop_getByteString_negative :: T Int))+ , -- Arbitrary test input+ let testInput :: [Int] ; testInput = [0 .. 10]+ in testProperty "look-ahead independent of chunking" (p (prop_lookAheadIndepOfChunking testInput))+ ] + , testGroup "Partial"+ [ testProperty "partial" (p prop_partial)+ , testProperty "fail" (p prop_fail)+ , testProperty "bytesRead" (p prop_bytesRead)+ , testProperty "partial only once" (p prop_partialOnlyOnce)+ ] --- ,("Lazy IntMap", p (lazyTrip :: T IntSet.IntSet ))- ,("IntSet", p (test :: T IntSet.IntSet ))- ,("IntMap ByteString", p (test :: T (IntMap.IntMap B.ByteString) ))+ , testGroup "Model"+ Action.tests - ,("B.ByteString", p (test :: T B.ByteString ))- ,("L.ByteString", p (test :: T L.ByteString ))+ , testGroup "Primitives"+ [ 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)+ , testProperty "Word32le" (p prop_Word32le)+ , testProperty "Word32host" (p prop_Word32host)+ , testProperty "Word64be" (p prop_Word64be)+ , 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)+ ] - ,("B.ByteString invariant", p (prop_invariant :: B B.ByteString ))- ,("[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] ))- ,("IntMap invariant", p (prop_invariant :: B (IntMap.IntMap B.ByteString) ))+ , testGroup "String utils"+ [ testProperty "getLazyByteString" prop_getLazyByteString+ , testProperty "getLazyByteStringNul" prop_getLazyByteStringNul+ , testProperty "getLazyByteStringNul No Null" prop_getLazyByteStringNul_noNul+ , testProperty "getRemainingLazyByteString" prop_getRemainingLazyByteString+ ] - ,("Set Word32", p (test :: T (Set.Set Word32) ))- ,("Map Word16 Int", p (test :: T (Map.Map Word16 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 - ,("(Maybe Int64, Bool, [Int])", p (test :: T (Maybe Int64, Bool, [Int])))+ , 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 -{------- Big tuples lack an Arbitrary instance in Hugs/QuickCheck---+ , 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 - ,("(Maybe Word16, Bool, [Int], Either Bool Word16, Int)",- p (test :: T (Maybe Word16, Bool, [Int], Either Bool Word16, Int) ))+ , testWithGen "Integer mixed" genInteger+ , testWithGen "Integer small" genIntegerSmall+ , testWithGen "Integer big" genIntegerBig - ,("(Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int)", p (roundTrip :: (Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int) -> Bool))+ , test' "Fixed" (test :: T (Fixed.Fixed Fixed.E3) ) test+#ifdef HAS_NATURAL+ , testWithGen "Natural mixed" genNatural+ , testWithGen "Natural small" genNaturalSmall+ , testWithGen "Natural big" genNaturalBig+#endif+ , testWithGen "GHC.Fingerprint" genFingerprint - ,("(Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int)", p (roundTrip :: (Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int) -> Bool))--}+ , test' "Float" (test :: T Float ) test+ , test' "Double" (test :: T Double) test --- GHC only:--- ,("Sequence", p (roundTrip :: Seq.Seq Int64 -> Bool))+ , 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 --- Obsolete--- ,("ensureLeft/Fail", mytest (shouldFail (decode L.empty :: Either ParseError Int)))+ , test' "(Int, ByteString)"+ (test :: T (Int, B.ByteString) ) test+ , test' "[(Int, ByteString)]"+ (test :: T [(Int, B.ByteString)] ) test++ , 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++ , 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++ , 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)+ [ ("B.ByteString invariant", p (prop_invariant :: B B.ByteString ))+ , ("[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 ]
− tests/QuickCheckUtils.hs
@@ -1,258 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}------ Uses multi-param type classes----module QuickCheckUtils where--import Control.Monad--import Test.QuickCheck.Batch-import Test.QuickCheck-import Text.Show.Functions--import qualified Data.ByteString as B-import qualified Data.ByteString.Unsafe as B-import qualified Data.ByteString.Internal as B-import qualified Data.ByteString.Lazy as L-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet--import qualified Control.Exception as C (evaluate)--import Control.Monad ( liftM2 )-import Data.Char-import Data.List-import Data.Word-import Data.Int-import System.Random-import System.IO---- import Control.Concurrent-import System.Mem-import System.CPUTime-import Text.Printf--import qualified Data.ByteString as P-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Lazy.Internal as L---- import qualified Data.Sequence as Seq---- Enable this to get verbose test output. Including the actual tests.-debug = False--mytest :: Testable a => a -> Int -> IO ()-mytest a n = mycheck defaultConfig- { configMaxTest=n- , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a--mycheck :: Testable a => Config -> a -> IO ()-mycheck config a = do- rnd <- newStdGen- performGC -- >> threadDelay 100- t <- mytests config (evaluate a) rnd 0 0 [] 0 -- 0- printf " %0.3f seconds\n" (t :: Double)- hFlush stdout--time :: a -> IO (a , Double)-time a = do- start <- getCPUTime- v <- C.evaluate a- v `seq` return ()- end <- getCPUTime- return (v, ( (fromIntegral (end - start)) / (10^12)))--mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> Double -> IO Double-mytests config gen rnd0 ntest nfail stamps t0- | ntest == configMaxTest config = do done "OK," ntest stamps- return t0-- | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps- return t0-- | otherwise = do- (result,t1) <- time (generate (configSize config ntest) rnd2 gen)-- putStr (configEvery config ntest (arguments result)) >> hFlush stdout- case ok result of- Nothing ->- mytests config gen rnd1 ntest (nfail+1) stamps (t0 + t1)- Just True ->- mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) (t0 + t1)- Just False -> do- putStr ( "Falsifiable after "- ++ show ntest- ++ " tests:\n"- ++ unlines (arguments result)- ) >> hFlush stdout- return t0-- where- (rnd1,rnd2) = split rnd0--done :: String -> Int -> [[String]] -> IO ()-done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )- where- table = display- . map entry- . reverse- . sort- . map pairLength- . group- . sort- . filter (not . null)- $ stamps-- display [] = ". "- display [x] = " (" ++ x ++ "). "- display xs = ".\n" ++ unlines (map (++ ".") xs)-- pairLength xss@(xs:_) = (length xss, xs)- entry (n, xs) = percentage n ntest- ++ " "- ++ concat (intersperse ", " xs)-- percentage n m = show ((100 * n) `div` m) ++ "%"----------------------------------------------------------------------------instance Random Word8 where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Int8 where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Word16 where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Int16 where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Word where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Word32 where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Int32 where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Word64 where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Int64 where- randomR = integralRandomR- random = randomR (minBound,maxBound)----------------------------------------------------------------------------integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)-integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,- fromIntegral b :: Integer) g of- (x,g) -> (fromIntegral x, g)----------------------------------------------------------------------------instance Arbitrary Word8 where- arbitrary = choose (0, 2^8-1)- coarbitrary w = variant 0--instance Arbitrary Word16 where- arbitrary = choose (0, 2^16-1)- coarbitrary = undefined--instance Arbitrary Word32 where--- arbitrary = choose (0, 2^32-1)- arbitrary = choose (minBound, maxBound)- coarbitrary = undefined--instance Arbitrary Word64 where--- arbitrary = choose (0, 2^64-1)- arbitrary = choose (minBound, maxBound)- coarbitrary = undefined--instance Arbitrary Int8 where--- arbitrary = choose (0, 2^8-1)- arbitrary = choose (minBound, maxBound)- coarbitrary w = variant 0--instance Arbitrary Int16 where--- arbitrary = choose (0, 2^16-1)- arbitrary = choose (minBound, maxBound)- coarbitrary = undefined--instance Arbitrary Int32 where--- arbitrary = choose (0, 2^32-1)- arbitrary = choose (minBound, maxBound)- coarbitrary = undefined--instance Arbitrary Int64 where--- arbitrary = choose (0, 2^64-1)- arbitrary = choose (minBound, maxBound)- coarbitrary = undefined--instance Arbitrary Word where- arbitrary = choose (minBound, maxBound)- coarbitrary w = variant 0----------------------------------------------------------------------------instance Arbitrary Char where- arbitrary = choose (maxBound, minBound)- coarbitrary = undefined--{--instance Arbitrary a => Arbitrary (Maybe a) where- arbitrary = oneof [ return Nothing, liftM Just arbitrary]- coarbitrary = undefined- -}--instance Arbitrary Ordering where- arbitrary = oneof [ return LT,return GT,return EQ ]- coarbitrary = undefined--{--instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where- arbitrary = oneof [ liftM Left arbitrary, liftM Right arbitrary]- coarbitrary = undefined- -}--instance Arbitrary IntSet.IntSet where- arbitrary = fmap IntSet.fromList arbitrary- coarbitrary = undefined--instance (Arbitrary e) => Arbitrary (IntMap.IntMap e) where- arbitrary = fmap IntMap.fromList arbitrary- coarbitrary = undefined--instance (Arbitrary a, Ord a) => Arbitrary (Set.Set a) where- arbitrary = fmap Set.fromList arbitrary- coarbitrary = undefined--instance (Arbitrary a, Ord a, Arbitrary b) => Arbitrary (Map.Map a b) where- arbitrary = fmap Map.fromList arbitrary- coarbitrary = undefined--{--instance (Arbitrary a) => Arbitrary (Seq.Seq a) where- arbitrary = fmap Seq.fromList arbitrary- coarbitrary = undefined--}--instance Arbitrary L.ByteString where- arbitrary = arbitrary >>= return . L.fromChunks . filter (not. B.null) -- maintain the invariant.- coarbitrary s = coarbitrary (L.unpack s)--instance Arbitrary B.ByteString where- arbitrary = B.pack `fmap` arbitrary- coarbitrary s = coarbitrary (B.unpack s)
tools/derive/BinaryDerive.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE ScopedTypeVariables #-} module BinaryDerive where @@ -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@@ -45,7 +45,7 @@ else " get =") ++ concatMap ((++"\n")) (map getDef constrs) ++ (if length constrs > 1- then " _ -> fail \"no parse\""+ then " _ -> fail \"no decoding\"" else "" ) getDef (n, (name, ps)) =
tools/derive/Example.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} import Data.Generics @@ -38,31 +39,34 @@ 0 -> get >>= \a -> return (Laptop a) 1 -> get >>= \a -> get >>= \b -> return (Desktop a b) --- | All drinks mankind will ever need-data Drinks = Beer Bool{-ale?-}- | Coffee- | Tea- | EnergyDrink- | Water- | Wine- | Whisky+data Exp = ExpOr Exp Exp+ | ExpAnd Exp Exp+ | ExpEq Exp Exp+ | ExpNEq Exp Exp+ | ExpAdd Exp Exp+ | ExpSub Exp Exp+ | ExpVar String+ | ExpInt Int deriving (Typeable, Data, Show, Eq) -instance Binary Main.Drinks where- put (Beer a) = putWord8 0 >> put a- put Coffee = putWord8 1- put Tea = putWord8 2- put EnergyDrink = putWord8 3- put Water = putWord8 4- put Wine = putWord8 5- put Whisky = putWord8 6+instance Binary Main.Exp where+ put (ExpOr a b) = putWord8 0 >> put a >> put b+ put (ExpAnd a b) = putWord8 1 >> put a >> put b+ put (ExpEq a b) = putWord8 2 >> put a >> put b+ put (ExpNEq a b) = putWord8 3 >> put a >> put b+ put (ExpAdd a b) = putWord8 4 >> put a >> put b+ put (ExpSub a b) = putWord8 5 >> put a >> put b+ put (ExpVar a) = putWord8 6 >> put a+ put (ExpInt a) = putWord8 7 >> put a get = do tag_ <- getWord8 case tag_ of- 0 -> get >>= \a -> return (Beer a)- 1 -> return Coffee- 2 -> return Tea- 3 -> return EnergyDrink- 4 -> return Water- 5 -> return Wine- 6 -> return Whisky+ 0 -> get >>= \a -> get >>= \b -> return (ExpOr a b)+ 1 -> get >>= \a -> get >>= \b -> return (ExpAnd a b)+ 2 -> get >>= \a -> get >>= \b -> return (ExpEq a b)+ 3 -> get >>= \a -> get >>= \b -> return (ExpNEq a b)+ 4 -> get >>= \a -> get >>= \b -> return (ExpAdd a b)+ 5 -> get >>= \a -> get >>= \b -> return (ExpSub a b)+ 6 -> get >>= \a -> return (ExpVar a)+ 7 -> get >>= \a -> return (ExpInt a)+ _ -> fail "no decoding"