bond-haskell 0.1.2.0 → 0.1.3.0

raw patch · 12 files changed

+269/−27 lines, 12 filesdep +criteriondep +deepseqdep ~basedep ~bond-haskell-compilerdep ~bytestringsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: criterion, deepseq

Dependency ranges changed: base, bond-haskell-compiler, bytestring, filepath, vector

API changes (from Hackage documentation)

Files

• Setup.hs +10/−5
• bench/Bench.hs +148/−0
• bench/schemas/bench.bond +5/−0
• bond-haskell.cabal +19/−2
• src/Data/Bond/Internal/BinaryUtils.hs +49/−12
• src/Data/Bond/Internal/Bonded.hs +6/−2
• src/Data/Bond/Internal/Bonded.hs-boot +2/−0
• src/Data/Bond/Internal/Imports.hs +2/−0
• src/Data/Bond/Struct.hs +9/−2
• src/Data/Bond/Types.hs +5/−4
• test/Spec.hs +10/−0
• test/simple_schemas/test.bond +4/−0

@@ -26,7 +26,7 @@ addSchemaModules pd0 lbi = do     let outPath = autogenModulesDir lbi     let schemaFlag = outPath </> "schemagen.flg"-    modules <- fmap lines $ readFile schemaFlag+    modules <- lines <$> readFile schemaFlag     let hbi = (Just $ emptyBuildInfo{ otherModules = map fromString modules }, [])     return $ updatePackageDescription hbi pd0 @@ -73,7 +73,7 @@                             return (flagTS < bondTS || flagTS < bondConstTS)                         else return True     when needSchemaRegen $ do-        extras <- getProgramOutput verbosity hbc ["-h", "-o", buildDir lbi, "--hsboot", "-n", "bond=Data.Bond.Schema", schemaPath </> "bond.bond", schemaPath </> "bond_const.bond"]+        extras <- getProgramOutput verbosity hbc ["-h", "-o", buildDir lbi, "--hsboot", "--nfdata", "-n", "bond=Data.Bond.Schema", schemaPath </> "bond.bond", schemaPath </> "bond_const.bond"]         createDirectoryIfMissing True (takeDirectory schemaFlag)         writeFile schemaFlag extras @@ -82,15 +82,20 @@      let dataPathFile = outPath </> "DataPath.hs"     dataPathFileExists <- doesFileExist dataPathFile-    when (not dataPathFileExists) $+    unless dataPathFileExists $         writeFile dataPathFile $             "module DataPath where\n\             \autogenPath :: String\n\             \autogenPath = " ++ show outPath      -- generate code for unittests-    when (fromFlagOrDefault False $ configTests conf) $ do+    when ((fromFlagOrDefault False $ configTests conf) || (fromFlagOrDefault False $ configBenchmarks conf)) $ do         regenSchemas verbosity hbc ("test" </> "compat" </> "schemas") outPath (outPath </> "compatgen.flg")++    when (fromFlagOrDefault False $ configBenchmarks conf) $ do+        regenSchemas verbosity hbc ("bench" </> "schemas") outPath (outPath </> "benchgen.flg")++    when (fromFlagOrDefault False $ configTests conf) $ do         regenSchemas verbosity hbc ("test" </> "simple_schemas") outPath (outPath </> "simplegen.flg")      -- run default hook@@ -109,6 +114,6 @@                             info verbosity $ "flag file " ++ flagFile ++ " missing"                             return True     when needSchemaRegen $ do-        extras <- getProgramOutput verbosity hbc $ ["-o", outDir] ++ schemaFiles+        extras <- getProgramOutput verbosity hbc $ ["--nfdata", "-o", outDir] ++ schemaFiles         createDirectoryIfMissing True (takeDirectory flagFile)         writeFile flagFile extras

