binary 0.7.6.1 → 0.8.0.0

raw patch · 16 files changed

+606/−178 lines, 16 filesdep +tardep +unordered-containersdep +zlibdep ~Cabaldep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: tar, unordered-containers, zlib

Dependency ranges changed: Cabal, base, bytestring, criterion

API changes (from Hackage documentation)

Files

• benchmarks/Builder.hs +5/−3
• benchmarks/GenericsBench.hs +52/−0
• benchmarks/GenericsBenchCache.hs +89/−0
• benchmarks/GenericsBenchTypes.hs +46/−0
• benchmarks/Get.hs +167/−105
• binary.cabal +30/−3
• changelog.md +8/−0
• src/Data/Binary.hs +9/−3
• src/Data/Binary/Builder/Base.hs +15/−0
• src/Data/Binary/Class.hs +68/−9
• src/Data/Binary/Generic.hs +27/−12
• src/Data/Binary/Get.hs +9/−10
• src/Data/Binary/Get/Internal.hs +19/−18
• src/Data/Binary/Put.hs +13/−8
• tests/File.hs +11/−7
• tests/QC.hs +38/−0

@@ -6,15 +6,17 @@  module Main (main) where +#if ! MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid(mappend, mempty))+#endif+ import Control.DeepSeq import Control.Exception (evaluate)-import Control.Monad.Trans (liftIO) import Criterion.Main import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.Lazy as L import Data.Char (ord)-import Data.Monoid (Monoid(mappend, mempty)) import Data.Word (Word8)  import Data.Binary.Builder@@ -84,7 +86,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 =

