From b07c916652f037de78efd06108e969a479e40750 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C3=96mer=20Sinan=20A=C4=9Facan?= Date: Sun, 16 Nov 2014 04:43:18 +0200 Subject: [PATCH] init --- .gitignore | 3 + LICENSE | 0 Setup.hs | 2 + serialization-bench.cabal | 30 +++++++ src/Main.hs | 162 ++++++++++++++++++++++++++++++++++++++ 5 files changed, 197 insertions(+) create mode 100644 .gitignore create mode 100644 LICENSE create mode 100644 Setup.hs create mode 100644 serialization-bench.cabal create mode 100644 src/Main.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..3f09fac --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +dist +.cabal-sandbox/ +cabal.sandbox.config diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..e69de29 diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/serialization-bench.cabal b/serialization-bench.cabal new file mode 100644 index 0000000..0faf53d --- /dev/null +++ b/serialization-bench.cabal @@ -0,0 +1,30 @@ +name: serialization-bench +version: 0.1.0.0 +-- synopsis: +-- description: +-- license: +license-file: LICENSE +author: Ömer Sinan Ağacan +maintainer: omeragacan@gmail.com +-- copyright: +-- category: +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +executable serialization-bench + main-is: Main.hs + -- other-modules: + -- other-extensions: + build-depends: base >=4.7 && <4.8, + binary >=0.7.1 && <0.7.3, + bytestring, + cereal >=0.4.1 && <0.4.2, + criterion, + deepseq, + packman, + QuickCheck, + random + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..b76bc26 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, + MultiParamTypeClasses #-} + +module Main where + +import Control.Applicative +import Control.DeepSeq +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Typeable +import Data.Word +import System.IO +import System.Random + +-- Serialization libs +import qualified Data.Binary as B +import qualified Data.Serialize as C +import qualified GHC.Packing as P + +-- Testing and random data generation +import Test.QuickCheck +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen + +-- Benchmarks +import Criterion.Main +import Criterion.Types + +data BinTree a = Tree (BinTree a) (BinTree a) | Leaf a + deriving (Show, Eq, Typeable) + +instance NFData a => NFData (BinTree a) where + rnf (Leaf a) = rnf a `seq` () + rnf (Tree left right) = rnf left `seq` rnf right `seq` () + +instance Arbitrary a => Arbitrary (BinTree a) where + arbitrary = oneof [Leaf <$> arbitrary, Tree <$> arbitrary <*> arbitrary] + + shrink Leaf{} = [] + shrink (Tree left right) = [left, right] ++ shrink left ++ shrink right + +instance B.Binary a => B.Binary (BinTree a) where + put (Leaf a) = do + B.put (0 :: Word8) + B.put a + + put (Tree left right) = do + B.put (1 :: Word8) + B.put left + B.put right + + get = do + t <- B.get :: B.Get Word8 + case t of + 0 -> Leaf <$> B.get + 1 -> Tree <$> B.get <*> B.get + +instance C.Serialize a => C.Serialize (BinTree a) where + put (Leaf a) = do + C.put (0 :: Word8) + C.put a + + put (Tree left right) = do + C.put (1 :: Word8) + C.put left + C.put right + + get = do + t <- C.get :: C.Get Word8 + case t of + 0 -> Leaf <$> C.get + 1 -> Tree <$> C.get <*> C.get + +data Binary = Binary +data Cereal = Cereal +data Packman = Packman + +class Serialize lib a where + serialize :: lib -> a -> IO BS.ByteString + deserialize :: lib -> BS.ByteString -> IO a + +instance (B.Binary a, NFData a) => Serialize Binary a where + serialize _ = return . force . LBS.toStrict . B.encode + deserialize _ = return . force . B.decode . LBS.fromStrict + +instance (C.Serialize a, NFData a) => Serialize Cereal a where + serialize _ = return . force . C.encode + deserialize _ = either error (return . force) . C.decode + +instance (NFData a, Typeable a) => Serialize Packman a where + serialize _ = fmap (force . LBS.toStrict . B.encode) . P.trySerialize + deserialize _ = either error (fmap force . P.deserialize) . B.decode . LBS.fromStrict + +prop :: Serialize lib (BinTree Int) => lib -> Property +prop lib = forAll arbitrary (ioProperty . test) + where + test :: BinTree Int -> IO Bool + test t = do + s <- serialize lib t + d <- deserialize lib s + return $ d == t + +runQC :: Serialize lib (BinTree Int) => lib -> IO () +runQC = quickCheckWith stdArgs{maxSuccess=1000} . prop + +bug :: IO () +bug = do + let ex = Tree (Leaf 10) (Leaf 20) :: BinTree Int + -- this works + -- P.encodeToFile "test" ex + -- tree <- P.decodeFromFile "test" :: IO (BinTree Int) + -- print tree + + -- this works + -- s <- P.trySerialize ex + -- d <- P.deserialize s + -- print d + + -- this doesn't work + s <- fmap B.encode . P.trySerialize $ (1 :: Int) + print (LBS.unpack s) + d <- (either error P.deserialize . B.decode $ s) :: IO Int + print d + + -- this doesn't work + -- b <- serialize Packman ex + -- b' <- deserialize Packman b :: IO (BinTree Int) + -- print b' + +generateBalancedTree :: Word32 -> IO (BinTree Int) +generateBalancedTree 0 = Leaf <$> randomIO +generateBalancedTree n = Tree <$> generateBalancedTree (n-1) <*> generateBalancedTree (n-1) + +runBench :: IO () +runBench = do + putStr "Generating tree... " + hFlush stdout + tree <- force <$> generateBalancedTree 22 + putStrLn "Done." + defaultMainWith defaultConfig{forceGC=True, verbosity=Verbose} + [ bgroup "binary" + [ bench "serialize" $ nfIO $ serialize Binary tree + , bench "serialize + deserialize" $ + nfIO (serialize Binary tree >>= deserialize Binary :: IO (BinTree Int)) + ] + , bgroup "cereal" + [ bench "serialize" $ nfIO $ serialize Cereal tree + , bench "serialize + deserialize" $ nfIO + (serialize Cereal tree >>= deserialize Cereal :: IO (BinTree Int)) + ] + , bgroup "packman" [] + ] + +main :: IO () +main = do + -- runQC Binary + -- runQC Cereal + -- runQC Packman + + -- bug + + runBench