@@ -0,0 +1,148 @@+{-# Language GADTs, ScopedTypeVariables #-}+module Main where++import Data.Bond+import Benchmark.Intvec+import Unittest.Compat.Compat++import Control.Applicative+import Criterion.Main+import Data.Proxy+import Data.Word+import System.FilePath+import Prelude -- workaround for Control.Applicative in ghc 7.10+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.Vector as V++compatDataPath :: String+compatDataPath = "test" </> "compat" </> "data"++data ProtoWrapper = forall t. BondProto t => ProtoWrapper String t FilePath+                  | forall t. BondTaggedProto t => TaggedProtoWrapper String t FilePath++fromTagged :: ProtoWrapper -> ProtoWrapper+fromTagged (TaggedProtoWrapper n t dat) = ProtoWrapper n t dat+fromTagged w = w++taggedProtocols :: [ProtoWrapper]+taggedProtocols =+    [ TaggedProtoWrapper "CompactBinary" CompactBinaryProto "compat.compact2.dat"+    , TaggedProtoWrapper "CompactBinary v1" CompactBinaryV1Proto "compat.compact.dat"+    , TaggedProtoWrapper "FastBinary" FastBinaryProto "compat.fast.dat"+    ]++simpleProtocols :: [ProtoWrapper]+simpleProtocols =+    [ ProtoWrapper "SimpleBinary" SimpleBinaryProto "compat.simple2.dat"+    , ProtoWrapper "SimpleBinary v1" SimpleBinaryV1Proto "compat.simple.dat"+    ]++main :: IO ()+main = defaultMain+    [ bgroup "bondRead" $ map benchRead (simpleProtocols ++ taggedProtocols)+    , bgroup "bondReadTagged" $ map benchReadTagged taggedProtocols+    , bgroup "bondReadWithSchema" $ map benchReadSchema (simpleProtocols ++ taggedProtocols)+    , bgroup "bondWrite" $ map benchWrite (simpleProtocols ++ taggedProtocols)+    , bgroup "bondWriteTagged" $ map benchWriteTagged taggedProtocols+    , bgroup "bondWriteWithSchema" $ map benchWriteSchema (simpleProtocols ++ taggedProtocols)+    , bgroup "VarInt"+        [ bgroup "Read"+            [ intRead "1" $ take 10000 $ cycle [0 .. 127]+            , intRead "2" $ take 10000 $ cycle [128 .. 16383]+            , intRead "3" $ take 10000 $ cycle [16384 .. 2097151]+            , intRead "4" $ take 10000 $ cycle [2097152 .. 268435455]+            , intRead "5" $ take 10000 $ cycle [268435456 .. 34359738367]+            , intRead "6" $ take 10000 $ cycle [34359738368 .. 4398046511103]+            , intRead "7" $ take 10000 $ cycle [4398046511104 .. 562949953421311]+            , intRead "8" $ take 10000 $ cycle [562949953421312 .. 72057594037927935]+            , intRead "9" $ take 10000 $ cycle [72057594037927936 .. 9223372036854775807]+            , intRead "10" $ take 10000 $ cycle [9223372036854775808 .. maxBound]+            ]+        , bgroup "Write"+            [ intWrite "1" $ take 10000 $ cycle [0 .. 127]+            , intWrite "2" $ take 10000 $ cycle [128 .. 16383]+            , intWrite "3" $ take 10000 $ cycle [16384 .. 2097151]+            , intWrite "4" $ take 10000 $ cycle [2097152 .. 268435455]+            , intWrite "5" $ take 10000 $ cycle [268435456 .. 34359738367]+            , intWrite "6" $ take 10000 $ cycle [34359738368 .. 4398046511103]+            , intWrite "7" $ take 10000 $ cycle [4398046511104 .. 562949953421311]+            , intWrite "8" $ take 10000 $ cycle [562949953421312 .. 72057594037927935]+            , intWrite "9" $ take 10000 $ cycle [72057594037927936 .. 9223372036854775807]+            , intWrite "10" $ take 10000 $ cycle [9223372036854775808 .. maxBound]+            ]+        ]+    ]++intRead :: String -> [Word64] -> Benchmark+intRead name xs = env+    makeStream+    (bench name . nf (bondRead CompactBinaryProto :: BL.ByteString -> Either String Intvec))+    where+    makeStream = do+        let v = defaultValue { ints = V.fromList xs }+        let Right stream = bondWrite CompactBinaryProto v+        return stream++intWrite :: String -> [Word64] -> Benchmark+intWrite name xs = env+    (return defaultValue { ints = V.fromList xs })+    (bench name . nf (bondWrite CompactBinaryProto))++benchRead :: ProtoWrapper -> Benchmark+benchRead (ProtoWrapper n t dat) =+    env (BL.fromStrict <$> BS.readFile (compatDataPath </> dat))+        (bench n . nf (bondRead t :: BL.ByteString -> Either String Compat))+benchRead p = benchRead (fromTagged p)++benchReadTagged :: ProtoWrapper -> Benchmark+benchReadTagged (TaggedProtoWrapper n t dat) =+    env (BL.fromStrict <$> BS.readFile (compatDataPath </> dat))+        (bench n . nf (bondReadTagged t))+benchReadTagged _ = error "wrong type"++benchReadSchema :: ProtoWrapper -> Benchmark+benchReadSchema (ProtoWrapper n t dat) =+    let schema = getSchema (Proxy :: Proxy Compat)+    in env (do+            stream <- BL.fromStrict <$> BS.readFile (compatDataPath </> dat)+            -- run decoding once to expand schema+            return (bondReadWithSchema t schema stream `seq` stream)+           )+           (bench n . nf (bondReadWithSchema t schema))+benchReadSchema p = benchReadSchema (fromTagged p)++benchWrite :: ProtoWrapper -> Benchmark+benchWrite (ProtoWrapper n t dat) =+    env getCompat+        (bench n . nf (bondWrite t))+    where+    getCompat :: IO Compat+    getCompat = do+        stream <- BL.readFile (compatDataPath </> dat)+        let Right val = bondRead t stream+        return val+benchWrite p = benchWrite (fromTagged p)++benchWriteTagged :: ProtoWrapper -> Benchmark+benchWriteTagged (TaggedProtoWrapper n t dat) =+    env getStruct+        (bench n . nf (bondWriteTagged t))+    where+    getStruct = do+        stream <- BL.readFile (compatDataPath </> dat)+        let Right val = bondReadTagged t stream+        return val+benchWriteTagged _ = error "wrong type"++benchWriteSchema :: ProtoWrapper -> Benchmark+benchWriteSchema (ProtoWrapper n t dat) =+    env getStruct+        (bench n . nf (bondWriteWithSchema t schema))+    where+    schema = getSchema (Proxy :: Proxy Compat)+    getStruct = do+        stream <- BL.readFile (compatDataPath </> dat)+        let Right val = bondReadWithSchema t schema stream+        return val+benchWriteSchema p = benchWriteSchema (fromTagged p)

@@ -0,0 +1,5 @@+namespace benchmark++struct intvec {+    10: vector<uint64> ints;+}

@@ -1,5 +1,5 @@ name:                bond-haskell-version:             0.1.2.0+version:             0.1.3.0 synopsis:            Runtime support for BOND serialization description:         Bond is a cross-platform framework for handling schematized                      data. It supports cross-language de/serialization and@@ -20,6 +20,7 @@ extra-source-files:  schema/*.bond                      test/compat/schemas/*.bond                      test/simple_schemas/*.bond+                     bench/schemas/*.bond data-files:          test/broken_schemas/*.json                      test/compat/data/compat.compact2.dat                      test/compat/data/compat.compact.dat@@ -61,12 +62,13 @@                        Data.Bond.Internal.Utils                        Data.Bond.Internal.Utils   build-depends:       base >= 4.7 && < 5-                     , bond-haskell-compiler >= 0.1.2.0 && < 0.1.3+                     , bond-haskell-compiler >= 0.1.3.0 && < 0.1.4                      , aeson                      , array                      , binary >= 0.7.0.0                      , bytestring >= 0.10                      , containers >= 0.4+                     , deepseq                      , extra >= 1.0                      , hashable >= 1.0                      , mtl >= 2.1@@ -86,6 +88,7 @@                      , bond-haskell                      , bytestring >= 0.10                      , containers >= 0.4+                     , deepseq                      , either                      , filepath >= 1.0                      , mtl >= 2.1@@ -94,6 +97,20 @@                      , tasty-hunit                      , tasty-quickcheck                      , unordered-containers >= 0.2+                     , vector+  ghc-options:         -threaded -W -Wall -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++benchmark bond-haskell-bench+  type:                exitcode-stdio-1.0+  hs-source-dirs:      bench+  main-is:             Bench.hs+  build-depends:       base+                     , bond-haskell+                     , bytestring+                     , criterion+                     , filepath+                     , vector   ghc-options:         -threaded -W -Wall -rtsopts -with-rtsopts=-N   default-language:    Haskell2010 

@@ -1,4 +1,4 @@-{-# LANGUAGE TypeFamilies, ScopedTypeVariables, FlexibleContexts #-}+{-# LANGUAGE TypeFamilies, ScopedTypeVariables, FlexibleContexts, BangPatterns, MultiWayIf #-} module Data.Bond.Internal.BinaryUtils where  import Data.Bond.Types@@ -7,7 +7,9 @@ import Control.Applicative import Control.Monad.Error import Data.Bits+import Data.Monoid import Prelude -- workaround for Control.Applicative in ghc 7.10+import qualified Data.Binary.Builder as BLD import qualified Data.Binary.Get as B import qualified Data.Binary.Put as B import qualified Data.ByteString as BS@@ -46,12 +48,27 @@ getLazyByteString = BondGet . B.getLazyByteString  getVarInt :: forall a t. (FiniteBits a, Num a, ReaderM t ~ B.Get) => BondGet t a-getVarInt = step 0+getVarInt = BondGet $ fastGet <|> slowGet 0     where-    step n | n > finiteBitSize (0 :: a) `div` 7 = fail "VarInt: sequence too long"-    step n = do-        b <- fromIntegral <$> getWord8-        rest <- if b `testBit` 7 then step (n + 1)  else return 0+    maxSize = 1 + finiteBitSize (0 :: a) `div` 7+    fastGet = do+        binstr <- B.lookAhead $ B.getByteString maxSize+        let loop i !v =+                let b = fromIntegral $ BS.index binstr i+                    v' = v .|. ((b `clearBit` 7) `shiftL` (i * 7))+                 in if | i >= maxSize -> Nothing+                       | b `testBit` 7 -> loop (i + 1) v'+                       | otherwise -> Just (i + 1, v')+        case loop 0 0 of+            Nothing -> fail "VarInt: sequence too long"+            Just (consumed, value) -> do+                B.skip consumed+                return value+    -- fallback in case there is not enough bytes in stream for max sequence+    slowGet i | i >= maxSize = fail "VarInt: sequence too long"+    slowGet i = do+        b <- fromIntegral <$> B.getWord8+        rest <- if b `testBit` 7 then slowGet (i + 1)  else return 0         return $ (b `clearBit` 7) .|. (rest `shiftL` 7)  tryPut :: ErrorT String B.PutM () -> Either String BL.ByteString@@ -78,9 +95,29 @@ putLazyByteString = BondPut . lift . B.putLazyByteString  putVarInt :: (FiniteBits a, Integral a, WriterM t ~ ErrorT String B.PutM) => a -> BondPut t-putVarInt i | i < 0 = error "VarInt with negative value"-putVarInt i | i < 128 = putWord8 $ fromIntegral i-putVarInt i = let iLow = fromIntegral $ i .&. 0x7F-               in do-                    putWord8 $ iLow `setBit` 7-                    putVarInt (i `shiftR` 7)+putVarInt n | n < 0 = error "VarInt with negative value"+putVarInt n = BondPut $ lift $ B.putBuilder $ makeBuilder n+    where+    makeBuilder i | i < 128 = BLD.singleton $ fromIntegral i+    makeBuilder i | i < 16384 = let (b1, b0) = fromIntegral i `divMod` 128+                                 in BLD.putWord16be $ 0x8000 .|. (b0 `shiftL` 8) .|. b1+    makeBuilder i | i < 2097152 = let (temp, b0) = i `divMod` 128+                                      (b2, b1) = temp `divMod` 128+                                   in BLD.putWord16be (0x8080 .|. fromIntegral ((b0 `shiftL` 8) .|. b1)) <>+                                        BLD.singleton (fromIntegral b2)+    makeBuilder i | i < 268435456 = let (temp1, b0) = i `divMod` 128+                                        (temp2, b1) = temp1 `divMod` 128+                                        (b3, b2) = temp2 `divMod` 128+                                     in BLD.putWord32be $ 0x80808000 .|.+                                            fromIntegral ((b0 `shiftL` 24) .|. (b1 `shiftL` 16) .|. (b2 `shiftL` 8) .|. b3)+    makeBuilder i | i < 9223372036854775808 = let (temp1, b0) = i `divMod` 128+                                                  (temp2, b1) = temp1 `divMod` 128+                                                  (temp3, b2) = temp2 `divMod` 128+                                                  (rest, b3) = temp3 `divMod` 128+                                               in BLD.putWord32be (0x80808080 .|.+                                                        fromIntegral ((b0 `shiftL` 24) .|. (b1 `shiftL` 16) .|. (b2 `shiftL` 8) .|. b3)) <>+                                                    makeBuilder rest+    makeBuilder i = let (temp1, b0) = i `divMod` 128+                        (temp2, b1) = temp1 `divMod` 128+                     in BLD.putWord16be (0x8080 .|. fromIntegral ((b0 `shiftL` 8) .|. b1)) <>+                            makeBuilder temp2

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} module Data.Bond.Internal.Bonded where  import Data.Bond.Marshal@@ -6,6 +6,8 @@ import Data.Bond.Internal.MarshalUtils import {-# SOURCE #-} Data.Bond.Internal.Protocol +import GHC.Generics (Generic)+import Control.DeepSeq import Control.Exception import Data.Typeable import qualified Data.ByteString.Lazy as Lazy@@ -21,7 +23,7 @@ data Bonded a         = BondedStream Lazy.ByteString -- ^ Marshalled stream         | BondedObject a               -- ^ Deserialized value-    deriving Typeable+    deriving (Generic, Typeable)  instance Show a => Show (Bonded a) where     show BondedStream{} = "BondedStream"@@ -35,6 +37,8 @@                             Left msg -> throw (BondedException msg)                             Right v -> v               in aobj == bobj++instance NFData a => NFData (Bonded a)  -- | Extract value from 'Bonded' using compile-type schema getValue :: BondStruct a => Bonded a -> Either String a

@@ -1,5 +1,6 @@ module Data.Bond.Internal.Bonded where +import Control.DeepSeq import Data.Typeable import qualified Data.ByteString.Lazy as BL @@ -7,3 +8,4 @@  instance Typeable Bonded instance Show a => Show (Bonded a)+instance NFData a => NFData (Bonded a)

@@ -5,6 +5,7 @@     , BondType(..)     , Hashable     , IsString+    , NFData     , Protocol(..)     , ap     , asProxyTypeOf@@ -19,6 +20,7 @@ import Data.Bond.Internal.Protocol import Data.Bond.Internal.Utils as X +import Control.DeepSeq (NFData) import Control.Monad (ap) import Data.Hashable (Hashable) import Data.Proxy (asProxyTypeOf)

@@ -1,8 +1,11 @@+{-# Language DeriveGeneric #-} module Data.Bond.Struct where  import {-# SOURCE #-} Data.Bond.Schema.BondDataType import Data.Bond.Types +import Control.DeepSeq+import GHC.Generics (Generic) import qualified Data.Map.Strict as M  -- |Representation of bond serializable type used in runtime-schema operations.@@ -25,8 +28,10 @@     | SET BondDataType [Value]     | MAP BondDataType BondDataType [(Value, Value)]     | BONDED (Bonded Struct)-    deriving Show+    deriving (Show, Generic) +instance NFData Value+ instance Eq Value where     (BOOL a) == (BOOL b) = a == b     (INT8 a) == (INT8 b) = a == b@@ -51,7 +56,9 @@  -- |Representation of bond structure used in runtime-schema operations. data Struct = Struct { base :: Maybe Struct, fields :: M.Map Ordinal Value }-    deriving (Show, Eq)+    deriving (Show, Eq, Generic)++instance NFData Struct  valueName :: Value -> String valueName (BOOL _) = "bool"

@@ -28,6 +28,7 @@  import {-# SOURCE #-} Data.Bond.Internal.Bonded +import Control.DeepSeq import Data.Data import Data.Int import Data.String@@ -43,15 +44,15 @@  -- |Bond "string" type newtype Utf8 = Utf8 BS.ByteString-    deriving (Eq, Ord, Hashable, Typeable)+    deriving (Eq, Ord, Hashable, Typeable, NFData)  -- |Bond "wstring" type newtype Utf16 = Utf16 BS.ByteString-    deriving (Eq, Ord, Hashable, Typeable)+    deriving (Eq, Ord, Hashable, Typeable, NFData)  -- |Bond "blob" type newtype Blob = Blob BS.ByteString-    deriving (Show, Eq, Ord, Hashable, Typeable)+    deriving (Show, Eq, Ord, Hashable, Typeable, NFData)  -- |Bond string\/wstring transformations from/to 'String' and 'T.Text'. class IsString a => EncodedString a where@@ -83,4 +84,4 @@  -- |Bond structure field ordinal. newtype Ordinal = Ordinal Word16-    deriving (Eq, Ord, Show, Hashable)+    deriving (Eq, Ord, Show, Hashable, NFData)

@@ -8,6 +8,7 @@ import Unittest.Simple.Inner as Inner import Unittest.Simple.Outer as Outer import Unittest.Simple.Reqopt as ReqOpt+import Unittest.Simple.Intvec  import Control.Monad import Control.Monad.Trans@@ -23,6 +24,7 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.Map as M+import qualified Data.Vector as V  import DataPath @@ -152,6 +154,7 @@         , testProperty "Int64" zigzagInt64         , testProperty "Word64" zigzagWord64         ]+    , testProperty "VarInt" varIntTest     ]     where     testTagged (TaggedProtoWrapper name proto dat) = testGroup name@@ -470,6 +473,13 @@  zigzagWord64 :: Word64 -> Bool zigzagWord64 x = x == toZigZag (fromZigZag x :: Int64)++varIntTest :: [Word64] -> Bool+varIntTest xs = let srcStruct = defaultValue { ints = V.fromList xs }+                    Right stream = bondWrite CompactBinaryProto srcStruct+                    Right dstStruct = bondRead CompactBinaryProto stream+                    ys = V.toList $ ints dstStruct+                 in xs == ys  assertEither :: EitherT String IO () -> Assertion assertEither = eitherT assertFailure (const $ return ())

@@ -24,3 +24,7 @@     20: required_optional string m_reqopt_string;     30: required int16 m_req_nothing_int16 = nothing; }++struct intvec {+    10: vector<uint64> ints;+}