@@ -0,0 +1,52 @@+{-# LANGUAGE DeriveGeneric, StandaloneDeriving, BangPatterns #-}+module Main where++import qualified Data.ByteString.Lazy            as L+import           Distribution.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])

@@ -0,0 +1,89 @@+{-# LANGUAGE DeriveGeneric, StandaloneDeriving, BangPatterns, CPP #-}+module GenericsBenchCache (readPackageDescriptionCache) where++import qualified Text.ParserCombinators.ReadP                  as Read++import qualified Data.ByteString.Lazy                          as L+import qualified Data.ByteString.Lazy.Char8                    as LC8++import           Data.Version                                  (parseVersion)+import           Distribution.PackageDescription+import           Distribution.PackageDescription.Configuration+import           Distribution.PackageDescription.Parse+import           Distribution.Version                          (Version)++import qualified Codec.Archive.Tar                             as Tar+import qualified Codec.Compression.GZip                        as GZip+import qualified Data.HashMap.Lazy                             as Map+import           System.Directory+import           System.Exit++import           GenericsBenchTypes                            ()++#if ! MIN_VERSION_base(4,8,0)+import           Control.Applicative                           ((<$>))+#endif++readTar :: String -> Int -> IO [PackageDescription]+readTar tarPath limit = do+  entries <- Tar.read . GZip.decompress <$> L.readFile tarPath+  let contents = Tar.foldEntries unpack [] (error "tar error") entries+  let !pkgs = Map.fromListWith pick+                      [ (pkg, (version, content))+                      | (path, content) <- contents+                      , Just (pkg, version) <- return (readFilePath path) ]++  return $ take limit [ flattenPackageDescription gpd+                      | (_, (_, content)) <- Map.toList pkgs+                      , ParseOk _warns gpd <- return (parsePackageDescription (LC8.unpack content)) ]+    where+      pick (v,a) (w,b) | v >= w = (v,a)+                       | otherwise = (w,b)+      unpack e acc =+        case Tar.entryContent e of+          Tar.NormalFile content _ -> (Tar.entryPath e, content):acc+          _ -> acc++readFilePath :: String -> Maybe (String, Version)+readFilePath str = extract (Read.readP_to_S parse str)+  where+    extract [(result,_)] = Just result+    extract _ = Nothing+    parse = do+      packageName <- Read.many1 (Read.satisfy (/='/'))+      _ <- Read.char '/'+      version <- parseVersion+      _ <- Read.char '/'+      return (packageName, version)++writePackageDescriptionCache :: String -> [PackageDescription] -> IO ()+writePackageDescriptionCache path = writeFile path . show++readPackageDescriptionCache :: Int -> IO [PackageDescription]+readPackageDescriptionCache amount = do+  let cacheFilePath' = cacheFilePath ++ "-" ++ (show amount)+  createPackageDescriptionCache cacheFilePath' amount+  pds <- read <$> readFile cacheFilePath'+  -- PackageDescription doesn't implement NFData, let's force with the following line+  (length (show pds)) `seq` return pds++cacheFilePath :: String+cacheFilePath = "generics-bench.cache"++createPackageDescriptionCache :: String -> Int -> IO ()+createPackageDescriptionCache path amount = do+  cacheExists <- doesFileExist path+  if cacheExists+    then putStrLn "reusing cache from previous run"+    else do+      putStr "creating cabal cache file... "+      tarFilePath <- (++"/.cabal/packages/hackage.haskell.org/00-index.tar.gz") <$> getHomeDirectory+      fileExists <- doesFileExist tarFilePath+      if fileExists+        then do+          pds <- readTar tarFilePath amount+          writePackageDescriptionCache path pds+          putStrLn "done"+        else do+          putStrLn (tarFilePath ++ " missing, aborting")+          exitFailure

@@ -0,0 +1,46 @@+{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module GenericsBenchTypes where++import           Distribution.Compiler+import           Distribution.License+import           Distribution.ModuleName         hiding (main)+import           Distribution.Package+import           Distribution.PackageDescription+import           Distribution.Version+import           Language.Haskell.Extension++import           GHC.Generics                    (Generic)++import           Data.Binary+++deriving instance Generic Version++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 SourceRepo+instance Binary TestSuite+instance Binary TestSuiteInterface+instance Binary TestType+instance Binary VersionRange

@@ -8,21 +8,19 @@  import Control.DeepSeq import Control.Exception (evaluate)-import Control.Monad.Trans (liftIO) import Criterion.Main import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as L+import Data.Bits import Data.Char (ord)-import Data.Monoid (Monoid(mappend, mempty))-import Data.Word (Word8, Word16, Word32)+import Data.List (foldl')  import Control.Applicative+import Data.Binary import Data.Binary.Get-import Data.Binary ( get )  import qualified Data.Serialize.Get as Cereal-import qualified Data.Serialize as Cereal  import qualified Data.Attoparsec.ByteString as A import qualified Data.Attoparsec.ByteString.Lazy as AL@@ -40,62 +38,88 @@     rnf bracketsInChunks,     rnf bracketCount,     rnf oneMegabyte,-    rnf oneMegabyteLBS+    rnf oneMegabyteLBS,+    rnf manyBytes,+    rnf encodedBigInteger      ]   defaultMain-    [-      bench "brackets 100kb one chunk input" $-        whnf (checkBracket . runTest bracketParser) brackets-    , bench "brackets 100kb in 100 byte chunks" $-        whnf (checkBracket . runTest bracketParser) bracketsInChunks-    , bench "Attoparsec lazy-bs brackets 100kb one chunk" $-        whnf (checkBracket . runAttoL bracketParser_atto) brackets-    , bench "Attoparsec lazy-bs brackets 100kb in 100 byte chunks" $-        whnf (checkBracket . runAttoL bracketParser_atto) bracketsInChunks-    , bench "Attoparsec strict-bs brackets 100kb" $-        whnf (checkBracket . runAtto bracketParser_atto) $ S.concat (L.toChunks brackets)-    , bench "Cereal strict-bs brackets 100kb" $-        whnf (checkBracket . runCereal bracketParser_cereal) $ S.concat (L.toChunks brackets)-    , bench "Binary getStruct4 1MB struct of 4 word8" $-        whnf (runTest (getStruct4 mega)) oneMegabyteLBS-    , bench "Cereal getStruct4 1MB struct of 4 word8" $-        whnf (runCereal (getStruct4_cereal mega)) oneMegabyte-    , bench "Attoparsec getStruct4 1MB struct of 4 word8" $-        whnf (runAtto (getStruct4_atto mega)) oneMegabyte-    , bench "Binary getWord8 1MB chunk size 1 byte" $-        whnf (runTest (getWord8N1 mega)) oneMegabyteLBS-    , bench "Cereal getWord8 1MB chunk size 1 byte" $-        whnf (runCereal (getWord8N1_cereal mega)) oneMegabyte-    , bench "Attoparsec getWord8 1MB chunk size 1 byte" $-        whnf (runAtto (getWord8N1_atto mega)) oneMegabyte-    , bench "getWord8 1MB chunk size 2 bytes" $-        whnf (runTest (getWord8N2 mega)) oneMegabyteLBS-    , bench "getWord8 1MB chunk size 4 bytes" $-        whnf (runTest (getWord8N4 mega)) oneMegabyteLBS-    , bench "getWord8 1MB chunk size 8 bytes" $-        whnf (runTest (getWord8N8 mega)) oneMegabyteLBS-    , bench "getWord8 1MB chunk size 16 bytes" $-        whnf (runTest (getWord8N16 mega)) oneMegabyteLBS-    , bench "getWord8 1MB chunk size 2 bytes Applicative" $-        whnf (runTest (getWord8N2A mega)) oneMegabyteLBS-    , bench "getWord8 1MB chunk size 4 bytes Applicative" $-        whnf (runTest (getWord8N4A mega)) oneMegabyteLBS-    , bench "getWord8 1MB chunk size 8 bytes Applicative" $-        whnf (runTest (getWord8N8A mega)) oneMegabyteLBS-    , bench "getWord8 1MB chunk size 16 bytes Applicative" $-        whnf (runTest (getWord8N16A mega)) oneMegabyteLBS+    [ bgroup "brackets"+        [ bench "Binary 100kb, one chunk" $+            whnf (checkBracket . runTest bracketParser) brackets+        , bench "Binary 100kb, 100 byte chunks" $+            whnf (checkBracket . runTest bracketParser) bracketsInChunks+        , bench "Attoparsec lazy-bs 100kb, one chunk" $+            whnf (checkBracket . runAttoL bracketParser_atto) brackets+        , bench "Attoparsec lazy-bs 100kb, 100 byte chunks" $+            whnf (checkBracket . runAttoL bracketParser_atto) bracketsInChunks+        , bench "Attoparsec strict-bs 100kb" $+            whnf (checkBracket . runAtto bracketParser_atto) $ S.concat (L.toChunks brackets)+        , bench "Cereal strict-bs 100kb" $+            whnf (checkBracket . runCereal bracketParser_cereal) $ S.concat (L.toChunks brackets)+        ]+    , bgroup "comparison getStruct4, 1MB of struct of 4 Word8s"+      [ bench "Attoparsec" $+          whnf (runAtto (getStruct4_atto mega)) oneMegabyte+      , bench "Binary" $+          whnf (runTest (getStruct4 mega)) oneMegabyteLBS+      , bench "Cereal" $+          whnf (runCereal (getStruct4_cereal mega)) oneMegabyte+      ]+    , bgroup "comparison getWord8, 1MB"+        [ bench "Attoparsec" $+            whnf (runAtto (getWord8N1_atto mega)) oneMegabyte+        , bench "Binary" $+            whnf (runTest (getWord8N1 mega)) oneMegabyteLBS+        , bench "Cereal" $+            whnf (runCereal (getWord8N1_cereal mega)) oneMegabyte+        ]+    , bgroup "getWord8 1MB"+        [ bench "chunk size 2 bytes" $+            whnf (runTest (getWord8N2 mega)) oneMegabyteLBS+        , bench "chunk size 4 bytes" $+            whnf (runTest (getWord8N4 mega)) oneMegabyteLBS+        , bench "chunk size 8 bytes" $+            whnf (runTest (getWord8N8 mega)) oneMegabyteLBS+        , bench "chunk size 16 bytes" $+            whnf (runTest (getWord8N16 mega)) oneMegabyteLBS+        ]+    , bgroup "getWord8 1MB Applicative"+        [ bench "chunk size 2 bytes" $+            whnf (runTest (getWord8N2A mega)) oneMegabyteLBS+        , bench "chunk size 4 bytes" $+            whnf (runTest (getWord8N4A mega)) oneMegabyteLBS+        , bench "chunk size 8 bytes" $+            whnf (runTest (getWord8N8A mega)) oneMegabyteLBS+        , bench "chunk size 16 bytes" $+            whnf (runTest (getWord8N16A mega)) oneMegabyteLBS+        ]+    , bgroup "roll"+        [ bench "foldr"  $ nf (roll_foldr  :: [Word8] -> Integer) manyBytes+        , bench "foldl'" $ nf (roll_foldl' :: [Word8] -> Integer) manyBytes+        ]+    , bgroup "Integer"+        [ bench "decode" $ nf (decode :: L.ByteString -> Integer) encodedBigInteger+        ]     ] +checkBracket :: Int -> Int checkBracket x | x == bracketCount = x                | otherwise = error "argh!" +runTest :: Get a -> L.ByteString -> a runTest decoder inp = runGet decoder inp++runCereal :: Cereal.Get a -> C8.ByteString -> a runCereal decoder inp = case Cereal.runGet decoder inp of                           Right a -> a                           Left err -> error err++runAtto :: AL.Parser a -> C8.ByteString -> a runAtto decoder inp = case A.parseOnly decoder inp of                         Right a -> a                         Left err -> error err++runAttoL :: Show a => AL.Parser a -> L.ByteString -> a runAttoL decoder inp = case AL.parse decoder inp of                         AL.Done _ r -> r                         a -> error (show a)@@ -108,15 +132,20 @@ oneMegabyteLBS :: L.ByteString oneMegabyteLBS = L.fromChunks [oneMegabyte] +mega :: Int mega = 1024 * 1024  -- 100k of brackets+bracketTest :: L.ByteString -> Int bracketTest inp = runTest bracketParser inp  bracketCount :: Int bracketCount = fromIntegral $ L.length brackets `div` 2 +brackets :: L.ByteString brackets = L.fromChunks [C8.concat (L.toChunks bracketsInChunks)]++bracketsInChunks :: L.ByteString bracketsInChunks = L.fromChunks (replicate chunksOfBrackets oneChunk)   where     oneChunk = "((()((()()))((()(()()()()()()()(((()()()()(()()(()(()())))))()((())())))()())(((())())(()))))()(()))"@@ -143,19 +172,23 @@ bracketParser_atto :: A.Parser Int bracketParser_atto = cont <|> return 0   where-  cont = do v <- some ( do A.word8 40+  cont = do v <- some ( do _ <- A.word8 40                            n <- bracketParser_atto-                           A.word8 41+                           _ <- A.word8 41                            return $! n + 1)             return $! sum v  -- Strict struct of 4 Word8s-data Struct4 = Struct4 {-# UNPACK #-} !Word8-                       {-# UNPACK #-} !Word8-                       {-# UNPACK #-} !Word8-                       {-# UNPACK #-} !Word8-               deriving Show+data S2 = S2 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+data S4 = S4 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+data S8 = S8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+             {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+data S16 = S16 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+               {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+               {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+               {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 +getStruct4 :: Int -> Get [S4] getStruct4 = loop []   where loop acc 0 = return acc         loop acc n = do@@ -163,9 +196,10 @@           !w1 <- getWord8           !w2 <- getWord8           !w3 <- getWord8-          let !s = Struct4 w0 w1 w2 w3+          let !s = S4 w0 w1 w2 w3           loop (s : acc) (n - 4) +getStruct4_cereal :: Int -> Cereal.Get [S4] getStruct4_cereal = loop []   where loop acc 0 = return acc         loop acc n = do@@ -173,9 +207,10 @@           !w1 <- Cereal.getWord8           !w2 <- Cereal.getWord8           !w3 <- Cereal.getWord8-          let !s = Struct4 w0 w1 w2 w3+          let !s = S4 w0 w1 w2 w3           loop (s : acc) (n - 4) +getStruct4_atto :: Int -> A.Parser [S4] getStruct4_atto = loop []   where loop acc 0 = return acc         loop acc n = do@@ -183,48 +218,53 @@           !w1 <- A.anyWord8           !w2 <- A.anyWord8           !w3 <- A.anyWord8-          let !s = Struct4 w0 w1 w2 w3+          let !s = S4 w0 w1 w2 w3           loop (s : acc) (n - 4) --- No-allocation loops.--getWord8N1 = loop 0+getWord8N1 :: Int -> Get [Word8]+getWord8N1 = loop []   where loop s n | s `seq` n `seq` False = undefined         loop s 0 = return s         loop s n = do           s0 <- getWord8-          loop (s0+s) (n-1)+          loop (s0:s) (n-1) -getWord8N1_cereal = loop 0+getWord8N1_cereal :: Int -> Cereal.Get [Word8]+getWord8N1_cereal = loop []   where loop s n | s `seq` n `seq` False = undefined         loop s 0 = return s         loop s n = do           s0 <- Cereal.getWord8-          loop (s0+s) (n-1)+          loop (s0:s) (n-1) -getWord8N1_atto = loop 0+getWord8N1_atto :: Int -> A.Parser [Word8]+getWord8N1_atto = loop []   where loop s n | s `seq` n `seq` False = undefined         loop s 0 = return s         loop s n = do           s0 <- A.anyWord8-          loop (s0+s) (n-1)+          loop (s0:s) (n-1) -getWord8N2 = loop 0+getWord8N2 :: Int -> Get [S2]+getWord8N2 = loop []   where loop s n | s `seq` n `seq` False = undefined         loop s 0 = return s         loop s n = do           s0 <- getWord8           s1 <- getWord8-          loop (s0+s1+s) (n-2)+          let !v = S2 s0 s1+          loop (v:s) (n-2) -getWord8N2A = loop 0+getWord8N2A :: Int -> Get [S2]+getWord8N2A = loop []   where loop s n | s `seq` n `seq` False = undefined         loop s 0 = return s         loop s n = do-          v <- (+) <$> getWord8 <*> getWord8-          loop (s+v) (n-2)+          !v <- S2 <$> getWord8 <*> getWord8+          loop (v:s) (n-2) -getWord8N4 = loop 0+getWord8N4 :: Int -> Get [S4]+getWord8N4 = loop []   where loop s n | s `seq` n `seq` False = undefined         loop s 0 = return s         loop s n = do@@ -232,17 +272,19 @@           s1 <- getWord8           s2 <- getWord8           s3 <- getWord8-          loop (s+s0+s1+s2+s3) (n-4)+          let !v = S4 s0 s1 s2 s3+          loop (v:s) (n-4) -getWord8N4A = loop 0+getWord8N4A :: Int -> Get [S4]+getWord8N4A = loop []   where loop s n | s `seq` n `seq` False = undefined         loop s 0 = return s         loop s n = do-          let p !s0 !s1 !s2 !s3 = s0 + s1 + s2 + s3-          v <- p <$> getWord8 <*> getWord8 <*> getWord8 <*> getWord8-          loop (s+v) (n-4)+          !v <- S4 <$> getWord8 <*> getWord8 <*> getWord8 <*> getWord8+          loop (v:s) (n-4) -getWord8N8 = loop 0+getWord8N8 :: Int -> Get [S8]+getWord8N8 = loop []   where loop s n | s `seq` n `seq` False = undefined         loop s 0 = return s         loop s n = do@@ -254,15 +296,15 @@           s5 <- getWord8           s6 <- getWord8           s7 <- getWord8-          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)+          let !v = S8 s0 s1 s2 s3 s4 s5 s6 s7+          loop (v:s) (n-8) -getWord8N8A = loop 0+getWord8N8A :: Int -> Get [S8]+getWord8N8A = loop []   where loop s n | s `seq` n `seq` False = undefined         loop s 0 = return s         loop s n = do-          let p !s0 !s1 !s2 !s3 !s4 !s5 !s6 !s7 =-                s0 + s1 + s2 + s3 + s4 + s5 + s6 + s7-          v <- p <$> getWord8+          !v <- S8 <$> getWord8                    <*> getWord8                    <*> getWord8                    <*> getWord8@@ -270,9 +312,10 @@                    <*> getWord8                    <*> getWord8                    <*> getWord8-          loop (s+v) (n-8)+          loop (v:s) (n-8) -getWord8N16 = loop 0+getWord8N16 :: Int -> Get [S16]+getWord8N16 = loop []   where loop s n | s `seq` n `seq` False = undefined         loop s 0 = return s         loop s n = do@@ -292,28 +335,47 @@           s13 <- getWord8           s14 <- getWord8           s15 <- getWord8-          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11+s12+s13+s14+s15) (n-16)+          let !v = S16 s0 s1 s2 s3 s4 s5 s6 s7 s8 s9 s10 s11 s12 s13 s14 s15+          loop (v:s) (n-16) -getWord8N16A = loop 0+getWord8N16A :: Int -> Get [S16]+getWord8N16A = loop []   where loop s n | s `seq` n `seq` False = undefined         loop s 0 = return s         loop s n = do-          let p !s0 !s1 !s2 !s3 !s4 !s5 !s6 !s7 !s8 !s9 !s10 !s11 !s12 !s13 !s14 !s15 =-                s0 + s1 + s2 + s3 + s4 + s5 + s6 + s7 + s8 + s9 + s10 + s11 + s12 + s13 + s14 + s15-          !v <- p <$> getWord8-                   <*> getWord8-                   <*> getWord8-                   <*> getWord8-                   <*> getWord8-                   <*> getWord8-                   <*> getWord8-                   <*> getWord8-                   <*> getWord8-                   <*> getWord8-                   <*> getWord8-                   <*> getWord8-                   <*> getWord8-                   <*> getWord8-                   <*> getWord8-                   <*> getWord8-          loop (s+v) (n-16)+          !v <- S16 <$> getWord8+                    <*> getWord8+                    <*> getWord8+                    <*> getWord8+                    <*> getWord8+                    <*> getWord8+                    <*> getWord8+                    <*> getWord8+                    <*> getWord8+                    <*> getWord8+                    <*> getWord8+                    <*> getWord8+                    <*> getWord8+                    <*> getWord8+                    <*> getWord8+                    <*> getWord8+          loop (v:s) (n-16)++manyBytes :: [Word8]+manyBytes = concat $ replicate 256 [0..255]++bigInteger :: Integer+bigInteger = roll_foldl' manyBytes++encodedBigInteger :: L.ByteString+encodedBigInteger = encode bigInteger++roll_foldr :: (Integral a, Num a, Bits a) => [Word8] -> a+roll_foldr   = foldr unstep 0+  where+    unstep b a = a `shiftL` 8 .|. fromIntegral b++roll_foldl' :: (Integral a, Num a, Bits a) => [Word8] -> a+roll_foldl'   = foldl' unstep 0 . reverse+  where+    unstep a b = a `shiftL` 8 .|. fromIntegral b

@@ -1,5 +1,5 @@ name:            binary-version:         0.7.6.1+version:         0.8.0.0 license:         BSD3 license-file:    LICENSE author:          Lennart Kolmodin <kolmodin@gmail.com>@@ -18,7 +18,7 @@ stability:       provisional build-type:      Simple cabal-version:   >= 1.8-tested-with:     GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1+tested-with:     GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2 extra-source-files:   README.md changelog.md docs/hcar/binary-Lb.tex tools/derive/*.hs @@ -120,7 +120,34 @@     mtl   -- build dependencies from using binary source rather than depending on the library   build-depends: array, containers-  ghc-options: -O2+  ghc-options: -O2 -Wall++benchmark generics-bench+  type: exitcode-stdio-1.0+  hs-source-dirs: src benchmarks+  main-is: GenericsBench.hs+  build-depends:+    base >= 3.0 && < 5,+    bytestring,+    Cabal == 1.22.*,+    directory,+    filepath,+    tar,+    unordered-containers,+    zlib,+    criterion+  other-modules:+    GenericsBenchCache+    GenericsBenchTypes+  -- build dependencies from using binary source rather than depending on the library+  build-depends: array, containers+  ghc-options: -O2 -Wall+  if impl(ghc >= 7.2.1)+    cpp-options: -DGENERICS+    other-modules: Data.Binary.Generic+    if impl(ghc <= 7.6)+      -- prior to ghc-7.4 generics lived in ghc-prim+      build-depends: ghc-prim  benchmark builder   type: exitcode-stdio-1.0

@@ -1,6 +1,14 @@ binary ====== +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 -------------- 

@@ -30,8 +30,9 @@ -- If the specifics of the data format is not important to you, for example, -- you are more interested in serializing and deserializing values than -- in which format will be used, it is possible to derive 'Binary'--- instances using the generic support. See 'GBinary'.--- +-- instances using the generic support. See 'GBinaryGet' and+-- 'GBinaryPut'.+-- -- If you have specific requirements about the encoding format, you can use -- the encoding and decoding primitives directly, see the modules -- "Data.Binary.Get" and "Data.Binary.Put".@@ -48,7 +49,8 @@ #ifdef GENERICS     -- * Generic support     -- $generics-    , GBinary(..)+    , GBinaryGet(..)+    , GBinaryPut(..) #endif      -- * The Get and Put monads@@ -180,6 +182,8 @@ -- 'Right' on success. In both cases the unconsumed input and the number of -- consumed bytes is returned. In case of failure, a human-readable error -- message will be returned as well.+--+-- /Since: 0.7.0.0/ decodeOrFail :: Binary a => L.ByteString              -> Either (L.ByteString, ByteOffset, String)                        (L.ByteString, ByteOffset, a)@@ -204,6 +208,8 @@  -- | Decode a value from a file. In case of errors, 'error' will -- be called with the error message.+--+-- /Since: 0.7.0.0/ decodeFile :: Binary a => FilePath -> IO a decodeFile f = do   result <- decodeFileOrFail f

@@ -64,7 +64,11 @@  import qualified Data.ByteString      as S import qualified Data.ByteString.Lazy as L+#if MIN_VERSION_base(4,9,0)+import Data.Semigroup+#else import Data.Monoid+#endif import Data.Word import Foreign @@ -107,10 +111,20 @@                    -> IO L.ByteString     } +#if MIN_VERSION_base(4,9,0)+instance Semigroup Builder where+    (<>) = append+    {-# INLINE (<>) #-}+#endif+ instance Monoid Builder where     mempty  = empty     {-# INLINE mempty #-}+#if MIN_VERSION_base(4,9,0)+    mappend = (<>)+#else     mappend = append+#endif     {-# INLINE mappend #-}     mconcat = foldr mappend mempty     {-# INLINE mconcat #-}@@ -191,6 +205,7 @@       else let !b  = Buffer p (o+u) 0 l                !bs = S.PS p o u            in return $! L.Chunk bs (inlinePerformIO (k b))+{-# INLINE [0] flush #-}  ------------------------------------------------------------------------ 

@@ -8,12 +8,21 @@  #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+ #if __GLASGOW_HASKELL__ >= 704 #define HAS_GHC_FINGERPRINT #endif +#ifndef HAS_FIXED_CONSTRUCTOR+{-# LANGUAGE ScopedTypeVariables #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module      : Data.Binary.Class@@ -35,7 +44,8 @@  #ifdef GENERICS     -- * Support for generics-    , GBinary(..)+    , GBinaryGet(..)+    , GBinaryPut(..) #endif      ) where@@ -43,17 +53,23 @@ import Data.Word import Data.Bits import Data.Int+#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+#endif import Control.Monad  import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as L  import Data.Char    (ord)-import Data.List    (unfoldr)+import Data.List    (unfoldr, foldl')  -- And needed for the instances: import qualified Data.ByteString as B@@ -74,6 +90,9 @@ #ifdef HAS_NATURAL import Numeric.Natural #endif++import qualified Data.Fixed as Fixed+ -- -- This isn't available in older Hugs or older GHC --@@ -86,11 +105,19 @@ import GHC.Fingerprint #endif +import Data.Version (Version(..))+ ------------------------------------------------------------------------  #ifdef GENERICS-class GBinary f where+-- Factored into two classes because this makes GHC optimize the+-- instances faster.  This doesn't matter for builds of binary,+-- but it matters a lot for end-users who write 'instance Binary T'.+-- See also: https://ghc.haskell.org/trac/ghc/ticket/9630+class GBinaryPut f where     gput :: f t -> Put++class GBinaryGet f where     gget :: Get (f t) #endif @@ -118,16 +145,26 @@     get :: Get t  #ifdef GENERICS-    default put :: (Generic t, GBinary (Rep t)) => t -> Put+    default put :: (Generic t, GBinaryPut (Rep t)) => t -> Put     put = gput . from -    default get :: (Generic t, GBinary (Rep t)) => Get t+    default get :: (Generic t, GBinaryGet (Rep t)) => Get t     get = to `fmap` gget #endif  ------------------------------------------------------------------------ -- 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@@ -239,24 +276,37 @@                     let v = roll bytes                     return $! if sign == (1 :: Word8) then v else - v +-- | /Since: 0.8.0.0/+#ifdef HAS_FIXED_CONSTRUCTOR+instance Binary (Fixed.Fixed a) where+  put (Fixed.MkFixed a) = put a+  get = Fixed.MkFixed `liftM` get+#else+instance forall a. Fixed.HasResolution a => Binary (Fixed.Fixed a) where+  -- Using undefined :: Maybe a as a proxy, as Data.Proxy is introduced only in base-4.7+  put x = put (truncate (x * fromInteger (Fixed.resolution (undefined :: Maybe a))) :: Integer)+  get = (\x -> fromInteger x / fromInteger (Fixed.resolution (undefined :: Maybe a))) `liftM` get+#endif+ -- -- Fold and unfold an Integer to and from a list of its bytes ---unroll :: (Integral a, Num a, Bits a) => a -> [Word8]+unroll :: (Integral a, Bits a) => a -> [Word8] unroll = unfoldr step   where     step 0 = Nothing     step i = Just (fromIntegral i, i `shiftR` 8) -roll :: (Integral a, Num a, Bits a) => [Word8] -> a-roll   = foldr unstep 0+roll :: (Integral a, Bits a) => [Word8] -> a+roll   = foldl' unstep 0 . reverse   where-    unstep b a = a `shiftL` 8 .|. fromIntegral b+    unstep a b = a `shiftL` 8 .|. fromIntegral b  #ifdef HAS_NATURAL -- Fixed-size type for a subset of Natural type NaturalWord = Word64 +-- | /Since: 0.7.3.0/ instance Binary Natural where     {-# INLINE put #-}     put n | n <= hi = do@@ -597,6 +647,7 @@ -- Fingerprints  #ifdef HAS_GHC_FINGERPRINT+-- | /Since: 0.7.6.0/ instance Binary Fingerprint where     put (Fingerprint x1 x2) = do         put x1@@ -606,3 +657,11 @@         x2 <- get         return $! Fingerprint x1 x2 #endif++------------------------------------------------------------------------+-- Version++-- | /Since: 0.8.0.0/+instance Binary Version where+    get = Version <$> get <*> get+    put (Version br tags) = put br >> put tags

@@ -32,28 +32,38 @@ import Prelude -- Silence AMP warning.  -- Type without constructors-instance GBinary V1 where+instance GBinaryPut V1 where     gput _ = return ()++instance GBinaryGet V1 where     gget   = return undefined  -- Constructor without arguments-instance GBinary U1 where+instance GBinaryPut U1 where     gput U1 = return ()++instance GBinaryGet U1 where     gget    = return U1  -- Product: constructor with parameters-instance (GBinary a, GBinary b) => GBinary (a :*: b) where+instance (GBinaryPut a, GBinaryPut b) => GBinaryPut (a :*: b) where     gput (x :*: y) = gput x >> gput y++instance (GBinaryGet a, GBinaryGet b) => GBinaryGet (a :*: b) where     gget = (:*:) <$> gget <*> gget  -- Metadata (constructor name, etc)-instance GBinary a => GBinary (M1 i c a) where+instance GBinaryPut a => GBinaryPut (M1 i c a) where     gput = gput . unM1++instance GBinaryGet a => GBinaryGet (M1 i c a) where     gget = M1 <$> gget  -- Constants, additional parameters, and rank-1 recursion-instance Binary a => GBinary (K1 i a) where+instance Binary a => GBinaryPut (K1 i a) where     gput = put . unK1++instance Binary a => GBinaryGet (K1 i a) where     gget = K1 <$> get  -- Borrowed from the cereal package.@@ -69,14 +79,15 @@ #define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size) #define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size) -instance ( GSum     a, GSum     b-         , GBinary a, GBinary b-         , SumSize    a, SumSize    b) => GBinary (a :+: b) where+instance ( GSumPut  a, GSumPut  b+         , SumSize    a, SumSize    b) => GBinaryPut (a :+: b) where     gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64)          | otherwise = sizeError "encode" size       where         size = unTagged (sumSize :: Tagged (a :+: b) Word64) +instance ( GSumGet  a, GSumGet  b+         , SumSize    a, SumSize    b) => GBinaryGet (a :+: b) where     gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64)          | otherwise = sizeError "decode" size       where@@ -88,23 +99,26 @@  ------------------------------------------------------------------------ -checkGetSum :: (Ord word, Num word, Bits word, GSum f)+checkGetSum :: (Ord word, Num word, Bits word, GSumGet f)             => word -> word -> Get (f a) checkGetSum size code | code < size = getSum code size                       | otherwise   = fail "Unknown encoding for constructor" {-# INLINE checkGetSum #-} -class GSum f where+class GSumGet f where     getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)++class GSumPut f where     putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put -instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where+instance (GSumGet a, GSumGet b) => GSumGet (a :+: b) where     getSum !code !size | code < sizeL = L1 <$> getSum code           sizeL                        | otherwise    = R1 <$> getSum (code - sizeL) sizeR         where           sizeL = size `shiftR` 1           sizeR = size - sizeL +instance (GSumPut a, GSumPut b) => GSumPut (a :+: b) where     putSum !code !size s = case s of                              L1 x -> putSum code           sizeL x                              R1 x -> putSum (code + sizeL) sizeR x@@ -112,9 +126,10 @@           sizeL = size `shiftR` 1           sizeR = size - sizeL -instance GBinary a => GSum (C1 c a) where+instance GBinaryGet a => GSumGet (C1 c a) where     getSum _ _ = gget +instance GBinaryPut a => GSumPut (C1 c a) where     putSum !code _ x = put code *> gput x  ------------------------------------------------------------------------

@@ -63,9 +63,6 @@ --getTrade' = Trade '<$>' 'getWord32le' '<*>' 'getWord32le' '<*>' 'getWord16le' -- @ ----- The applicative style can sometimes result in faster code, as @binary@--- will try to optimize the code by grouping the reads together.--- -- There are two kinds of ways to execute this decoder, the lazy input -- method and the incremental input method. Here we will use the lazy -- input method.@@ -299,6 +296,8 @@ -- success. In both cases any unconsumed input and the number of bytes -- consumed is returned. In the case of failure, a human-readable -- error message is included as well.+--+-- /Since: 0.6.4.0/ runGetOrFail :: Get a -> L.ByteString              -> Either (L.ByteString, ByteOffset, String) (L.ByteString, ByteOffset, a) runGetOrFail g lbs0 = feedAll (runGetIncremental g) lbs0@@ -409,7 +408,7 @@ -- | Read a Word8 from the monad state getWord8 :: Get Word8 getWord8 = readN 1 B.unsafeHead-{-# INLINE getWord8 #-}+{-# INLINE[2] getWord8 #-}  -- force GHC to inline getWordXX {-# RULES@@ -429,7 +428,7 @@ word16be = \s ->         (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w16` 8) .|.         (fromIntegral (s `B.unsafeIndex` 1))-{-# INLINE getWord16be #-}+{-# INLINE[2] getWord16be #-} {-# INLINE word16be #-}  -- | Read a Word16 in little endian format@@ -440,7 +439,7 @@ word16le = \s ->               (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w16` 8) .|.               (fromIntegral (s `B.unsafeIndex` 0) )-{-# INLINE getWord16le #-}+{-# INLINE[2] getWord16le #-} {-# INLINE word16le #-}  -- | Read a Word32 in big endian format@@ -453,7 +452,7 @@               (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 16) .|.               (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32`  8) .|.               (fromIntegral (s `B.unsafeIndex` 3) )-{-# INLINE getWord32be #-}+{-# INLINE[2] getWord32be #-} {-# INLINE word32be #-}  -- | Read a Word32 in little endian format@@ -466,7 +465,7 @@               (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 16) .|.               (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32`  8) .|.               (fromIntegral (s `B.unsafeIndex` 0) )-{-# INLINE getWord32le #-}+{-# INLINE[2] getWord32le #-} {-# INLINE word32le #-}  -- | Read a Word64 in big endian format@@ -483,7 +482,7 @@               (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 16) .|.               (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64`  8) .|.               (fromIntegral (s `B.unsafeIndex` 7) )-{-# INLINE getWord64be #-}+{-# INLINE[2] getWord64be #-} {-# INLINE word64be #-}  -- | Read a Word64 in little endian format@@ -500,7 +499,7 @@               (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 16) .|.               (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64`  8) .|.               (fromIntegral (s `B.unsafeIndex` 0) )-{-# INLINE getWord64le #-}+{-# INLINE[2] getWord64le #-} {-# INLINE word64le #-}  ------------------------------------------------------------------------

@@ -23,7 +23,7 @@     , withInputChunks     , Consume     , failOnEOF-    +     , get     , put     , ensureN@@ -91,14 +91,10 @@ type Success a r = B.ByteString -> a -> Decoder r  instance Monad Get where-  return = returnG+  return = pure   (>>=) = bindG   fail = failG -returnG :: a -> Get a-returnG a = C $ \s ks -> ks s a-{-# INLINE [0] returnG #-}- 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 #-}@@ -118,11 +114,12 @@ {-# INLINE fmapG #-}  instance Applicative Get where-  pure = returnG-  {-# INLINE pure #-}+  pure = \x -> C $ \s ks -> ks s x+  {-# INLINE [0] pure #-}   (<*>) = apG   {-# INLINE (<*>) #-} +-- | /Since: 0.7.1.0/ instance MonadPlus Get where   mzero = empty   mplus = (<|>)@@ -192,6 +189,8 @@ -- If the given decoder fails, 'isolate' will also fail. -- Offset from 'bytesRead' will be relative to the start of 'isolate', not the -- absolute of the input.+--+-- /Since: 0.7.2.0/ isolate :: Int   -- ^ The number of bytes that must be consumed         -> Get a -- ^ The decoder to isolate         -> Get a@@ -254,6 +253,7 @@ getBytes = getByteString {-# INLINE getBytes #-} +-- | /Since: 0.7.0.0/ instance Alternative Get where   empty = C $ \inp _ks -> Fail inp "Data.Binary.Get(Alternative).empty"   (<|>) f g = do@@ -272,7 +272,7 @@ #endif  -- | Run a decoder and keep track of all the input it consumes.--- Once it's finished, return the final decoder (always 'Done' or 'Fail'), +-- Once it's finished, return the final decoder (always 'Done' or 'Fail'), -- and unconsume all the the input the decoder required to run. -- Any additional chunks which was required to run the decoder -- will also be returned.@@ -298,6 +298,8 @@  -- | Run the given decoder, but without consuming its input. If the given -- decoder fails, then so will this function.+--+-- /Since: 0.7.0.0/ lookAhead :: Get a -> Get a lookAhead g = do   (decoder, bs) <- runAndKeepTrack g@@ -309,6 +311,8 @@ -- | Run the given decoder, and only consume its input if it returns 'Just'. -- If 'Nothing' is returned, the input will be unconsumed. -- If the given decoder fails, then so will this function.+--+-- /Since: 0.7.0.0/ lookAheadM :: Get (Maybe a) -> Get (Maybe a) lookAheadM g = do   let g' = maybe (Left ()) Right <$> g@@ -317,6 +321,8 @@ -- | Run the given decoder, and only consume its input if it returns 'Right'. -- If 'Left' is returned, the input will be unconsumed. -- If the given decoder fails, then so will this function.+--+-- /Since: 0.7.1.0/ lookAheadE :: Get (Either a b) -> Get (Either a b) lookAheadE g = do   (decoder, bs) <- runAndKeepTrack g@@ -326,8 +332,10 @@     Fail inp s -> C $ \_ _ -> Fail inp s     _ -> error "Binary: impossible" --- Label a decoder. If the decoder fails, the label will be appended on+-- | Label a decoder. If the decoder fails, the label will be appended on -- a new line to the error message string.+--+-- /Since: 0.7.2.0/ label :: String -> Get a -> Get a label msg decoder = C $ \inp ks ->   let r0 = runCont decoder inp (\inp' a -> Done inp' a)@@ -380,17 +388,10 @@  {-# RULES -"<$> to <*>" forall f g.-  (<$>) f g = returnG f <*> g- "readN/readN merge" forall n m f g.   apG (readN n f) (readN m g) = readN (n+m) (\bs -> f bs $ g (B.unsafeDrop n bs)) -"returnG/readN swap" [~1] forall f.-  returnG f = readN 0 (const f)--"readN 0/returnG swapback" [1] forall f.-  readN 0 f = returnG (f B.empty) #-}+ #-}  -- | Ensure that there are at least @n@ bytes available. If not, the -- computation will escape with 'Partial'.

@@ -84,27 +84,32 @@         {-# INLINE fmap #-}  instance Applicative PutM where-        pure    = return+        pure a  = Put $ PairS a mempty+        {-# INLINE pure #-}+         m <*> k = Put $             let PairS f w  = unPut m                 PairS x w' = unPut k             in PairS (f x) (w `mappend` w') +        m *> k  = Put $+            let PairS _ w  = unPut m+                PairS b w' = unPut k+            in PairS b (w `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')     {-# 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 (>>) #-}  tell :: Builder -> Put

@@ -1,14 +1,18 @@+{-# LANGUAGE CPP #-} module Main where -import Control.Applicative-import Test.HUnit-import System.Directory ( getTemporaryDirectory )-import System.FilePath ( (</>) )+#if ! MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif -import Distribution.Simple.Utils ( withTempDirectory )-import Distribution.Verbosity ( silent )+import           System.Directory          (getTemporaryDirectory)+import           System.FilePath           ((</>))+import           Test.HUnit -import Data.Binary+import           Distribution.Simple.Utils (withTempDirectory)+import           Distribution.Verbosity    (silent)++import           Data.Binary  data Foo = Bar !Word32 !Word32 !Word32 deriving (Eq, Show) 

@@ -5,6 +5,10 @@ #define HAS_NATURAL #endif +#if MIN_VERSION_base(4,7,0)+#define HAS_FIXED_CONSTRUCTOR+#endif+ #if __GLASGOW_HASKELL__ >= 704 #define HAS_GHC_FINGERPRINT #endif@@ -28,6 +32,8 @@ import           GHC.Fingerprint #endif +import qualified Data.Fixed as Fixed+ import           Test.Framework import           Test.Framework.Providers.QuickCheck2 import           Test.QuickCheck@@ -398,6 +404,30 @@  ------------------------------------------------------------------------ +#ifdef HAS_FIXED_CONSTRUCTOR++fixedPut :: forall a. Fixed.HasResolution a => Fixed.Fixed a -> Put+fixedPut x = put (truncate (x * fromInteger (Fixed.resolution (undefined :: Maybe a))) :: Integer)++fixedGet :: forall a. Fixed.HasResolution a => Get (Fixed.Fixed a)+fixedGet = (\x -> fromInteger x / fromInteger (Fixed.resolution (undefined :: Maybe a))) `liftA` get++-- | Serialise using base >=4.7 and <4.7 methods agree+prop_fixed_ser :: Fixed.Fixed Fixed.E3 -> Bool+prop_fixed_ser x = runPut (put x) == runPut (fixedPut x)++-- | Serialised with base >=4.7, unserialised with base <4.7 method roundtrip+prop_fixed_constr_resolution :: Fixed.Fixed Fixed.E3 -> Bool+prop_fixed_constr_resolution x = runGet fixedGet (runPut (put x)) == x++-- | Serialised with base <4.7, unserialised with base >=4.7 method roundtrip+prop_fixed_resolution_constr :: Fixed.Fixed Fixed.E3 -> Bool+prop_fixed_resolution_constr x = runGet get (runPut (fixedPut x)) == x++#endif++------------------------------------------------------------------------+ type T a = a -> Property type B a = a -> Bool @@ -475,6 +505,7 @@             , ("Word",       p (test :: T Word                   ))             , ("Int",        p (test :: T Int                    ))             , ("Integer",    p (test :: T Integer                ))+            , ("Fixed",      p (test :: T (Fixed.Fixed Fixed.E3) )) #ifdef HAS_NATURAL             , ("Natural",         prop_test_Natural               ) #endif@@ -536,4 +567,11 @@             , ("L.ByteString invariant",   p (prop_invariant :: B L.ByteString                 ))             , ("[L.ByteString] invariant", p (prop_invariant :: B [L.ByteString]               ))             ]+#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         ]