beamable 0.1.0.2 → 0.1.1.0
raw patch · 4 files changed
+102/−33 lines, 4 filesdep +deepseqdep ~QuickCheck
Dependencies added: deepseq
Dependency ranges changed: QuickCheck
Files
- beamable.cabal +3/−2
- bench/Bench.hs +42/−7
- src/Data/Beamable.hs +1/−0
- src/Data/Beamable/Internal.hs +56/−24
beamable.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.1.0.2+version: 0.1.1.0 -- A short (one-line) description of the package. synopsis: Generic serializer/deserializer with compact representation@@ -80,7 +80,7 @@ build-depends: test-framework >= 0.4 && < 0.9, test-framework-quickcheck2 >= 0.2 && < 0.4,- QuickCheck >= 2.4 && < 2.6,+ QuickCheck >= 2.4 && < 2.7, -- Copied from regular dependencies... base >= 4.5 && < 4.8, blaze-builder >= 0.3,@@ -96,6 +96,7 @@ build-depends: criterion >= 0.6 && < 0.9,+ deepseq >= 1.3 && < 2, -- Copied from regular dependencies... base >= 4.5 && < 4.8, blaze-builder >= 0.3,
bench/Bench.hs view
@@ -1,31 +1,66 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RankNTypes #-} module Main where import Criterion import Criterion.Main+import Control.DeepSeq import Data.Beamable import Data.List (sort) import Data.Word+import GHC.Generics main :: IO () main = defaultMain- [ bgroup "roundTrip" rtGroup+ [ bgroup "roundTrip" $ allBenches roundTrip+ , bgroup "encode" $ allBenches encodeF ] where !_unused = sum testWords !_unused' = sum testInts -rtGroup =- [ bgroup "Int" $ map mkBenchRT testInts- , bgroup "Word" $ map mkBenchRT testWords+-- TODO: generalize this such that we can easily benchmark decoding+-- by itself. At present we can only benchmark decoding by looking at+-- the round-trip times.+allBenches :: (forall a. (Beamable a) => a -> a) -> [Benchmark]+allBenches f =+ [ bgroup "Int" $ map (mkBenchGroup f) testInts+ , bgroup "Word" $ map (mkBenchGroup f) testWords+ , bench "[Int]" $ nf f testInts+ , bench "[Int]1000" $ nf f longList+ , bench "(Word,Word)" $ nf f ((0,1000000) :: (Word,Word))+ , bench "(Int,Int,(Word,Int))" $ nf f ((0,23451345,(1000000,-4213)) :: (Int,Int,(Word,Int)))+ , bench "TestG1" $ nf f (TestG1 10 20 :: TestG [Int])+ , bench "TestG2" $ nf f (TestG2 [1..5] 20 :: TestG [Int]) ]+ where+ longList = replicate 1000 (1::Int)+ !_unused = sum longList -mkBenchRT x = bench (show x) $ whnf ((`asTypeOf` x) . decode . encode) x+mkBenchGroup f x = bench (show x) $ whnf f x +roundTrip x = decode (encode x) `asTypeOf` x++-- we use the slightly odd type because it fits into 'allBenches'+-- easily. encode produces a strict ByteString, so we can just force+-- it to WHNF to benchmark it.+encodeF :: Beamable a => a -> a+encodeF x = encode x `seq` x+ test10s :: [Word]-test10s = 0:[10^x | x <- [0..10]]-testWords = sort $ test10s ++ map (*5) test10s+test10s = [10^x | x <- [0,2..10]]+testWords = 0: (sort $ test10s ++ map (*5) test10s) testInts :: [Int] testInts = let xs = map fromIntegral testWords in reverse (map negate xs) ++ tail xs ++data TestG a = TestG1 Int Int | TestG2 a Word+ deriving (Eq, Show, Generic)++instance Beamable a => Beamable (TestG a)++instance NFData a => NFData (TestG a) where+ rnf (TestG1 a b) = a `seq` b `seq` ()+ rnf (TestG2 a b) = a `deepseq` b `seq` ()
src/Data/Beamable.hs view
@@ -23,6 +23,7 @@ , encodeLive , decodeLive , feed+ , Phantom(..) -- reexport , Builder
src/Data/Beamable/Internal.hs view
@@ -1,7 +1,8 @@-{-# OPTIONS -Wall #-}+{-# OPTIONS -Wall -fno-full-laziness #-} {-# LANGUAGE DeriveGeneric, TypeOperators, FlexibleContexts, DefaultSignatures #-} {-# LANGUAGE FlexibleInstances, ScopedTypeVariables, BangPatterns #-} {-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.Beamable.Internal@@ -11,6 +12,7 @@ , typeSignR , typeSign , TypeSign (..)+ , Phantom (..) ) where import Data.Beamable.Int@@ -51,7 +53,7 @@ beam v = gbeam (from v) (0,0) default unbeam :: (Generic a, GBeamable (Rep a)) => ByteString -> (a, ByteString)- unbeam v = first to $ gunbeam v (0,0)+ unbeam v = runResult (gunbeam v (0,0)) $ \a b -> (to a, b) default typeSignR :: (Generic a, GBeamable (Rep a)) => [String] -> a -> Word64 typeSignR prev v = gtypeSign prev (from v)@@ -79,16 +81,22 @@ unbeamEnum :: Enum a => ByteString -> (a, ByteString) unbeamEnum bs = let (i, bs') = unbeamInt bs in (toEnum (fromIntegral i), bs')-- }}} +-- writing unbeam via a CPS transform seems more efficient.+newtype Result a = Result+ { runResult :: forall r. (a -> B.ByteString -> r) -> r } +defResult :: Result a -> (a,B.ByteString)+defResult u = runResult u (,)+ class GBeamable f where gbeam :: f a -> (Int, Word) -> Builder- gunbeam :: B.ByteString -> (Int, Word) -> (f a, B.ByteString)+ gunbeam :: B.ByteString -> (Int, Word) -> Result (f a) gtypeSign :: [String] -> f a -> Word64 -- this instance used for datatypes with single constructor only instance (GBeamable a, Datatype d, Constructor c) => GBeamable (M1 D d (M1 C c a)) where gbeam (M1 (M1 x)) = gbeam x- gunbeam x = first M1 . gunbeam x+ gunbeam x t = Result $ \k -> runResult (gunbeam x t) $ k . M1 gtypeSign prev x | elem (datatypeName x) prev = signMur (datatypeName x, '_') gtypeSign prev x = signMur (datatypeName x, ':', gtypeSign (datatypeName x : prev) (unM1 x)) @@ -97,14 +105,15 @@ instance (GBeamable a, Constructor c) => GBeamable (M1 C c a) where gbeam (M1 x) t@(_, dirs) = mappend (beamWord $ fromIntegral dirs) (gbeam x t) {-# INLINE gbeam #-}- gunbeam bs = first M1 . gunbeam bs+ gunbeam x t = Result $ \k -> runResult (gunbeam x t) $ k . M1 gtypeSign prev x = signMur (conName x, '<', gtypeSign prev (unM1 x)) -- this instance is needed to avoid overlapping instances with (M1 D d (M1 C c a)) instance (Datatype d, GBeamable a, GBeamable b) => GBeamable (M1 D d (a :+: b) ) where gbeam (M1 x) = gbeam x- gunbeam bs (lev, _) = let (dirs, bs') = unbeamWord bs- in first M1 $ gunbeam bs' (lev, fromIntegral dirs)+ gunbeam bs (lev, _) = Result $ \k ->+ let !(!dirs, bs') = unbeamWord bs+ in runResult (gunbeam bs' (lev, fromIntegral dirs)) $ k . M1 gtypeSign prev x | elem (datatypeName x) prev = signMur (datatypeName x, '_') gtypeSign prev x = signMur ( gtypeSign (datatypeName x : prev) (unL . unM1 $ x), '|'@@ -112,33 +121,37 @@ -- choose correct constructor based on the first word uncoded from the BS (dirs variable) instance (GBeamable a, GBeamable b) => GBeamable (a :+: b) where- gbeam (L1 x) (lev, dirs) = gbeam x (lev + 1, dirs)- gbeam (R1 x) (lev, dirs) = gbeam x (lev + 1, dirs + (1 `shiftL` lev))- gunbeam bs (lev, dirs) = if testBit dirs lev- then first R1 $ gunbeam bs (lev + 1, dirs)- else first L1 $ gunbeam bs (lev + 1, dirs)+ gbeam (L1 x) (!lev, dirs) = gbeam x (lev + 1, dirs)+ gbeam (R1 x) (!lev, !dirs) = gbeam x (lev + 1, dirs + (1 `shiftL` lev))+ gunbeam bs (lev, dirs) = Result $ \k ->+ let !lev' = lev+1 in if testBit dirs lev+ then runResult (gunbeam bs (lev', dirs)) $ k . R1+ else runResult (gunbeam bs (lev', dirs)) $ k . L1 gtypeSign prev x = signMur (gtypeSign prev (unL x), '|', gtypeSign prev (unR x)) instance GBeamable a => GBeamable (M1 S c a) where gbeam (M1 x) = gbeam x- gunbeam bs = first M1 . gunbeam bs+ gunbeam x t = Result $ \k -> runResult (gunbeam x t) $ k . M1 gtypeSign prev ~(M1 x) = signMur ('[', gtypeSign prev x) instance GBeamable U1 where gbeam _ _ = mempty- gunbeam bs _ = (U1, bs)+ gunbeam bs _ = Result $ \k -> k U1 bs gtypeSign _ _x = signMur 'U' instance (GBeamable a, GBeamable b) => GBeamable (a :*: b) where gbeam (x :*: y) t = gbeam x t `mappend` gbeam y t- gunbeam bs t = let (ra, bs') = gunbeam bs t- (rb, bs'') = gunbeam bs' t- in (ra :*: rb, bs'')+ gunbeam bs t = Result $ \k ->+ let !(ra, bs') = defResult $ gunbeam bs t+ !(rb, bs'') = defResult $ gunbeam bs' t+ in k (ra :*: rb) bs'' gtypeSign prev ~(x :*: y) = signMur (gtypeSign prev x, '*', gtypeSign prev y) instance Beamable a => GBeamable (K1 i a) where gbeam (K1 x) _ = beam x- gunbeam bs _ = first K1 (unbeam bs)+ gunbeam bs _ = Result $ \k ->+ let !(a, bs') = unbeam bs+ in k (K1 a) bs' gtypeSign prev x = signMur ('K', typeSignR prev (unK1 x)) {-@@ -234,17 +247,20 @@ instance Beamable Bool instance Beamable a => Beamable [a] where- beam xs = beamWord (fromIntegral $ length xs) `mappend` mconcat (map beam xs)- unbeam bs = let (cnt, bs') = unbeamWord bs+ {-# INLINE beam #-}+ beam xs = mconcat (beamWord (fromIntegral $ length xs):(map beam xs) )+ {-# INLINE unbeam #-}+ unbeam bs = let !(!cnt, bs') = unbeamWord bs in unfoldCnt (fromIntegral cnt) unbeam bs' typeSignR prev _ = signMur ('L', typeSignR prev (undefined :: a)) +{-# INLINE unfoldCnt #-} unfoldCnt :: Int -> (b -> (a, b)) -> b -> ([a], b)-unfoldCnt cnt_i f = unfoldCnt' [] cnt_i+unfoldCnt cnt_i f = unfoldCnt' id cnt_i where- unfoldCnt' xs 0 b = (reverse xs, b)- unfoldCnt' xs cnt b = let (x, b') = f b- in unfoldCnt' (x:xs) (cnt - 1) b'+ unfoldCnt' xs 0 b = (xs [], b)+ unfoldCnt' xs cnt b = let !(!x, b') = f b+ in unfoldCnt' (xs.(x:)) (cnt - 1) b' instance Beamable ByteString where beam bs = beamWord (fromIntegral $ B.length bs) `mappend` fromByteString bs@@ -256,3 +272,19 @@ unbeam bs = let (chunks, bs') = unbeam bs in (BL.fromChunks chunks, bs') typeSignR _ _ = signMur "ByteString.Lazy"++-- | @Phantom a@ has just one possible value, like @()@, and is encoded+-- as a 0-byte sequence. However, its 'typeSign' depends on the 'typeSign'+-- of its parameter.+data Phantom a = Phantom+ deriving (Show, Eq, Ord, Enum)++instance Beamable a => Beamable (Phantom a) where+ beam = const mempty+ unbeam bs = (Phantom, bs)+ typeSignR f _ =+ let thisDT = "Data.Beamable.Phantom"+ f' = thisDT:f+ in if elem thisDT f+ then signMur (thisDT, '_')+ else signMur (thisDT, ':', typeSignR f' (undefined :: a))