packages feed

bond-haskell (empty) → 0.1.1.0

raw patch · 37 files changed

+4184/−0 lines, 37 filesdep +aesondep +arraydep +basebuild-type:Customsetup-changed

Dependencies added: aeson, array, base, binary, bond-haskell, bond-haskell-compiler, bytestring, containers, either, extra, filepath, hashable, mtl, scientific, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, text, unordered-containers, vector

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Andrey Sverdlichenko (c) 2015-2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of author nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,113 @@+import Distribution.ModuleName (fromString)+import Distribution.PackageDescription+import Distribution.Simple+import Distribution.Simple.BuildPaths+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Program+import Distribution.Simple.Setup+import Distribution.Simple.Utils+import Distribution.Verbosity+import Control.Applicative+import Control.Monad+import Data.List+import System.Directory+import System.FilePath++main = defaultMainWithHooks $ simpleUserHooks+    { hookedPrograms = [simpleProgram "hbc", simpleProgram "gbc"]+    , postConf = runHbc+    , buildHook = addSchemaModulesBuild+    , copyHook = addSchemaModulesCopy+    , regHook = addSchemaModulesReg+    , instHook = addSchemaModulesInstall+}++addSchemaModules :: PackageDescription -> LocalBuildInfo -> IO PackageDescription+addSchemaModules pd0 lbi = do+    let outPath = autogenModulesDir lbi+    let schemaFlag = outPath </> "schemagen.flg"+    modules <- fmap lines $ readFile schemaFlag+    let hbi = (Just $ emptyBuildInfo{ otherModules = map fromString modules }, [])+    return $ updatePackageDescription hbi pd0++addSchemaModulesBuild :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()+addSchemaModulesBuild pd0 lbi hooks flags = do+    pd <- addSchemaModules pd0 lbi+    -- run default hook+    buildHook simpleUserHooks pd lbi hooks flags++addSchemaModulesReg :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO ()+addSchemaModulesReg pd0 lbi hooks flags = do+    pd <- addSchemaModules pd0 lbi+    -- run default hook+    regHook simpleUserHooks pd lbi hooks flags++addSchemaModulesCopy :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO ()+addSchemaModulesCopy pd0 lbi hooks flags = do+    pd <- addSchemaModules pd0 lbi+    -- run default hook+    copyHook simpleUserHooks pd lbi hooks flags++addSchemaModulesInstall :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO ()+addSchemaModulesInstall pd0 lbi hooks flags = do+    pd <- addSchemaModules pd0 lbi+    -- run default hook+    instHook simpleUserHooks pd lbi hooks flags++runHbc :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()+runHbc args conf pd lbi = do+    let verbosity = fromFlagOrDefault normal $ configVerbosity conf+    (hbc, _) <- requireProgram verbosity (simpleProgram "hbc") (configPrograms conf)+    (gbc, _) <- requireProgram verbosity (simpleProgram "gbc") (configPrograms conf)+    let schemaPath = "schema"+    let outPath = autogenModulesDir lbi++    -- generate code for SchemaDef & Co+    let schemaFlag = outPath </> "schemagen.flg"+    schemaGenFlagExists <- doesFileExist schemaFlag+    needSchemaRegen <- if schemaGenFlagExists+                        then do+                            bondTS <- getModificationTime $ schemaPath </> "bond.bond"+                            bondConstTS <- getModificationTime $ schemaPath </> "bond_const.bond"+                            flagTS <- getModificationTime schemaFlag+                            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"]+        createDirectoryIfMissing False outPath+        writeFile schemaFlag extras++    -- generate json schemas for unittests+    runProgram verbosity gbc ["schema", "-o", outPath, "-r", schemaPath </> "bond.bond"]++    let dataPathFile = outPath </> "DataPath.hs"+    dataPathFileExists <- doesFileExist dataPathFile+    when (not dataPathFileExists) $+        writeFile dataPathFile $+            "module DataPath where\n\+            \autogenPath :: String\n\+            \autogenPath = " ++ show outPath++    -- generate code for unittests+    when (fromFlagOrDefault False $ configTests conf) $ do+        regenSchemas verbosity hbc ("test" </> "compat" </> "schemas") outPath (outPath </> "compatgen.flg")+        regenSchemas verbosity hbc ("test" </> "simple_schemas") outPath (outPath </> "simplegen.flg")++    -- run default hook+    postConf simpleUserHooks args conf pd lbi++regenSchemas :: Verbosity -> ConfiguredProgram -> FilePath -> FilePath -> FilePath -> IO ()+regenSchemas verbosity hbc schemasDir outDir flagFile = do+    schemaFiles <- map (schemasDir </>) . filter (".bond" `isSuffixOf`) <$> getDirectoryContents schemasDir+    flagFileExists <- doesFileExist flagFile+    needSchemaRegen <- if flagFileExists+                        then do+                            filesTS <- mapM getModificationTime schemaFiles+                            flagTS <- getModificationTime flagFile+                            return $ any (flagTS <) filesTS+                        else do+                            info verbosity $ "flag file " ++ flagFile ++ " missing"+                            return True+    when needSchemaRegen $ do+        extras <- getProgramOutput verbosity hbc $ ["-o", outDir] ++ schemaFiles+        writeFile flagFile extras
+ bond-haskell.cabal view
@@ -0,0 +1,89 @@+name:                bond-haskell+version:             0.1.1.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+                     powerful generic mechanisms for efficiently manipulating+                     data.+                     .+                     This package contains a runtime library used by generated+                     Haskell code.+homepage:            http://github.com/rblaze/bond-haskell-runtime#readme+license:             BSD3+license-file:        LICENSE+author:              Andrey Sverdlichenko <blaze@ruddy.ru>+maintainer:          Andrey Sverdlichenko <blaze@ruddy.ru>+copyright:           (C) 2015 Andrey Sverdlichenko+category:            Data,Parsing+build-type:          Custom+cabal-version:       >=1.18++library+  hs-source-dirs:      src+  exposed-modules:     Data.Bond+                       Data.Bond.Marshal+                       Data.Bond.Proto+                       Data.Bond.Struct+                       Data.Bond.TypedSchema+                       Data.Bond.Types+                       Data.Bond.Internal.Imports+                       Data.Bond.Internal.ZigZag+  other-modules:       Data.Bond.Internal.BinaryUtils+                       Data.Bond.Internal.Bonded+                       Data.Bond.Internal.BondedUtils+                       Data.Bond.Internal.Cast+                       Data.Bond.Internal.CompactBinaryProto+                       Data.Bond.Internal.Default+                       Data.Bond.Internal.FastBinaryProto+                       Data.Bond.Internal.JsonProto+                       Data.Bond.Internal.MarshalUtils+                       Data.Bond.Internal.OrdinalSet+                       Data.Bond.Internal.Protocol+                       Data.Bond.Internal.ProtoUtils+                       Data.Bond.Internal.SchemaOps+                       Data.Bond.Internal.SchemaUtils+                       Data.Bond.Internal.SimpleBinaryProto+                       Data.Bond.Internal.TaggedProtocol+                       Data.Bond.Internal.Utils+                       Data.Bond.Internal.Utils+  build-depends:       base >= 4.7 && < 5+                     , bond-haskell-compiler >= 0.1.1.0 && < 0.1.2+                     , aeson+                     , array+                     , binary >= 0.7.0.0+                     , bytestring >= 0.10+                     , containers >= 0.4+                     , extra >= 1.0+                     , hashable >= 1.0+                     , mtl >= 2.1+                     , scientific+                     , text >= 0.11+                     , unordered-containers >= 0.2+                     , vector >= 0.10+  default-language:    Haskell2010+  ghc-options:         -W -Wall -fno-warn-warnings-deprecations++test-suite bond-haskell-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , aeson+                     , bond-haskell+                     , bytestring >= 0.10+                     , containers >= 0.4+                     , either+                     , filepath >= 1.0+                     , mtl >= 2.1+                     , tasty+                     , tasty-golden+                     , tasty-hunit+                     , tasty-quickcheck+                     , unordered-containers >= 0.2+  ghc-options:         -threaded -W -Wall -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/rblaze/bond-haskell.git+  subdir:   runtime
+ src/Data/Bond.hs view
@@ -0,0 +1,111 @@+{-|+Bond is an extensible framework for working with schematized data. It is+suitable for scenarios ranging from service communications to Big Data storage+and processing.++Bond defines a rich type system and schema versioning rules which allow+forward and backward compatibility.++Core bond library is published on GitHub at https://github.com/Microsoft/bond/.+-}+module Data.Bond+    ( +    -- * Example+    -- $examples+    -- * Protocol types+      BondProto(..)+    , BondTaggedProto(..)+    -- * Supported protocols+    , CompactBinaryV1Proto(..)+    , CompactBinaryProto(..)+    , FastBinaryProto(..)+    , SimpleBinaryV1Proto(..)+    , SimpleBinaryProto(..)+    , JsonProto(..)+    -- * bonded\<T>+    , Bonded(..)+    , getValue+    , putValue+    , castValue+    , marshalValue+    , BondedException(..)+    -- * Runtime-schema operations+    -- |Some generic applications may need to work with Bond schemas unknown+    -- at compile-time. In order to address such scenarios Bond defines a+    -- type 'Data.Bond.Schema.SchemaDef' to represent schemas in stoorage+    -- and transfer.+    --+    -- Haskell library uses 'StructSchema' internally for performance+    -- reasons and provides conversion functions.+    , BondStruct(getSchema)+    , assembleSchema+    , checkStructSchema+    , defaultStruct+    , parseSchema+    , Struct(..)+    , Value(..)+    -- * Marshalling+    -- |Since Bond supports multiple serialization protocols, application+    -- endpoints either have to agree on a particular protocol, or include+    -- protocol metadata in the payload. Marshaling APIs provide the+    -- standard way to do the latter, by automatically adding a payload+    -- header with the protocol identifier and version.+    --+    -- See 'bondMarshal', 'bondMarshalWithSchema' and 'bondMarshalTagged' for serialization.+    , bondUnmarshal+    , bondUnmarshalWithSchema+    , bondUnmarshalTagged+    -- * Misc+    , EncodedString(..)+    , Ordinal(..)+    , defaultValue+    -- | Reexported from generated code+    , BondDataType(..)+    , bT_BOOL, bT_UINT8, bT_UINT16, bT_UINT32, bT_UINT64+    , bT_FLOAT, bT_DOUBLE, bT_STRING, bT_STRUCT, bT_LIST+    , bT_SET, bT_MAP, bT_INT8, bT_INT16, bT_INT32, bT_INT64, bT_WSTRING+    , SchemaDef+    ) where++import Data.Bond.Marshal+import Data.Bond.Proto+import Data.Bond.Struct+import Data.Bond.Types+import Data.Bond.Internal.Bonded+import Data.Bond.Internal.CompactBinaryProto+import Data.Bond.Internal.Default+import Data.Bond.Internal.FastBinaryProto+import Data.Bond.Internal.JsonProto+import Data.Bond.Internal.Protocol+import Data.Bond.Internal.SchemaOps+import Data.Bond.Internal.SimpleBinaryProto+import Data.Bond.Schema.BondDataType+import Data.Bond.Schema.SchemaDef++-- $examples+-- Let's use following @schema.bond@ IDL file:+--+-- @+-- namespace my.test+--+-- struct my_struct {+--   10: int32 m_int;+--   20: string m_str = "some string";+-- }+-- @+--+-- Code generation requires @hbc@ program from @bond-haskell-compiler@ package:+--+-- > hbc schema.bond+--+-- This creates file @My.Test.My_struct.hs@. Note that case conversions are +-- performed to create syntactically correct Haskell code.+--+-- @+-- -- create structure and set m_int to 5:+-- let struct = defaultValue { m_int = 5 }+-- -- serialize @struct@ with FastBinary protocol+-- let Right binstream = bondWrite FastBinaryProto struct+-- -- parse @binstream@ using runtime schema+-- let Right rtstruct = bondReadWithSchema FastBinaryProto (getSchema (Proxy :: Proxy My_struct)) binstream+-- @
+ src/Data/Bond/Internal/BinaryUtils.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE TypeFamilies, ScopedTypeVariables, FlexibleContexts #-}+module Data.Bond.Internal.BinaryUtils where++import Data.Bond.Types+import Data.Bond.Internal.Protocol++import Control.Applicative+import Control.Monad.Error+import Data.Bits+import Prelude -- workaround for Control.Applicative in ghc 7.10+import qualified Data.Binary.Get as B+import qualified Data.Binary.Put as B+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL++-- XXX isolate is available in binary >= 0.7.2.0 (lts-3 and higher) only+isolate :: ReaderM t ~ B.Get => Int -> BondGet t a -> BondGet t a+isolate _ = Prelude.id+--isolate n (BondGet g) = BondGet $ B.isolate n g++lookAhead :: ReaderM t ~ B.Get => BondGet t a -> BondGet t a+lookAhead (BondGet g) = BondGet $ B.lookAhead g++skip :: ReaderM t ~ B.Get => Int -> BondGet t ()+skip = BondGet . B.skip++bytesRead :: ReaderM t ~ B.Get => BondGet t Int64+bytesRead = BondGet B.bytesRead++getWord8 :: ReaderM t ~ B.Get => BondGet t Word8+getWord8 = BondGet B.getWord8++getWord16le :: ReaderM t ~ B.Get => BondGet t Word16+getWord16le = BondGet B.getWord16le++getWord32le :: ReaderM t ~ B.Get => BondGet t Word32+getWord32le = BondGet B.getWord32le++getWord64le :: ReaderM t ~ B.Get => BondGet t Word64+getWord64le = BondGet B.getWord64le++getByteString :: ReaderM t ~ B.Get => Int -> BondGet t BS.ByteString+getByteString = BondGet . B.getByteString++getLazyByteString :: ReaderM t ~ B.Get => Int64 -> BondGet t BL.ByteString+getLazyByteString = BondGet . B.getLazyByteString++getVarInt :: forall a t. (FiniteBits a, Num a, ReaderM t ~ B.Get) => BondGet t a+getVarInt = step 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+        return $ (b `clearBit` 7) .|. (rest `shiftL` 7)++tryPut :: ErrorT String B.PutM () -> Either String BL.ByteString+tryPut g = case B.runPutM (runErrorT g) of+            (Left msg, _) -> Left msg+            (Right (), bs) -> Right bs++putWord8 :: WriterM t ~ ErrorT String B.PutM => Word8 -> BondPut t+putWord8 = BondPut . lift . B.putWord8++putWord16le :: WriterM t ~ ErrorT String B.PutM => Word16 -> BondPut t+putWord16le = BondPut . lift . B.putWord16le++putWord32le :: WriterM t ~ ErrorT String B.PutM => Word32 -> BondPut t+putWord32le = BondPut . lift . B.putWord32le++putWord64le :: WriterM t ~ ErrorT String B.PutM => Word64 -> BondPut t+putWord64le = BondPut . lift . B.putWord64le++putByteString :: WriterM t ~ ErrorT String B.PutM => BS.ByteString -> BondPut t+putByteString = BondPut . lift . B.putByteString++putLazyByteString :: WriterM t ~ ErrorT String B.PutM => BL.ByteString -> BondPut t+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)
+ src/Data/Bond/Internal/Bonded.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Data.Bond.Internal.Bonded where++import Data.Bond.Marshal+import Data.Bond.Proto+import Data.Bond.Internal.MarshalUtils+import {-# SOURCE #-} Data.Bond.Internal.Protocol++import Control.Exception+import Data.Typeable+import qualified Data.ByteString.Lazy as Lazy++-- | BondedException is thrown when attempt to deserialize bonded field for comparison fails.+-- To handle such cases in the pure code explicitly decode all bonded fields before comparing structures.+data BondedException = BondedException String+    deriving (Show, Typeable)++instance Exception BondedException++-- | bonded\<T> value+data Bonded a+        = BondedStream Lazy.ByteString -- ^ Marshalled stream+        | BondedObject a               -- ^ Deserialized value+    deriving Typeable++instance Show a => Show (Bonded a) where+    show BondedStream{} = "BondedStream"+    show (BondedObject v) = show v++instance (BondStruct a, Eq a) => Eq (Bonded a) where+    a == b = let aobj = case getValue a of+                            Left msg -> throw (BondedException msg)+                            Right v -> v+                 bobj = case getValue b of+                            Left msg -> throw (BondedException msg)+                            Right v -> v+              in aobj == bobj++-- | Extract value from 'Bonded' using compile-type schema+getValue :: BondStruct a => Bonded a -> Either String a+getValue (BondedObject a) = Right a+getValue (BondedStream s) = bondUnmarshal s++-- | Extract value from 'Bonded' using compile-type schema for other type.+-- This may be useful for casting values to child structs.+-- User is responsible for schema compatibility.+castValue :: BondStruct b => Bonded a -> Either String b+castValue (BondedObject _) = error "can't cast deserialized struct"+castValue (BondedStream s) = bondUnmarshal s++-- | Put struct to the bonded\<T> field.+putValue :: a -> Bonded a+putValue = BondedObject++-- | Marshal struct to the bonded\<T> field.+-- There is no checks for schema compatibility, caveat emptor.+marshalValue :: (BondProto t, BondStruct a) => t -> a -> Either String (Bonded b)+marshalValue t = fmap BondedStream . bondMarshal' t
+ src/Data/Bond/Internal/Bonded.hs-boot view
@@ -0,0 +1,9 @@+module Data.Bond.Internal.Bonded where++import Data.Typeable+import qualified Data.ByteString.Lazy as BL++data Bonded a = BondedStream BL.ByteString | BondedObject a++instance Typeable Bonded+instance Show a => Show (Bonded a)
+ src/Data/Bond/Internal/BondedUtils.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Data.Bond.Internal.BondedUtils where++import {-# SOURCE #-} Data.Bond.Internal.CompactBinaryProto+import {-# SOURCE #-} Data.Bond.Internal.FastBinaryProto+import Data.Bond.Marshal+import Data.Bond.Proto+import Data.Bond.Struct+import Data.Bond.TypedSchema+import Data.Bond.Internal.Bonded+import Data.Bond.Internal.Protocol++import Control.Applicative+import Data.Proxy+import Prelude          -- ghc 7.10 workaround for Control.Applicative+import qualified Data.ByteString.Lazy as BL++bondRecode :: forall t a. (BondProto t, BondStruct a) => t -> Bonded a -> Either String (Bonded a)+bondRecode t (BondedObject a) = BondedStream <$> bondMarshal t a+bondRecode t (BondedStream stream)+    | sig == protoSig t = Right $ BondedStream stream+    | isTaggedSource = do+        v <- bondUnmarshalTagged stream+        s <- bondMarshalWithSchema t schema v+        return (BondedStream s)+    | otherwise = do+        v <- bondUnmarshalWithSchema schema stream+        s <- bondMarshalWithSchema t schema v+        return (BondedStream s)+    where+    sig = BL.take 4 stream+    schema = getSchema (Proxy :: Proxy a)+    taggedSigs = [protoSig FastBinaryProto, protoSig CompactBinaryProto, protoSig CompactBinaryV1Proto]+    isTaggedSource = sig `elem` taggedSigs++bondRecodeToTagged :: forall t a. (BondTaggedProto t, BondStruct a) => t -> Bonded a -> Either String (Bonded a)+bondRecodeToTagged t (BondedObject a) = BondedStream <$> bondMarshal t a+bondRecodeToTagged t (BondedStream stream)+    | sig == protoSig t = Right $ BondedStream stream+    | isTaggedSource = do+        v <- bondUnmarshalTagged stream+        s <- bondMarshalTagged t v+        return (BondedStream s)+    | otherwise = do+        v <- bondUnmarshalWithSchema schema stream+        s <- bondMarshalWithSchema t schema v+        return (BondedStream s)+    where+    sig = BL.take 4 stream+    schema = getSchema (Proxy :: Proxy a)+    taggedSigs = [protoSig FastBinaryProto, protoSig CompactBinaryProto, protoSig CompactBinaryV1Proto]+    isTaggedSource = sig `elem` taggedSigs++bondRecodeStruct :: BondProto t => t -> StructSchema -> Bonded Struct -> Either String (Bonded Struct)+bondRecodeStruct t schema (BondedObject a) = BondedStream <$> bondMarshalWithSchema t schema a+bondRecodeStruct t schema (BondedStream stream)+    | sig == protoSig t = Right $ BondedStream stream+    | isTaggedSource = do+        v <- bondUnmarshalTagged stream+        s <- bondMarshalWithSchema t schema v+        return (BondedStream s)+    | otherwise = do+        v <- bondUnmarshalWithSchema schema stream+        s <- bondMarshalWithSchema t schema v+        return (BondedStream s)+    where+    sig = BL.take 4 stream+    taggedSigs = [protoSig FastBinaryProto, protoSig CompactBinaryProto, protoSig CompactBinaryV1Proto]+    isTaggedSource = sig `elem` taggedSigs
+ src/Data/Bond/Internal/Cast.hs view
@@ -0,0 +1,29 @@+{-# Language FlexibleContexts #-}+module Data.Bond.Internal.Cast where++import Control.Monad.ST (runST, ST)+import Data.Array.ST (newArray, readArray, MArray, STUArray)+import Data.Array.Unsafe (castSTUArray)+import Data.Word++{-# INLINE wordToFloat #-}+wordToFloat :: Word32 -> Float+wordToFloat x = runST (cast x)++{-# INLINE floatToWord #-}+floatToWord :: Float -> Word32+floatToWord x = runST (cast x)++{-# INLINE wordToDouble #-}+wordToDouble :: Word64 -> Double+wordToDouble x = runST (cast x)++{-# INLINE doubleToWord #-}+doubleToWord :: Double -> Word64+doubleToWord x = runST (cast x)++{-# INLINE cast #-}+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
+ src/Data/Bond/Internal/CompactBinaryProto.hs view
@@ -0,0 +1,425 @@+{-# Language ScopedTypeVariables, MultiWayIf, TypeFamilies, FlexibleContexts #-}+module Data.Bond.Internal.CompactBinaryProto (+        CompactBinaryProto(..),+        CompactBinaryV1Proto(..)+    ) where++import Data.Bond.Proto+import Data.Bond.Types+import Data.Bond.Internal.BinaryUtils+import Data.Bond.Internal.BondedUtils+import Data.Bond.Internal.Cast+import Data.Bond.Internal.ProtoUtils+import Data.Bond.Internal.Protocol+import Data.Bond.Internal.SchemaUtils+import Data.Bond.Internal.TaggedProtocol+import Data.Bond.Internal.ZigZag++import Data.Bond.Schema.BondDataType+import Data.Bond.Schema.ProtocolType++import Control.Applicative hiding (optional)+import Control.Monad+import Control.Monad.Error+import Data.Bits+import Data.List+import Data.Maybe+import Data.Proxy+import Prelude          -- ghc 7.10 workaround for Control.Applicative++import qualified Data.Binary.Get as B+import qualified Data.Binary.Put as B+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.HashSet as H+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Vector as V++{-|+A binary, tagged protocol using variable integer encoding and compact field header.+Version 2 of Compact Binary adds length prefix for structs. This enables deserialization of bonded\<T\> and skipping of unknown struct fields in constant time.+-}+data CompactBinaryProto = CompactBinaryProto+-- |A binary, tagged protocol using variable integer encoding and compact field header.+data CompactBinaryV1Proto = CompactBinaryV1Proto++instance TaggedProtocol CompactBinaryProto where+    getFieldHeader = getCompactFieldHeader+    getListHeader = do+        v <- getWord8+        if v `shiftR` 5 /= 0+            then return (BondDataType $ fromIntegral (v .&. 0x1f), fromIntegral (v `shiftR` 5) - 1)+            else do+                n <- getVarInt+                return (BondDataType (fromIntegral v), n)+    getTaggedStruct = do+        size <- getVarInt+        isolate size getTaggedData+    putFieldHeader = putCompactFieldHeader+    putListHeader t n = do+        let tag = fromIntegral $ fromEnum t+        if n < 7+            then putWord8 $ tag .|. fromIntegral ((1 + n) `shiftL` 5)+            else do+                putWord8 tag+                putVarInt n+    putTaggedStruct v = do+        let BondPut g = putTaggedData v >> putTag bT_STOP :: BondPut CompactBinaryProto+        case tryPut g of+            Left msg -> throwError msg+            Right bs -> do+                putVarInt $ BL.length bs+                putLazyByteString bs+    skipStruct = getVarInt >>= skip+    skipRestOfStruct =+        let loop = do+                (wiretype, _) <- getFieldHeader+                if | wiretype == bT_STOP -> return ()+                   | wiretype == bT_STOP_BASE -> loop+                   | otherwise -> skipType wiretype >> loop+         in loop+    skipType = compactSkipType++instance BondProto CompactBinaryProto where+    bondRead = binaryDecode+    bondWrite = binaryEncode+    bondReadWithSchema = readTaggedWithSchema+    bondWriteWithSchema = writeTaggedWithSchema+    protoSig _ = protoHeader cOMPACT_PROTOCOL 2++instance BondTaggedProto CompactBinaryProto where+    bondReadTagged = readTagged+    bondWriteTagged = writeTagged++instance Protocol CompactBinaryProto where+    type ReaderM CompactBinaryProto = B.Get+    type WriterM CompactBinaryProto = ErrorT String B.PutM++    bondGetStruct = do+        size <- getVarInt+        isolate size $ getStruct TopLevelStruct+    bondGetBaseStruct = getStruct BaseStruct++    bondGetBool = do+        v <- getWord8+        return $ v /= 0+    bondGetUInt8 = getWord8+    bondGetUInt16 = getVarInt+    bondGetUInt32 = getVarInt+    bondGetUInt64 = getVarInt+    bondGetInt8 = fromIntegral <$> getWord8+    bondGetInt16 = fromZigZag <$> getVarInt+    bondGetInt32 = fromZigZag <$> getVarInt+    bondGetInt64 = fromZigZag <$> getVarInt+    bondGetFloat = wordToFloat <$> getWord32le+    bondGetDouble = wordToDouble <$> getWord64le+    bondGetString = do+        n <- getVarInt+        Utf8 <$> getByteString n+    bondGetWString = do+        n <- getVarInt+        Utf16 <$> getByteString (n * 2)+    bondGetBlob = getBlob+    bondGetDefNothing = Just <$> bondGet+    bondGetList = getList+    bondGetHashSet = H.fromList <$> bondGetList+    bondGetSet = S.fromList <$> bondGetList+    bondGetMap = getMap+    bondGetVector = getVector+    bondGetNullable = do+        v <- bondGetList+        case v of+            [] -> return Nothing+            [x] -> return (Just x)+            _ -> fail $ "list of length " ++ show (length v) ++ " where nullable expected"+    bondGetBonded = getBonded cOMPACT_PROTOCOL 2++    bondPutStruct v = do+        let BondPut g = putStruct TopLevelStruct v :: BondPut CompactBinaryProto+        case tryPut g of+            Left msg -> throwError msg+            Right bs -> do+                putVarInt $ BL.length bs+                putLazyByteString bs+    bondPutBaseStruct = putBaseStruct+    bondPutField = putField+    bondPutDefNothingField p n Nothing = unless (isOptionalField p n) $ fail "can't write nothing to non-optional field"+    bondPutDefNothingField p n (Just v) = putField p n v++    bondPutBool True = putWord8 1+    bondPutBool False = putWord8 0+    bondPutUInt8 = putWord8+    bondPutUInt16 = putVarInt+    bondPutUInt32 = putVarInt+    bondPutUInt64 = putVarInt+    bondPutInt8 = putWord8 . fromIntegral+    bondPutInt16 = putVarInt . toZigZag+    bondPutInt32 = putVarInt . toZigZag+    bondPutInt64 = putVarInt . toZigZag+    bondPutFloat = putWord32le . floatToWord+    bondPutDouble = putWord64le . doubleToWord+    bondPutString (Utf8 s) = do+        putVarInt $ BS.length s+        putByteString s+    bondPutWString (Utf16 s) = do+        putVarInt $ BS.length s `div` 2+        putByteString s+    bondPutList = putList+    bondPutNullable = bondPutList . maybeToList+    bondPutHashSet = putHashSet+    bondPutSet = putSet+    bondPutMap = putMap+    bondPutVector = putVector+    bondPutBlob (Blob b) = do+        putListHeader bT_INT8 (BS.length b)+        putByteString b+    bondPutBonded (BondedObject a) = bondPut a+    bondPutBonded s = do+        BondedStream stream <- case bondRecode CompactBinaryProto s of+            Left msg -> throwError $ "Bonded recode error: " ++ msg+            Right v -> return v+        putLazyByteString (BL.drop 4 stream)++instance TaggedProtocol CompactBinaryV1Proto where+    getFieldHeader = getCompactFieldHeader+    getListHeader = do+        t <- BondDataType . fromIntegral <$> getWord8+        n <- getVarInt+        return (t, n)+    getTaggedStruct = getTaggedData+    putFieldHeader = putCompactFieldHeader+    putListHeader t n = do+        putTag t+        putVarInt n+    putTaggedStruct s = putTaggedData s >> putTag bT_STOP+    skipStruct =+        let loop = do+                (td, _) <- getFieldHeader+                if | td == bT_STOP -> return ()+                   | td == bT_STOP_BASE -> loop+                   | otherwise -> skipType td >> loop+         in loop+    skipRestOfStruct = skipType bT_STRUCT+    skipType = compactSkipType++instance BondProto CompactBinaryV1Proto where+    bondRead = binaryDecode+    bondWrite = binaryEncode+    bondReadWithSchema = readTaggedWithSchema+    bondWriteWithSchema = writeTaggedWithSchema+    protoSig _ = protoHeader cOMPACT_PROTOCOL 1++instance BondTaggedProto CompactBinaryV1Proto where+    bondReadTagged = readTagged+    bondWriteTagged = writeTagged++instance Protocol CompactBinaryV1Proto where+    type ReaderM CompactBinaryV1Proto = B.Get+    type WriterM CompactBinaryV1Proto = ErrorT String B.PutM++    bondGetStruct = getStruct TopLevelStruct+    bondGetBaseStruct = getStruct BaseStruct++    bondGetBool = do+        v <- getWord8+        return $ v /= 0+    bondGetUInt8 = getWord8+    bondGetUInt16 = getVarInt+    bondGetUInt32 = getVarInt+    bondGetUInt64 = getVarInt+    bondGetInt8 = fromIntegral <$> getWord8+    bondGetInt16 = fromZigZag <$> getVarInt+    bondGetInt32 = fromZigZag <$> getVarInt+    bondGetInt64 = fromZigZag <$> getVarInt+    bondGetFloat = wordToFloat <$> getWord32le+    bondGetDouble = wordToDouble <$> getWord64le+    bondGetString = do+        n <- getVarInt+        Utf8 <$> getByteString n+    bondGetWString = do+        n <- getVarInt+        Utf16 <$> getByteString (n * 2)+    bondGetBlob = getBlob+    bondGetDefNothing = Just <$> bondGet+    bondGetList = getList+    bondGetHashSet = H.fromList <$> bondGetList+    bondGetSet = S.fromList <$> bondGetList+    bondGetMap = getMap+    bondGetVector = getVector+    bondGetNullable = do+        v <- bondGetList+        case v of+            [] -> return Nothing+            [x] -> return (Just x)+            _ -> fail $ "list of length " ++ show (length v) ++ " where nullable expected"+    bondGetBonded = getBonded cOMPACT_PROTOCOL 1++    bondPutStruct = putStruct TopLevelStruct+    bondPutBaseStruct = putBaseStruct+    bondPutField = putField+    bondPutDefNothingField p n Nothing = unless (isOptionalField p n) $ fail "can't write nothing to non-optional field"+    bondPutDefNothingField p n (Just v) = putField p n v++    bondPutBool True = putWord8 1+    bondPutBool False = putWord8 0+    bondPutUInt8 = putWord8+    bondPutUInt16 = putVarInt+    bondPutUInt32 = putVarInt+    bondPutUInt64 = putVarInt+    bondPutInt8 = putWord8 . fromIntegral+    bondPutInt16 = putVarInt . toZigZag+    bondPutInt32 = putVarInt . toZigZag+    bondPutInt64 = putVarInt . toZigZag+    bondPutFloat = putWord32le . floatToWord+    bondPutDouble = putWord64le . doubleToWord+    bondPutString (Utf8 s) = do+        putVarInt $ BS.length s+        putByteString s+    bondPutWString (Utf16 s) = do+        putVarInt $ BS.length s `div` 2+        putByteString s+    bondPutList = putList+    bondPutNullable = bondPutList . maybeToList+    bondPutHashSet = putHashSet+    bondPutSet = putSet+    bondPutMap = putMap+    bondPutVector = putVector+    bondPutBlob (Blob b) = do+        putListHeader bT_INT8 (BS.length b)+        putByteString b+    bondPutBonded (BondedObject a) = bondPut a+    bondPutBonded s = do+        BondedStream stream <- case bondRecode CompactBinaryV1Proto s of+            Left msg -> throwError $ "Bonded recode error: " ++ msg+            Right v -> return v+        putLazyByteString (BL.drop 4 stream)++getCompactFieldHeader :: (BondProto t, ReaderM t ~ B.Get) => BondGet t (BondDataType, Ordinal)+getCompactFieldHeader = do+    tag <- getWord8+    case tag `shiftR` 5 of+        6 -> do+            n <- getWord8+            return (BondDataType $ fromIntegral $ tag .&. 31, Ordinal (fromIntegral n))+        7 -> do+            n <- getWord16le+            return (BondDataType $ fromIntegral $ tag .&. 31, Ordinal n)+        n -> return (BondDataType $ fromIntegral $ tag .&. 31, Ordinal (fromIntegral n))++putCompactFieldHeader :: (BondProto t, WriterM t ~ ErrorT String B.PutM) => BondDataType -> Ordinal -> BondPut t+putCompactFieldHeader t (Ordinal n) =+    let tbits = fromIntegral $ fromEnum t+        nbits = fromIntegral n+     in if | n <= 5 -> putWord8 $ tbits .|. (nbits `shiftL` 5)+           | n <= 255 -> do+                    putWord8 $ tbits .|. 0xC0+                    putWord8 nbits+           | otherwise -> do+                    putWord8 $ tbits .|. 0xE0+                    putWord16le n++getBlob :: (TaggedProtocol t, ReaderM t ~ B.Get) => BondGet t Blob+getBlob = do+    (t, n) <- getListHeader+    unless (t == bT_INT8) $ fail $ "invalid element tag " ++ bondTypeName t ++ " in blob field"+    Blob <$> getByteString n++getList :: forall a t. (TaggedProtocol t, ReaderM t ~ B.Get, BondType a) => BondGet t [a]+getList = do+    let et = getWireType (Proxy :: Proxy a)+    (t, n) <- getListHeader+    unless (t == et) $ fail $ "invalid element tag " ++ bondTypeName t ++ " in list field, " ++ bondTypeName et ++ " expected"+    replicateM n bondGet++getVector :: forall a t. (TaggedProtocol t, ReaderM t ~ B.Get, BondType a) => BondGet t (Vector a)+getVector = do+    let et = getWireType (Proxy :: Proxy a)+    (t, n) <- getListHeader+    unless (t == et) $ fail $ "invalid element tag " ++ bondTypeName t ++ " in list field, " ++ bondTypeName et ++ " expected"+    V.replicateM n bondGet++getMap :: forall k v t. (TaggedProtocol t, ReaderM t ~ B.Get, Ord k, BondType k, BondType v) => BondGet t (Map k v)+getMap = do+    let etk = getWireType (Proxy :: Proxy k)+    let etv = getWireType (Proxy :: Proxy v)+    tk <- BondDataType . fromIntegral <$> getWord8+    tv <- BondDataType . fromIntegral <$> getWord8+    unless (tk == etk) $ fail $ "invalid key tag " ++ bondTypeName tk ++ " in map field, " ++ bondTypeName etk ++ " expected"+    unless (tv == etv) $ fail $ "invalid value tag " ++ bondTypeName tv ++ " in map field, " ++ bondTypeName etv ++ " expected"+    n <- getVarInt+    fmap M.fromList $ replicateM n $ do+        k <- bondGet+        v <- bondGet+        return (k, v)++getBonded :: (TaggedProtocol t, ReaderM t ~ B.Get) => ProtocolType -> Word16 -> BondGet t (Bonded a)+getBonded sig ver = do+    size <- lookAhead $ do+        start <- bytesRead+        skipType bT_STRUCT+        stop <- bytesRead+        return (stop - start)+    bs <- getLazyByteString (fromIntegral size)+    return $ BondedStream $ BL.append (protoHeader sig ver) bs++skipVarInt :: forall t. (Protocol t, ReaderM t ~ B.Get) => BondGet t ()+skipVarInt = void (getVarInt :: BondGet t Word64)++compactSkipType :: (TaggedProtocol t, ReaderM t ~ B.Get) => BondDataType -> BondGet t ()+compactSkipType t =+     if | t == bT_BOOL -> skip 1+        | t == bT_UINT8 -> skip 1+        | t == bT_UINT16 -> skipVarInt+        | t == bT_UINT32 -> skipVarInt+        | t == bT_UINT64 -> skipVarInt+        | t == bT_FLOAT -> skip 4+        | t == bT_DOUBLE -> skip 8+        | t == bT_STRING -> getVarInt >>= skip+        | t == bT_STRUCT -> skipStruct+        | t == bT_LIST -> do+            (td, n) <- getListHeader+            replicateM_ n (skipType td)+        | t == bT_SET -> skipType bT_LIST+        | t == bT_MAP -> do+            tk <- BondDataType . fromIntegral <$> getWord8+            tv <- BondDataType . fromIntegral <$> getWord8+            n <- getVarInt+            replicateM_ n $ skipType tk >> skipType tv+        | t == bT_INT8 -> skip 1+        | t == bT_INT16 -> skipVarInt+        | t == bT_INT32 -> skipVarInt+        | t == bT_INT64 -> skipVarInt+        | t == bT_WSTRING -> do+            n <- getVarInt+            skip $ n * 2+        | otherwise -> fail $ "Invalid type to skip " ++ bondTypeName t++putList :: forall a t. (TaggedProtocol t, WriterM t ~ ErrorT String B.PutM, BondType a) => [a] -> BondPut t+putList xs = do+    putListHeader (getWireType (Proxy :: Proxy a)) (length xs)+    mapM_ bondPut xs++putHashSet :: forall a t. (TaggedProtocol t, WriterM t ~ ErrorT String B.PutM, BondType a) => HashSet a -> BondPut t+putHashSet xs = do+    putListHeader (getWireType (Proxy :: Proxy a)) (H.size xs)+    mapM_ bondPut $ H.toList xs++putSet :: forall a t. (TaggedProtocol t, WriterM t ~ ErrorT String B.PutM, BondType a) => Set a -> BondPut t+putSet xs = do+    putListHeader (getWireType (Proxy :: Proxy a)) (S.size xs)+    mapM_ bondPut $ S.toList xs++putMap :: forall k v t. (Protocol t, WriterM t ~ ErrorT String B.PutM, BondType k, BondType v) => Map k v -> BondPut t+putMap m = do+    putTag $ getWireType (Proxy :: Proxy k)+    putTag $ getWireType (Proxy :: Proxy v)+    putVarInt $ M.size m+    forM_ (M.toList m) $ \(k, v) -> do+        bondPut k+        bondPut v++putVector :: forall a t. (TaggedProtocol t, WriterM t ~ ErrorT String B.PutM, BondType a) => Vector a -> BondPut t+putVector xs = do+    putListHeader (getWireType (Proxy :: Proxy a)) (V.length xs)+    V.mapM_ bondPut xs
+ src/Data/Bond/Internal/CompactBinaryProto.hs-boot view
@@ -0,0 +1,11 @@+module Data.Bond.Internal.CompactBinaryProto where++import Data.Bond.Proto++data CompactBinaryProto = CompactBinaryProto+data CompactBinaryV1Proto = CompactBinaryV1Proto++instance BondProto CompactBinaryProto+instance BondTaggedProto CompactBinaryProto+instance BondProto CompactBinaryV1Proto+instance BondTaggedProto CompactBinaryV1Proto
+ src/Data/Bond/Internal/Default.hs view
@@ -0,0 +1,126 @@+module Data.Bond.Internal.Default where++import Data.Bond.TypedSchema+import Data.Bond.Types+import Data.Maybe+import qualified Data.ByteString as BS+import qualified Data.HashSet as H+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Vector as V++-- |Type with default value.+--  Used for optional field elimination.+class Default a where+    -- |Get default value for specified type.+    defaultValue :: a+    -- |Check if value matches default in 'FieldTypeInfo'+    equalToDefault :: FieldTypeInfo -> a -> Bool+    equalToDefault _ _ = False++instance Default Bool where+    defaultValue = False+    equalToDefault (FieldBool (DefaultValue v)) a = v == a+    equalToDefault (FieldBool DefaultNothing) _ = False+    equalToDefault _ _ = error "internal error: field type do not match value in Bool"+instance Default Double where+    defaultValue = 0+    equalToDefault (FieldDouble (DefaultValue v)) a = v == a+    equalToDefault (FieldDouble DefaultNothing) _ = False+    equalToDefault _ _ = error "internal error: field type do not match value in Double"+instance Default Float where+    defaultValue = 0+    equalToDefault (FieldFloat (DefaultValue v)) a = v == a+    equalToDefault (FieldFloat DefaultNothing) _ = False+    equalToDefault _ _ = error "internal error: field type do not match value in Float"+instance Default Int8 where+    defaultValue = 0+    equalToDefault (FieldInt8 (DefaultValue v)) a = v == a+    equalToDefault (FieldInt8 DefaultNothing) _ = False+    equalToDefault _ _ = error "internal error: field type do not match value in Int8"+instance Default Int16 where+    defaultValue = 0+    equalToDefault (FieldInt16 (DefaultValue v)) a = v == a+    equalToDefault (FieldInt16 DefaultNothing) _ = False+    equalToDefault _ _ = error "internal error: field type do not match value in Int16"+instance Default Int32 where+    defaultValue = 0+    equalToDefault (FieldInt32 (DefaultValue v)) a = v == a+    equalToDefault (FieldInt32 DefaultNothing) _ = False+    equalToDefault _ _ = error "internal error: field type do not match value in Int32"+instance Default Int64 where+    defaultValue = 0+    equalToDefault (FieldInt64 (DefaultValue v)) a = v == a+    equalToDefault (FieldInt64 DefaultNothing) _ = False+    equalToDefault _ _ = error "internal error: field type do not match value in Int64"+instance Default Word8 where+    defaultValue = 0+    equalToDefault (FieldUInt8 (DefaultValue v)) a = v == a+    equalToDefault (FieldUInt8 DefaultNothing) _ = False+    equalToDefault _ _ = error "internal error: field type do not match value in UInt8"+instance Default Word16 where+    defaultValue = 0+    equalToDefault (FieldUInt16 (DefaultValue v)) a = v == a+    equalToDefault (FieldUInt16 DefaultNothing) _ = False+    equalToDefault _ _ = error "internal error: field type do not match value in UInt16"+instance Default Word32 where+    defaultValue = 0+    equalToDefault (FieldUInt32 (DefaultValue v)) a = v == a+    equalToDefault (FieldUInt32 DefaultNothing) _ = False+    equalToDefault _ _ = error "internal error: field type do not match value in UInt32"+instance Default Word64 where+    defaultValue = 0+    equalToDefault (FieldUInt64 (DefaultValue v)) a = v == a+    equalToDefault (FieldUInt64 DefaultNothing) _ = False+    equalToDefault _ _ = error "internal error: field type do not match value in UInt64"+instance Default (Maybe a) where+    defaultValue = Nothing+    -- default value for nullable is always null+    equalToDefault FieldList{} = isNothing+    equalToDefault _ = error "internal error: field type do not match value in Maybe"+instance Default [a] where+    defaultValue = []+    -- default value for list is always []+    equalToDefault FieldList{} = null+    equalToDefault _ = error "internal error: field type do not match value in List"+instance Default Blob where+    defaultValue = Blob BS.empty+    -- default value for blob is always BS.empty+    equalToDefault FieldList{} (Blob a) = BS.null a+    equalToDefault _ _ = error "internal error: field type do not match value in Blob"+instance Default Utf8 where+    defaultValue = Utf8 BS.empty+    equalToDefault (FieldString (DefaultValue v)) a = v == a+    equalToDefault (FieldString DefaultNothing) _ = False+    equalToDefault _ _ = error "internal error: field type do not match value in String"+instance Default Utf16 where+    defaultValue = Utf16 BS.empty+    equalToDefault (FieldWString (DefaultValue v)) a = v == a+    equalToDefault (FieldWString DefaultNothing) _ = False+    equalToDefault _ _ = error "internal error: field type do not match value in WString"+instance Default (Map a b) where+    defaultValue = M.empty+    -- default value for map is always M.empty+    equalToDefault FieldMap{} = M.null+    equalToDefault _ = error "internal error: field type do not match value in Map"+instance Default (HashSet a) where+    defaultValue = H.empty+    -- default value for set is always H.empty+    equalToDefault FieldSet{} = H.null+    equalToDefault _ = error "internal error: field type do not match value in HashSet"+instance Default (Set a) where+    defaultValue = S.empty+    -- default value for set is always H.empty+    equalToDefault FieldSet{} = S.null+    equalToDefault _ = error "internal error: field type do not match value in Set"+instance Default (Vector a) where+    defaultValue = V.empty+    -- default value for vector is always V.empty+    equalToDefault FieldList{} = V.null+    equalToDefault _ = error "internal error: field type do not match value in Vector"+instance Default a => Default (Bonded a) where+    defaultValue = BondedObject defaultValue+    -- Default value check is performed to decide if field needs to be written.+    -- Bonded streams must always be written.+    equalToDefault FieldBonded{} _ = False+    equalToDefault _ _ = error "internal error: field type do not match value in Bonded"
+ src/Data/Bond/Internal/FastBinaryProto.hs view
@@ -0,0 +1,257 @@+{-# Language ScopedTypeVariables, MultiWayIf, TypeFamilies #-}+module Data.Bond.Internal.FastBinaryProto (+        FastBinaryProto(..)+    ) where++import Data.Bond.Proto+import Data.Bond.Types+import Data.Bond.Internal.BinaryUtils+import Data.Bond.Internal.BondedUtils+import Data.Bond.Internal.Cast+import Data.Bond.Internal.Protocol+import Data.Bond.Internal.ProtoUtils+import Data.Bond.Internal.SchemaUtils+import Data.Bond.Internal.TaggedProtocol++import Data.Bond.Schema.BondDataType+import Data.Bond.Schema.ProtocolType++import Control.Applicative+import Control.Monad+import Control.Monad.Error+import Data.List+import Data.Maybe+import Data.Proxy+import Prelude          -- ghc 7.10 workaround for Control.Applicative++import qualified Data.Binary.Get as B+import qualified Data.Binary.Put as B+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.HashSet as H+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Vector as V++-- |A binary, tagged protocol similar to 'CompactBinaryProto' but optimized for deserialization speed rather than payload compactness.+data FastBinaryProto = FastBinaryProto++instance TaggedProtocol FastBinaryProto where+    getFieldHeader = do+        t <- BondDataType . fromIntegral <$> getWord8+        n <- if t == bT_STOP || t == bT_STOP_BASE then return 0 else getWord16le+        return (t, Ordinal n)+    getListHeader = do+        t <- BondDataType . fromIntegral <$> getWord8+        n <- getVarInt+        return (t, n)+    getTaggedStruct = getTaggedData+    putFieldHeader t (Ordinal n) = do+        putTag t+        putWord16le n+    putListHeader t n = do+        putTag t+        putVarInt n+    putTaggedStruct s = putTaggedData s >> putTag bT_STOP+    skipStruct =+        let loop = do+                (td, _) <- getFieldHeader+                if | td == bT_STOP -> return ()+                   | td == bT_STOP_BASE -> loop+                   | otherwise -> skipType td >> loop+         in loop+    skipRestOfStruct = skipType bT_STRUCT+    skipType t =+        if | t == bT_BOOL -> skip 1+           | t == bT_UINT8 -> skip 1+           | t == bT_UINT16 -> skip 2+           | t == bT_UINT32 -> skip 4+           | t == bT_UINT64 -> skip 8+           | t == bT_FLOAT -> skip 4+           | t == bT_DOUBLE -> skip 8+           | t == bT_STRING -> getVarInt >>= skip+           | t == bT_STRUCT ->+                let loop = do+                        td <- BondDataType . fromIntegral <$> getWord8+                        if | td == bT_STOP -> return ()+                           | td == bT_STOP_BASE -> loop+                           | otherwise -> skip 2 >> skipType td >> loop+                 in loop+           | t == bT_LIST -> do+                td <- BondDataType . fromIntegral <$> getWord8+                n <- getVarInt+                replicateM_ n (skipType td)+           | t == bT_SET -> skipType bT_LIST+           | t == bT_MAP -> do+                tk <- BondDataType . fromIntegral <$> getWord8+                tv <- BondDataType . fromIntegral <$> getWord8+                n <- getVarInt+                replicateM_ n $ skipType tk >> skipType tv+           | t == bT_INT8 -> skip 1+           | t == bT_INT16 -> skip 2+           | t == bT_INT32 -> skip 4+           | t == bT_INT64 -> skip 8+           | t == bT_WSTRING -> do+                n <- getVarInt+                skip $ n * 2+           | otherwise -> fail $ "Invalid type to skip " ++ bondTypeName t++instance BondProto FastBinaryProto where+    bondRead = binaryDecode+    bondWrite = binaryEncode+    bondReadWithSchema = readTaggedWithSchema+    bondWriteWithSchema = writeTaggedWithSchema+    protoSig _ = protoHeader fAST_PROTOCOL 1++instance BondTaggedProto FastBinaryProto where+    bondReadTagged = readTagged+    bondWriteTagged = writeTagged++instance Protocol FastBinaryProto where+    type ReaderM FastBinaryProto = B.Get+    type WriterM FastBinaryProto = ErrorT String B.PutM++    bondGetStruct = getStruct TopLevelStruct+    bondGetBaseStruct = getStruct BaseStruct++    bondGetBool = do+        v <- getWord8+        return $ v /= 0+    bondGetUInt8 = getWord8+    bondGetUInt16 = getWord16le+    bondGetUInt32 = getWord32le+    bondGetUInt64 = getWord64le+    bondGetInt8 = fromIntegral <$> getWord8+    bondGetInt16 = fromIntegral <$> getWord16le+    bondGetInt32 = fromIntegral <$> getWord32le+    bondGetInt64 = fromIntegral <$> getWord64le+    bondGetFloat = wordToFloat <$> getWord32le+    bondGetDouble = wordToDouble <$> getWord64le+    bondGetString = do+        n <- getVarInt+        Utf8 <$> getByteString n+    bondGetWString = do+        n <- getVarInt+        Utf16 <$> getByteString (n * 2)+    bondGetBlob = do+        (t, n) <- getListHeader+        unless (t == bT_INT8) $ fail $ "invalid element tag " ++ bondTypeName t ++ " in blob field"+        Blob <$> getByteString n+    bondGetDefNothing = Just <$> bondGet+    bondGetList = getList+    bondGetHashSet = H.fromList <$> bondGetList+    bondGetSet = S.fromList <$> bondGetList+    bondGetMap = getMap+    bondGetVector = getVector+    bondGetNullable = do+        v <- bondGetList+        case v of+            [] -> return Nothing+            [x] -> return (Just x)+            _ -> fail $ "list of length " ++ show (length v) ++ " where nullable expected"+    bondGetBonded = do+        size <- lookAhead $ do+            start <- bytesRead+            skipType bT_STRUCT+            stop <- bytesRead+            return (stop - start)+        bs <- getLazyByteString (fromIntegral size)+        return $ BondedStream $ BL.append (protoHeader fAST_PROTOCOL 1) bs++    bondPutStruct = putStruct TopLevelStruct+    bondPutBaseStruct = putBaseStruct+    bondPutField = putField+    bondPutDefNothingField p n Nothing = unless (isOptionalField p n) $ fail "can't write nothing to non-optional field"+    bondPutDefNothingField p n (Just v) = putField p n v++    bondPutBool True = putWord8 1+    bondPutBool False = putWord8 0+    bondPutUInt8 = putWord8+    bondPutUInt16 = putWord16le+    bondPutUInt32 = putWord32le+    bondPutUInt64 = putWord64le+    bondPutInt8 = putWord8 . fromIntegral+    bondPutInt16 = putWord16le . fromIntegral+    bondPutInt32 = putWord32le . fromIntegral+    bondPutInt64 = putWord64le . fromIntegral+    bondPutFloat = putWord32le . floatToWord+    bondPutDouble = putWord64le . doubleToWord+    bondPutString (Utf8 s) = do+        putVarInt $ BS.length s+        putByteString s+    bondPutWString (Utf16 s) = do+        putVarInt $ BS.length s `div` 2+        putByteString s+    bondPutList = putList+    bondPutNullable = bondPutList . maybeToList+    bondPutHashSet = putHashSet+    bondPutSet = putSet+    bondPutMap = putMap+    bondPutVector = putVector+    bondPutBlob (Blob b) = do+        putTag bT_INT8+        putVarInt $ BS.length b+        putByteString b+    bondPutBonded (BondedObject a) = bondPut a+    bondPutBonded s = do+        BondedStream stream <- case bondRecode FastBinaryProto s of+            Left msg -> throwError $ "Bonded recode error: " ++ msg+            Right v -> return v+        putLazyByteString (BL.drop 4 stream)++getList :: forall a. BondType a => BondGet FastBinaryProto [a]+getList = do+    let et = getWireType (Proxy :: Proxy a)+    (t, n) <- getListHeader+    unless (t == et) $ fail $ "invalid element tag " ++ bondTypeName t ++ " in list field, " ++ bondTypeName et ++ " expected"+    replicateM n bondGet++getVector :: forall a. BondType a => BondGet FastBinaryProto (Vector a)+getVector = do+    let et = getWireType (Proxy :: Proxy a)+    (t, n) <- getListHeader+    unless (t == et) $ fail $ "invalid element tag " ++ bondTypeName t ++ " in list field, " ++ bondTypeName et ++ " expected"+    V.replicateM n bondGet++getMap :: forall k v. (Ord k, BondType k, BondType v) => BondGet FastBinaryProto (Map k v)+getMap = do+    let etk = getWireType (Proxy :: Proxy k)+    let etv = getWireType (Proxy :: Proxy v)+    tk <- BondDataType . fromIntegral <$> getWord8+    tv <- BondDataType . fromIntegral <$> getWord8+    unless (tk == etk) $ fail $ "invalid element tag " ++ bondTypeName tk ++ " in list field, " ++ bondTypeName etk ++ " expected"+    unless (tv == etv) $ fail $ "invalid element tag " ++ bondTypeName tv ++ " in list field, " ++ bondTypeName etv ++ " expected"+    n <- getVarInt+    fmap M.fromList $ replicateM n $ do+        k <- bondGet+        v <- bondGet+        return (k, v)++putList :: forall a. BondType a => [a] -> BondPut FastBinaryProto+putList xs = do+    putListHeader (getWireType (Proxy :: Proxy a)) (length xs)+    mapM_ bondPut xs++putHashSet :: forall a. BondType a => HashSet a -> BondPut FastBinaryProto+putHashSet xs = do+    putListHeader (getWireType (Proxy :: Proxy a)) (H.size xs)+    mapM_ bondPut $ H.toList xs++putSet :: forall a. BondType a => Set a -> BondPut FastBinaryProto+putSet xs = do+    putListHeader (getWireType (Proxy :: Proxy a)) (S.size xs)+    mapM_ bondPut $ S.toList xs++putMap :: forall k v. (BondType k, BondType v) => Map k v -> BondPut FastBinaryProto+putMap m = do+    putTag $ getWireType (Proxy :: Proxy k)+    putTag $ getWireType (Proxy :: Proxy v)+    putVarInt $ M.size m+    forM_ (M.toList m) $ \(k, v) -> do+        bondPut k+        bondPut v++putVector :: forall a. BondType a => Vector a -> BondPut FastBinaryProto+putVector xs = do+    putListHeader (getWireType (Proxy :: Proxy a)) (V.length xs)+    V.mapM_ bondPut xs
+ src/Data/Bond/Internal/FastBinaryProto.hs-boot view
@@ -0,0 +1,8 @@+module Data.Bond.Internal.FastBinaryProto where++import Data.Bond.Proto++data FastBinaryProto = FastBinaryProto++instance BondProto FastBinaryProto+instance BondTaggedProto FastBinaryProto
+ src/Data/Bond/Internal/Imports.hs view
@@ -0,0 +1,24 @@+module Data.Bond.Internal.Imports +    ( module X+    , BondStruct(..)+    , BondType(..)+    , Hashable+    , IsString+    , Protocol(..)+    , ap+    , asProxyTypeOf+    , fromOrdinalList+    ) where ++import Data.Bond.TypedSchema as X+import Data.Bond.Types as X+import Data.Bond.Internal.Default as X+import Data.Bond.Internal.OrdinalSet+import Data.Bond.Internal.Protocol+import Data.Bond.Internal.Utils as X++import Control.Monad (ap)+import Data.Hashable (Hashable)+import Data.Proxy (asProxyTypeOf)+import Data.String (IsString)+import Data.Typeable as X
+ src/Data/Bond/Internal/Imports.hs-boot view
@@ -0,0 +1,5 @@+module Data.Bond.Internal.Imports+    ( module X+    ) where++import Data.Bond.Types as X
+ src/Data/Bond/Internal/JsonProto.hs view
@@ -0,0 +1,394 @@+{-# Language MultiWayIf, ScopedTypeVariables, FlexibleContexts, TypeFamilies, OverloadedStrings #-}+module Data.Bond.Internal.JsonProto (+        JsonProto(..)+    ) where++import Data.Bond.Proto+import Data.Bond.Struct+import Data.Bond.TypedSchema+import Data.Bond.Types+import Data.Bond.Internal.BondedUtils+import Data.Bond.Internal.Default+import Data.Bond.Internal.OrdinalSet+import Data.Bond.Internal.Protocol+import Data.Bond.Internal.ProtoUtils+import Data.Bond.Internal.SchemaOps+import Data.Bond.Internal.SchemaUtils++import Data.Bond.Schema.ProtocolType++import Control.Applicative hiding (optional)+import Control.Monad+import Control.Monad.Error+import Control.Monad.Extra+import Control.Monad.Reader+import Control.Monad.State.Strict+import Data.List+import Data.Maybe+import Data.Proxy+import Data.Scientific+import Data.Text (Text)+import Data.Text.Encoding+import Prelude          -- ghc 7.10 workaround for Control.Applicative++import qualified Data.Aeson as A+import qualified Data.Aeson.Types as A+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as H+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import qualified Data.Vector as V++-- |The output is a standard JSON and is a very good choice for interoperating with other systems or generating human readable payload. Because payload doesn't include field ordinals, it is treated as untagged protocol.+data JsonProto = JsonProto++type ReadM = ErrorT String (Reader A.Value)+type WriteM = ErrorT String (State A.Value)++instance BondProto JsonProto where+    bondRead _ = jsonDecode+    bondWrite _ = jsonEncode+    bondReadWithSchema _ = jsonDecodeWithSchema+    bondWriteWithSchema _ = jsonEncodeWithSchema+    protoSig _ = protoHeader sIMPLE_JSON_PROTOCOL 1++instance Protocol JsonProto where+    type ReaderM JsonProto = ReadM+    type WriterM JsonProto = WriteM++    bondGetStruct = parseStruct+    bondGetBaseStruct = parseStruct++    bondGetBool = do+        v <- ask+        case v of+            A.Bool b -> return b+            _ -> typeError "bool" v+    bondGetUInt8 = useNumber "uint8" $ maybe (throwError "value doesn't fit to uint8") return . toBoundedInteger+    bondGetUInt16 = useNumber "uint16" $ maybe (throwError "value doesn't fit to uint16") return . toBoundedInteger+    bondGetUInt32 = useNumber "uint32" $ maybe (throwError "value doesn't fit to uint32") return . toBoundedInteger+    bondGetUInt64 = useNumber "uint64" $ maybe (throwError "value doesn't fit to uint64") return . toBoundedInteger+    bondGetInt8 = useNumber "int8" $ maybe (throwError "value doesn't fit to int8") return . toBoundedInteger+    bondGetInt16 = useNumber "int16" $ maybe (throwError "value doesn't fit to int16") return . toBoundedInteger+    bondGetInt32 = useNumber "int32" $ maybe (throwError "value doesn't fit to int32") return . toBoundedInteger+    bondGetInt64 = useNumber "int64" $ maybe (throwError "value doesn't fit to int64") return . toBoundedInteger+    bondGetFloat = useNumber "float" (return . toRealFloat)+    bondGetDouble = useNumber "double" (return . toRealFloat)+    bondGetString = useString "string" (Utf8 . encodeUtf8)+    bondGetWString = useString "wstring" (Utf16 . encodeUtf16LE)+    bondGetBlob = useArray "blob" $ \v -> do+        let convert x = case x of+                A.Number n -> do+                    let byte = toBoundedInteger n :: Maybe Int8+                    when (isNothing byte) $ throwError "value doesn't fit to signed byte"+                    return $ fromIntegral (fromJust byte)+                _ -> typeError "signed byte" x+        xs <- V.mapM convert v+        return $ Blob $ BS.pack $ V.toList xs+    bondGetDefNothing = Just <$> bondGet+    bondGetList = useArray "list" $ \v -> mapM (\e -> local (const e) bondGet) (V.toList v)+    bondGetHashSet = H.fromList <$> bondGetList+    bondGetSet = S.fromList <$> bondGetList+    bondGetMap = useArray "map" $ \v -> do+        let readPair ss = case ss of+                [] -> return []+                (key:val:xs) -> do+                    ke <- local (const key) bondGet+                    ve <- local (const val) bondGet+                    rest <- readPair xs+                    return $ (ke, ve) : rest+                _ -> throwError "map key without value"+        M.fromList <$> readPair (V.toList v)+    bondGetVector = useArray "vector" $ V.mapM (\e -> local (const e) bondGet)+    bondGetNullable = do+        v <- ask+        case v of+            A.Null -> return Nothing+            A.Array a -> if | V.length a == 0 -> return Nothing+                            | V.length a == 1 -> (Just . head) <$> bondGetList+                            | otherwise -> throwError $ "list of length " ++ show (V.length a) ++ " where nullable expected"+            _ -> typeError "nullable" v+    bondGetBonded = do+        v <- ask+        return $ BondedStream $ BL.append (protoSig JsonProto) (A.encode v)++    bondPutStruct v = do+        put A.emptyObject+        bondStructPut v+    bondPutBaseStruct = bondStructPut+    bondPutField = putField+    bondPutDefNothingField p n Nothing = unless (isOptionalField p n) $ fail "can't write nothing to non-optional field"+    bondPutDefNothingField p n (Just v) = putField p n v++    bondPutBool = put . A.Bool+    bondPutUInt8 = put . A.Number . fromIntegral+    bondPutUInt16 = put . A.Number . fromIntegral+    bondPutUInt32 = put . A.Number . fromIntegral+    bondPutUInt64 = put . A.Number . fromIntegral+    bondPutInt8 = put . A.Number . fromIntegral+    bondPutInt16 = put . A.Number . fromIntegral+    bondPutInt32 = put . A.Number . fromIntegral+    bondPutInt64 = put . A.Number . fromIntegral+    bondPutFloat = put . A.Number . fromFloatDigits+    bondPutDouble = put . A.Number . fromFloatDigits+    bondPutString (Utf8 s) = put $ A.String $ decodeUtf8 s+    bondPutWString (Utf16 s) = put $ A.String $ decodeUtf16LE s+    bondPutList = putList+    bondPutNullable Nothing = put A.Null+    bondPutNullable (Just v) = bondPutList [v]+    bondPutHashSet = bondPutList . H.toList+    bondPutSet = bondPutList . S.toList+    bondPutMap = putMap+    bondPutVector xs = do+        vs <- V.forM xs $ \x -> do+            bondPut x+            get+        put $ A.Array vs+    bondPutBlob (Blob b) =+        put $ A.Array $ V.generate (BS.length b) $+            \i -> let w = BS.index b i+                      c = fromIntegral w :: Int8+                   in A.Number (fromIntegral c)+    bondPutBonded = putBonded++putBonded :: forall a. BondStruct a => Bonded a -> BondPut JsonProto+putBonded (BondedObject a) = bondPut a+putBonded s = do+    BondedStream stream <- case bondRecode JsonProto s of+        Left msg -> throwError $ "Bonded recode error: " ++ msg+        Right v -> return v+    case A.eitherDecode (BL.drop 4 stream) of+        Left msg -> throwError $ "Bonded recode error: " ++ msg+        Right v -> put v++typeError :: MonadError String m => String -> A.Value -> m a+typeError s v = throwError $ typename ++ " found where " ++ s ++ " expected"+    where+    typename = case v of+            A.Object _ -> "Object"+            A.Array _  -> "Array"+            A.String _ -> "String"+            A.Number _ -> "Number"+            A.Bool _   -> "Boolean"+            A.Null     -> "Null"++jsonDecode :: forall a. BondStruct a => BL.ByteString -> Either String a+jsonDecode s = do+    v <- A.eitherDecode s+    let BondGet g = bondGetStruct :: BondGet JsonProto a++    runReader (runErrorT g) v++jsonEncode :: forall a. BondStruct a => a -> Either String BL.ByteString+jsonEncode a =+    let BondPut g = bondPutStruct a :: BondPut JsonProto+     in case runState (runErrorT g) (error "no object") of+            (Left msg, _) -> Left msg+            (Right (), v) -> Right $ A.encode v++useObject :: String -> A.Value -> (A.Object -> BondGet JsonProto a) -> BondGet JsonProto a+useObject _ (A.Object v) p = p v+useObject s v _ = typeError s v++useArray :: String -> (A.Array -> BondGet JsonProto a) -> BondGet JsonProto a+useArray s p = do+    v <- ask+    case v of+        A.Array a -> p a+        _ -> typeError s v++useArrayOrNull :: String -> (A.Array -> BondGet JsonProto a) -> BondGet JsonProto a+useArrayOrNull s p = do+    v <- ask+    case v of+        A.Null -> p V.empty+        A.Array a -> p a+        _ -> typeError s v++useNumber :: String -> (Scientific -> BondGet JsonProto a) -> BondGet JsonProto a+useNumber s p = do+    v <- ask+    case v of+        A.Number n -> p n+        _ -> typeError s v++useString :: String -> (Text -> a) -> BondGet JsonProto a+useString s p = do+    v <- ask+    case v of+        A.String str -> return (p str)+        _ -> typeError s v++parseStruct :: forall a . BondStruct a => BondGet JsonProto a+parseStruct = do+    let schema = getSchema (Proxy :: Proxy a)++    value <- ask+    baseStruct <- bondStructGetBase defaultValue++    (retval, notRead) <- useObject "struct" value $ \obj -> do+        let parseField (s, ords) (ordinal, fieldInfo) = do+                let fieldname = M.findWithDefault (fieldName fieldInfo) "JsonName" (fieldAttrs fieldInfo)+                case HM.lookup fieldname obj of+                    Nothing -> return (s, ords)+                    Just v -> do+                        s' <- local (const v) $ bondStructGetField ordinal s+                        return (s', deleteOrdinal ordinal ords)+        foldM parseField (baseStruct, structRequiredOrdinals schema) $ M.toList (structFields schema)+    unless (isEmptySet notRead) $ fail $ "required fields not read: " ++ show (map (getFieldName schema) $ toOrdinalList notRead)+    return retval++putField :: forall a b . (BondType a, BondStruct b) => Proxy b -> Ordinal -> a -> BondPut JsonProto+putField p ordinal a = do+    let fieldInfo = M.findWithDefault (error "internal error: unknown field ordinal") ordinal (structFields $ getSchema p)+    let needToSave = not (equalToDefault (fieldType fieldInfo) a) || fieldModifier fieldInfo /= FieldOptional+    when needToSave $ do+        let fieldname = M.findWithDefault (fieldName fieldInfo) "JsonName" (fieldAttrs fieldInfo)+        A.Object obj <- get+        bondPut a+        v <- get+        put $ A.Object $ HM.insert fieldname v obj++putList :: forall a. BondType a => [a] -> BondPut JsonProto+putList xs = do+    vs <- forM xs $ \x -> do+        bondPut x+        get+    put $ A.Array $ V.fromList vs++putMap :: forall k v. (BondType k, BondType v) => Map k v -> BondPut JsonProto+putMap m = do+    vs <- flip concatMapM (M.toList m) $ \(k, v) -> do+        bondPut k+        key <- get+        bondPut v+        val <- get+        return [key, val]+    put $ A.Array $ V.fromList vs++jsonDecodeWithSchema :: StructSchema -> BL.ByteString -> Either String Struct+jsonDecodeWithSchema rootSchema bs = A.eitherDecode bs >>= runReader (runErrorT rdr)+    where+    BondGet rdr = readStruct rootSchema+    readStruct :: StructSchema -> BondGet JsonProto Struct+    readStruct schema = do+        parent <- case structBase schema of +            Nothing -> return Nothing+            Just baseSchema -> Just <$> readStruct baseSchema+        value <- ask+        useObject "struct" value $ \ obj -> do+            fs <- M.fromList . catMaybes <$> mapM (readField obj) (M.toList $ structFields schema)+            return $ Struct parent fs+    readField obj (fieldId, fieldInfo) = do+        let fieldname = M.findWithDefault (fieldName fieldInfo) "JsonName" (fieldAttrs fieldInfo)+        case HM.lookup fieldname obj of+            Nothing -> return Nothing+            Just v -> do+                fieldValue <- local (const v) $ readValue (fieldToElementType $ fieldType fieldInfo)+                return $ Just (fieldId, fieldValue)++    readValue ElementBool = BOOL <$> bondGetBool+    readValue ElementUInt8 = UINT8 <$> bondGetUInt8+    readValue ElementUInt16 = UINT16 <$> bondGetUInt16+    readValue ElementUInt32 = UINT32 <$> bondGetUInt32+    readValue ElementUInt64 = UINT64 <$> bondGetUInt64+    readValue ElementInt8 = INT8 <$> bondGetInt8+    readValue ElementInt16 = INT16 <$> bondGetInt16+    readValue ElementInt32 = INT32 <$> bondGetInt32+    readValue ElementInt64 = INT64 <$> bondGetInt64+    readValue ElementFloat = FLOAT <$> bondGetFloat+    readValue ElementDouble = DOUBLE <$> bondGetDouble+    readValue ElementString = STRING <$> bondGetString+    readValue ElementWString = WSTRING <$> bondGetWString+    readValue (ElementBonded _) = do+        v <- ask+        return $ BONDED $ BondedStream $ BL.append (protoSig JsonProto) (A.encode v)+    readValue (ElementStruct schema) = STRUCT <$> readStruct schema+    readValue (ElementList element) = useArrayOrNull "list" $ \v ->+        LIST (elementToBondDataType element) <$> forM (V.toList v) (\x ->+            local (const x) (readValue element))+    readValue (ElementSet element) = useArrayOrNull "set" $ \v ->+        SET (elementToBondDataType element) <$> forM (V.toList v) (\x ->+            local (const x) (readValue element))+    readValue (ElementMap key value) = useArray "map" $ \v -> do+        let readPair ss = case ss of+                [] -> return []+                (kobj:vobj:xs) -> do+                    k <- local (const kobj) $ readValue key+                    val <- local (const vobj) $ readValue value+                    rest <- readPair xs+                    return $ (k, val) : rest+                _ -> throwError "map key without value"+        MAP (elementToBondDataType key) (elementToBondDataType value) <$> readPair (V.toList v)++jsonEncodeWithSchema :: StructSchema -> Struct -> Either String BL.ByteString+jsonEncodeWithSchema rootSchema s = do+    struct <- checkStructSchema rootSchema s+    let BondPut writer = putStruct rootSchema struct+    case runState (runErrorT writer) (error "no object") of+        (Left msg, _) -> Left msg+        (Right (), v) -> Right $ A.encode v+    where+    putStruct :: StructSchema -> Struct -> BondPut JsonProto+    putStruct schema struct = do+        put A.emptyObject+        putStructData schema struct+    putStructData schema struct = do+        case (structBase schema, base struct) of +            (Nothing, Nothing) -> return ()+            (Just baseSchema, Just baseStruct) -> putStructData baseSchema baseStruct+            _ -> error "internal error: inheritance chain in schema do not match one in struct"+        mapM_ (putStructField $ structFields schema) $ M.toList $ fields struct+    putStructField schemamap (fieldId, fieldValue) =+        case M.lookup fieldId schemamap of+            Nothing -> return () -- unknown field, can't convert to ordinal, skip it+            Just fieldInfo -> do+                let fieldname = M.findWithDefault (fieldName fieldInfo) "JsonName" (fieldAttrs fieldInfo)+                A.Object obj <- get+                putValue (fieldToElementType $ fieldType fieldInfo) fieldValue+                v <- get+                put $ A.Object $ HM.insert fieldname v obj++    putValue ElementBool (BOOL b) = bondPutBool b+    putValue ElementInt8 (INT8 v) = bondPutInt8 v+    putValue ElementInt16 (INT16 v) = bondPutInt16 v+    putValue ElementInt32 (INT32 v) = bondPutInt32 v+    putValue ElementInt64 (INT64 v) = bondPutInt64 v+    putValue ElementUInt8 (UINT8 v) = bondPutUInt8 v+    putValue ElementUInt16 (UINT16 v) = bondPutUInt16 v+    putValue ElementUInt32 (UINT32 v) = bondPutUInt32 v+    putValue ElementUInt64 (UINT64 v) = bondPutUInt64 v+    putValue ElementFloat (FLOAT v) = bondPutFloat v+    putValue ElementDouble (DOUBLE v) = bondPutDouble v+    putValue ElementString (STRING v) = bondPutString v+    putValue ElementWString (WSTRING v) = bondPutWString v+    putValue (ElementStruct schema) (STRUCT v) = putStruct schema v+    putValue (ElementList element) (LIST _ xs) = do+        vs <- forM xs $ \x -> do+            putValue element x+            get+        put $ A.Array $ V.fromList vs+    putValue (ElementSet element) (SET _ xs) = do+        vs <- forM xs $ \x -> do+            putValue element x+            get+        put $ A.Array $ V.fromList vs+    putValue (ElementMap key value) (MAP _ _ xs) = do+        vs <- flip concatMapM xs $ \(k, v) -> do+            putValue key k+            kobj <- get+            putValue value v+            vobj <- get+            return [kobj, vobj]+        put $ A.Array $ V.fromList vs+    putValue (ElementBonded schema) (BONDED stream@BondedStream{}) = do+        BondedStream jsonstream <- case bondRecodeStruct JsonProto schema stream of+            Left msg -> throwError $ "Bonded recode error: " ++ msg+            Right v -> return v+        case A.eitherDecode (BL.drop 4 jsonstream) of+            Left msg -> throwError $ "Bonded recode error: " ++ msg+            Right v -> put v+    putValue (ElementBonded schema) (BONDED (BondedObject struct)) = putStruct schema struct+    putValue _ _ = error "internal error: schema type do not match value type"
+ src/Data/Bond/Internal/JsonProto.hs-boot view
@@ -0,0 +1,7 @@+module Data.Bond.Internal.JsonProto where++import Data.Bond.Proto++data JsonProto = JsonProto++instance BondProto JsonProto
+ src/Data/Bond/Internal/MarshalUtils.hs view
@@ -0,0 +1,10 @@+module Data.Bond.Internal.MarshalUtils where++import Data.Bond.Proto+import Data.Bond.Internal.Protocol++import qualified Data.ByteString.Lazy as BL++-- XXX workaround for module loops+bondMarshal' :: (BondProto t, BondStruct a) => t -> a -> Either String BL.ByteString+bondMarshal' = bondMarshal
+ src/Data/Bond/Internal/OrdinalSet.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE FlexibleContexts #-}+module Data.Bond.Internal.OrdinalSet where++import Data.Bond.Types++import qualified Data.IntSet as IS+import qualified Data.Vector.Generic as V++type OrdinalSet = IS.IntSet++deleteOrdinal :: Ordinal -> OrdinalSet -> OrdinalSet+deleteOrdinal (Ordinal d) = IS.delete (fromIntegral d)++memberOrdinal :: Ordinal -> OrdinalSet -> Bool+memberOrdinal (Ordinal d) = IS.member (fromIntegral d)++isEmptySet :: OrdinalSet -> Bool+isEmptySet = IS.null++toOrdinalList :: OrdinalSet -> [Ordinal]+toOrdinalList = map (Ordinal . fromIntegral) . IS.toList++fromOrdinalList :: [Ordinal] -> OrdinalSet+fromOrdinalList = IS.fromList . map (\ (Ordinal d) -> fromIntegral d)++fromOrdinalVector :: (V.Vector v Ordinal, V.Vector v IS.Key) => v Ordinal -> OrdinalSet+fromOrdinalVector = IS.fromList . V.toList . V.map (\ (Ordinal d) -> fromIntegral d)
+ src/Data/Bond/Internal/ProtoUtils.hs view
@@ -0,0 +1,23 @@+module Data.Bond.Internal.ProtoUtils where++import Data.Bond.Schema.ProtocolType++import Data.Bits+import Data.Word+import qualified Data.ByteString.Lazy as BL++parseHeader :: BL.ByteString -> (ProtocolType, Word16)+parseHeader s | BL.length s /= 4 = (ProtocolType maxBound, maxBound)+parseHeader s = (protoSig, protoVer)+    where+    [s0, s1, v0, v1] = BL.unpack $ BL.take 4 s+    protoSig = ProtocolType $ fromIntegral s0 .|. (fromIntegral s1 `shiftL` 8)+    protoVer = fromIntegral v0 .|. (fromIntegral v1 `shiftL` 8)++protoHeader :: ProtocolType -> Word16 -> BL.ByteString+protoHeader (ProtocolType protoSig) protoVer = BL.pack [s0, s1, v0, v1]+    where+    s0 = fromIntegral protoSig+    s1 = fromIntegral (protoSig `shiftR` 8)+    v0 = fromIntegral protoVer+    v1 = fromIntegral (protoVer `shiftR` 8)
+ src/Data/Bond/Internal/Protocol.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE UndecidableInstances, FlexibleContexts, GeneralizedNewtypeDeriving, StandaloneDeriving, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-}+module Data.Bond.Internal.Protocol where++import Data.Bond.TypedSchema+import Data.Bond.Types+import Data.Bond.Internal.Default+import Data.Bond.Internal.Utils++import Control.Applicative+import Control.Monad.Error.Class+import Control.Monad.Reader.Class+import Control.Monad.State.Class+import Data.Hashable+import Data.Proxy+import Data.Text+import Data.Typeable+import Prelude          -- ghc 7.10 workaround for Control.Applicative+import qualified Data.HashSet as H+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Vector as V++newtype BondGet t a = BondGet ((ReaderM t) a)+deriving instance (Functor (ReaderM t)) => Functor (BondGet t)+deriving instance (Applicative (ReaderM t)) => Applicative (BondGet t)+deriving instance (Monad (ReaderM t)) => Monad (BondGet t)+deriving instance (MonadReader r (ReaderM t)) => MonadReader r (BondGet t)+deriving instance (MonadState s (ReaderM t)) => MonadState s (BondGet t)+deriving instance (MonadError e (ReaderM t)) => MonadError e (BondGet t)++newtype BondPutM t a = BondPut ((WriterM t) a)+deriving instance (Functor (WriterM t)) => Functor (BondPutM t)+deriving instance (Applicative (WriterM t)) => Applicative (BondPutM t)+deriving instance (Monad (WriterM t)) => Monad (BondPutM t)+deriving instance (MonadReader r (WriterM t)) => MonadReader r (BondPutM t)+deriving instance (MonadState s (WriterM t)) => MonadState s (BondPutM t)+deriving instance (MonadError e (WriterM t)) => MonadError e (BondPutM t)++type BondPut t = BondPutM t ()++-- |A type bond knows how to read and write to stream as a part of 'BondStruct'.+class (Typeable a, Default a) => BondType a where+    -- | Read value.+    bondGet :: (Functor (ReaderM t), Monad (ReaderM t), Protocol t) => BondGet t a+    -- | Write value.+    bondPut :: (Monad (BondPutM t), Protocol t) => a -> BondPut t+    -- | Get name of type.+    getName :: Proxy a -> Text+    -- | Get qualified name of type.+    getQualifiedName :: Proxy a -> Text+    -- | Get type description.+    getElementType :: Proxy a -> ElementTypeInfo++-- |Bond top-level structure, can be de/serialized on its own.+class BondType a => BondStruct a where+    -- | Read all struct fields in order.+    bondStructGetUntagged :: (Functor (ReaderM t), Monad (ReaderM t), Protocol t) => BondGet t a+    -- | Read base struct from stream.+    bondStructGetBase :: (Monad (ReaderM t), Protocol t) => a -> BondGet t a+    -- | Read field with specific ordinal.+    bondStructGetField :: (Functor (ReaderM t), Monad (ReaderM t), Protocol t) => Ordinal -> a -> BondGet t a+    -- | Put all struct fields to stream in order.+    bondStructPut :: (Monad (BondPutM t), Protocol t) => a -> BondPut t+    -- | Obtain struct schema.+    getSchema :: Proxy a -> StructSchema++-- |Bond serialization protocol, implements all operations.+class Protocol t where+    type ReaderM t :: * -> *+    type WriterM t :: * -> *+    -- | Serialize top-level struct+    bondPutStruct :: BondStruct a => a -> BondPut t+    -- | Serialize base struct+    bondPutBaseStruct :: BondStruct a => a -> BondPut t+    -- | Deserialize top-level struct+    bondGetStruct :: BondStruct a => BondGet t a+    -- | Deserialize base struct+    bondGetBaseStruct :: BondStruct a => BondGet t a++    bondPutField :: (BondType a, BondStruct b) => Proxy b -> Ordinal -> a -> BondPut t+    bondPutDefNothingField :: (BondType a, BondStruct b) => Proxy b -> Ordinal -> Maybe a -> BondPut t++    bondPutBool :: Bool -> BondPut t+    bondPutUInt8 :: Word8 -> BondPut t+    bondPutUInt16 :: Word16 -> BondPut t+    bondPutUInt32 :: Word32 -> BondPut t+    bondPutUInt64 :: Word64 -> BondPut t+    bondPutInt8 :: Int8 -> BondPut t+    bondPutInt16 :: Int16 -> BondPut t+    bondPutInt32 :: Int32 -> BondPut t+    bondPutInt64 :: Int64 -> BondPut t+    bondPutFloat :: Float -> BondPut t+    bondPutDouble :: Double -> BondPut t+    bondPutString :: Utf8 -> BondPut t+    bondPutWString :: Utf16 -> BondPut t+    bondPutBlob :: Blob -> BondPut t+    bondPutList :: BondType a => [a] -> BondPut t+    bondPutVector :: BondType a => V.Vector a -> BondPut t+    bondPutHashSet :: BondType a => H.HashSet a -> BondPut t+    bondPutSet :: BondType a => S.Set a -> BondPut t+    bondPutMap :: (BondType k, BondType v) => M.Map k v -> BondPut t+    bondPutNullable :: BondType a => Maybe a -> BondPut t+    bondPutBonded :: BondStruct a => Bonded a -> BondPut t++    bondGetBool :: BondGet t Bool+    bondGetUInt8 :: BondGet t Word8+    bondGetUInt16 :: BondGet t Word16+    bondGetUInt32 :: BondGet t Word32+    bondGetUInt64 :: BondGet t Word64+    bondGetInt8 :: BondGet t Int8+    bondGetInt16 :: BondGet t Int16+    bondGetInt32 :: BondGet t Int32+    bondGetInt64 :: BondGet t Int64+    bondGetFloat :: BondGet t Float+    bondGetDouble :: BondGet t Double+    bondGetString :: BondGet t Utf8+    bondGetWString :: BondGet t Utf16+    bondGetBlob :: BondGet t Blob+    bondGetList :: BondType a => BondGet t [a]+    bondGetVector :: BondType a => BondGet t (V.Vector a)+    bondGetHashSet :: (Eq a, Hashable a, BondType a) => BondGet t (H.HashSet a)+    bondGetSet :: (Ord a, BondType a) => BondGet t (S.Set a)+    bondGetMap :: (Ord k, BondType k, BondType v) => BondGet t (M.Map k v)+    bondGetNullable :: BondType a => BondGet t (Maybe a)+    bondGetDefNothing :: BondType a => BondGet t (Maybe a)+    bondGetBonded :: BondStruct a => BondGet t (Bonded a)++instance BondType Float where+    bondGet = bondGetFloat+    bondPut = bondPutFloat+    getName _ = "float"+    getQualifiedName _ = "float"+    getElementType _ = ElementFloat++instance BondType Double where+    bondGet = bondGetDouble+    bondPut = bondPutDouble+    getName _ = "double"+    getQualifiedName _ = "double"+    getElementType _ = ElementDouble++instance BondType Bool where+    bondGet = bondGetBool+    bondPut = bondPutBool+    getName _ = "bool"+    getQualifiedName _ = "bool"+    getElementType _ = ElementBool++instance BondType Int8 where+    bondGet = bondGetInt8+    bondPut = bondPutInt8+    getName _ = "int8"+    getQualifiedName _ = "int8"+    getElementType _ = ElementInt8++instance BondType Int16 where+    bondGet = bondGetInt16+    bondPut = bondPutInt16+    getName _ = "int16"+    getQualifiedName _ = "int16"+    getElementType _ = ElementInt16++instance BondType Int32 where+    bondGet = bondGetInt32+    bondPut = bondPutInt32+    getName _ = "int32"+    getQualifiedName _ = "int32"+    getElementType _ = ElementInt32++instance BondType Int64 where+    bondGet = bondGetInt64+    bondPut = bondPutInt64+    getName _ = "int64"+    getQualifiedName _ = "int64"+    getElementType _ = ElementInt64++instance BondType Word8 where+    bondGet = bondGetUInt8+    bondPut = bondPutUInt8+    getName _ = "uint8"+    getQualifiedName _ = "uint8"+    getElementType _ = ElementUInt8++instance BondType Word16 where+    bondGet = bondGetUInt16+    bondPut = bondPutUInt16+    getName _ = "uint16"+    getQualifiedName _ = "uint16"+    getElementType _ = ElementUInt16++instance BondType Word32 where+    bondGet = bondGetUInt32+    bondPut = bondPutUInt32+    getName _ = "uint32"+    getQualifiedName _ = "uint32"+    getElementType _ = ElementUInt32++instance BondType Word64 where+    bondGet = bondGetUInt64+    bondPut = bondPutUInt64+    getName _ = "uint64"+    getQualifiedName _ = "uint64"+    getElementType _ = ElementUInt64++instance BondType Utf8 where+    bondGet = bondGetString+    bondPut = bondPutString+    getName _ = "string"+    getQualifiedName _ = "string"+    getElementType _ = ElementString++instance BondType Utf16 where+    bondGet = bondGetWString+    bondPut = bondPutWString+    getName _ = "wstring"+    getQualifiedName _ = "wstring"+    getElementType _ = ElementWString++instance BondType Blob where+    bondGet = bondGetBlob+    bondPut = bondPutBlob+    getName _ = "blob"+    getQualifiedName _ = "blob"+    getElementType _ = ElementList ElementInt8++instance BondType a => BondType [a] where+    bondGet = bondGetList+    bondPut = bondPutList+    getName _ = makeGenericName "list" [getName (Proxy :: Proxy a)]+    getQualifiedName _ = makeGenericName "list" [getQualifiedName (Proxy :: Proxy a)]+    getElementType _ = ElementList $ getElementType (Proxy :: Proxy a)++instance BondType a => BondType (V.Vector a) where+    bondGet = bondGetVector+    bondPut = bondPutVector+    getName _ = makeGenericName "vector" [getName (Proxy :: Proxy a)]+    getQualifiedName _ = makeGenericName "vector" [getQualifiedName (Proxy :: Proxy a)]+    getElementType _ = ElementList $ getElementType (Proxy :: Proxy a)++instance (Eq a, Hashable a, BondType a) => BondType (H.HashSet a) where+    bondGet = bondGetHashSet+    bondPut = bondPutHashSet+    getName _ = makeGenericName "set" [getName (Proxy :: Proxy a)]+    getQualifiedName _ = makeGenericName "set" [getQualifiedName (Proxy :: Proxy a)]+    getElementType _ = ElementSet $ getElementType (Proxy :: Proxy a)++instance (Ord a, BondType a) => BondType (S.Set a) where+    bondGet = bondGetSet+    bondPut = bondPutSet+    getName _ = makeGenericName "set" [getName (Proxy :: Proxy a)]+    getQualifiedName _ = makeGenericName "set" [getQualifiedName (Proxy :: Proxy a)]+    getElementType _ = ElementSet $ getElementType (Proxy :: Proxy a)++instance (Ord k, BondType k, BondType v) => BondType (M.Map k v) where+    bondGet = bondGetMap+    bondPut = bondPutMap+    getName _ = makeGenericName "map" [getName (Proxy :: Proxy k), getName (Proxy :: Proxy v)]+    getQualifiedName _ = makeGenericName "map"+                            [ getQualifiedName (Proxy :: Proxy k)+                            , getQualifiedName (Proxy :: Proxy v)+                            ]+    getElementType _ = ElementMap (getElementType (Proxy :: Proxy k)) (getElementType (Proxy :: Proxy v))++instance BondStruct a => BondType (Bonded a) where+    bondGet = bondGetBonded+    bondPut = bondPutBonded+    getName _ = makeGenericName "bonded" [getName (Proxy :: Proxy a)]+    getQualifiedName _ = makeGenericName "bonded" [getQualifiedName (Proxy :: Proxy a)]+    getElementType _ = ElementBonded $ getSchema (Proxy :: Proxy a)++instance BondType a => BondType (Maybe a) where+    bondGet = bondGetNullable+    bondPut = bondPutNullable+    getName _ = makeGenericName "nullable" [getName (Proxy :: Proxy a)]+    getQualifiedName _ = makeGenericName "nullable" [getQualifiedName (Proxy :: Proxy a)]+    getElementType _ = ElementList $ getElementType (Proxy :: Proxy a)
+ src/Data/Bond/Internal/Protocol.hs-boot view
@@ -0,0 +1,4 @@+module Data.Bond.Internal.Protocol where++class BondType a+class BondStruct a
+ src/Data/Bond/Internal/SchemaOps.hs view
@@ -0,0 +1,426 @@+{-# LANGUAGE FlexibleContexts #-}+module Data.Bond.Internal.SchemaOps where++import Data.Bond.Struct+import Data.Bond.TypedSchema+import Data.Bond.Types+import Data.Bond.Internal.Default+import Data.Bond.Internal.OrdinalSet+import Data.Bond.Internal.SchemaUtils+import Data.Bond.Schema.BondDataType+import Data.Bond.Schema.Metadata+import Data.Bond.Schema.Modifier+import Data.Bond.Schema.SchemaDef+import Data.Bond.Schema.Variant+import qualified Data.Bond.Schema.FieldDef as FD+import qualified Data.Bond.Schema.StructDef as SD+import qualified Data.Bond.Schema.TypeDef as TD++import Control.Applicative hiding (optional)+import Control.Arrow+import Control.Monad.State.Strict+import Control.Monad.Error+import Data.Either+import Data.List+import Data.Maybe+import Data.Typeable+import Data.Vector ((//))+import Prelude          -- ghc 7.10 workaround for Control.Applicative+import qualified Data.IntSet as IS+import qualified Data.Map.Lazy as ML+import qualified Data.Map.Strict as M+import qualified Data.Vector as V++validateSchemaDef :: MonadError String m => SchemaDef -> m ()+validateSchemaDef schema = do+    checkChain IS.empty 0+    let rootTD = root schema+    when (TD.id rootTD /= bT_STRUCT) $ throwError "root type is not struct"+    checkType rootTD+    V.mapM_ checkStruct (structs schema)+    where+    checkChain _ n | n == V.length (structs schema) = return ()+    checkChain seen n | IS.member n seen = checkChain seen (n + 1)+    checkChain seen n = do+        let step stack i = do+                when (i >= V.length (structs schema)) $ throwError $ "struct index " ++ show i ++ " out of range"+                when (IS.member i stack) $ throwError "loop in inheritance chain"+                let baseStruct = SD.base_def $ structs schema V.! i+                let newStack = IS.insert i stack+                case baseStruct of+                    Nothing -> return newStack+                    Just b -> do+                        when (TD.id b /= bT_STRUCT) $ throwError "not a struct in inheritance chain"+                        step newStack (fromIntegral $ TD.struct_def b)+        stack <- step IS.empty n+        checkChain (IS.union seen stack) (n + 1)+    checkStruct struct = do+        maybe (return ()) checkType (SD.base_def struct)+        -- FIXME check for duplicate ordinals+        V.forM_ (SD.fields struct) $ checkType . FD.typedef+    checkType t@TD.TypeDef{TD.id = typ}+        | typ == bT_BOOL = return ()+        | typ == bT_INT8 = return ()+        | typ == bT_INT16 = return ()+        | typ == bT_INT32 = return ()+        | typ == bT_INT64 = return ()+        | typ == bT_UINT8 = return ()+        | typ == bT_UINT16 = return ()+        | typ == bT_UINT32 = return ()+        | typ == bT_UINT64 = return ()+        | typ == bT_FLOAT = return ()+        | typ == bT_DOUBLE = return ()+        | typ == bT_STRING = return ()+        | typ == bT_WSTRING = return ()+        | typ == bT_LIST =+            case TD.element t of+                Nothing -> throwError "element type missing in list schema"+                Just subtype -> checkType subtype+        | typ == bT_SET =+            case TD.element t of+                Nothing -> throwError "element type missing in set schema"+                Just subtype -> checkType subtype+        | typ == bT_MAP = do+            case TD.element t of+                Nothing -> throwError "value type missing in map schema"+                Just subtype -> checkType subtype+            case TD.key t of+                Nothing -> throwError "key type missing in map schema"+                Just subtype -> checkType subtype+        | typ == bT_STRUCT = do+            let idx = fromIntegral $ TD.struct_def t+            when (idx >= V.length (structs schema)) $ throwError $ "struct index " ++ show idx ++ " out of range"+        | otherwise = throwError $ "unexpected data type " ++ bondTypeName typ++-- |Convert 'SchemaDef' to internal schema representation.+parseSchema :: SchemaDef -> Either String StructSchema+parseSchema schemadef = validateSchemaDef schemadef >> makeSchema+    where+    substructs = V.map compileStruct (structs schemadef)+    makeSchema = V.indexM substructs (fromIntegral $ TD.struct_def $ root schemadef)+    compileStruct struct =+        let meta = SD.metadata struct+            tycon = mkTyCon3 "Bond" "RuntimeSchema" (toString $ qualified_name meta)+            typerep = mkTyConApp tycon []+            requiredOrdinals = fromOrdinalVector $ V.map (Ordinal . fromIntegral . FD.id) $+                V.filter (\ f -> modifier (FD.metadata f) == required) $ SD.fields struct+            fieldMap = M.fromList $ V.toList $ V.map makeField $ SD.fields struct+         in StructSchema+            { structTag = typerep+            , structName = toText (name meta)+            , structQualifiedName = toText (qualified_name meta)+            , structAttrs = M.fromList $ map (toText *** toText) $ M.toList $ attributes meta+            , structBase = fmap (V.unsafeIndex substructs . fromIntegral . TD.struct_def) (SD.base_def struct)+            , structFields = fieldMap+            , structRequiredOrdinals = requiredOrdinals+            }+    makeField field =+        let meta = FD.metadata field+            fieldMod+                | modifier meta == optional = FieldOptional+                | modifier meta == required = FieldRequired+                | otherwise = FieldRequiredOptional+            schema = FieldSchema+                { fieldName = toText (name meta)+                , fieldAttrs = M.fromList $ map (toText *** toText) $ M.toList $ attributes meta+                , fieldModifier = fieldMod+                , fieldType = makeFieldType (FD.typedef field) (default_value $ FD.metadata field)+                }+         in (Ordinal $ FD.id field, schema)+    makeFieldType td variant+        | TD.id td == bT_BOOL = FieldBool $ defnothing (uint_value variant /= 0)+        | TD.id td == bT_INT8 = FieldInt8 $ defnothing (fromIntegral $ int_value variant)+        | TD.id td == bT_INT16 = FieldInt16 $ defnothing (fromIntegral $ int_value variant)+        | TD.id td == bT_INT32 = FieldInt32 $ defnothing (fromIntegral $ int_value variant)+        | TD.id td == bT_INT64 = FieldInt64 $ defnothing (int_value variant)+        | TD.id td == bT_UINT8 = FieldUInt8 $ defnothing (fromIntegral $ uint_value variant)+        | TD.id td == bT_UINT16 = FieldUInt16 $ defnothing (fromIntegral $ uint_value variant)+        | TD.id td == bT_UINT32 = FieldUInt32 $ defnothing (fromIntegral $ uint_value variant)+        | TD.id td == bT_UINT64 = FieldUInt64 $ defnothing (uint_value variant)+        | TD.id td == bT_FLOAT = FieldFloat $ defnothing (realToFrac $ double_value variant)+        | TD.id td == bT_DOUBLE = FieldDouble $ defnothing (double_value variant)+        | TD.id td == bT_STRING = FieldString $ defnothing (string_value variant)+        | TD.id td == bT_WSTRING = FieldWString $ defnothing (wstring_value variant)+        | TD.id td == bT_STRUCT && TD.bonded_type td = FieldBonded (defnothing ()) (V.unsafeIndex substructs $ fromIntegral $ TD.struct_def td)+        | TD.id td == bT_STRUCT = FieldStruct (defnothing ()) (V.unsafeIndex substructs $ fromIntegral $ TD.struct_def td)+        | TD.id td == bT_LIST = FieldList (defnothing ()) (makeElementType $ fromJust $ TD.element td)+        | TD.id td == bT_SET = FieldSet (defnothing ()) (makeElementType $ fromJust $ TD.element td)+        | TD.id td == bT_MAP = FieldMap (defnothing ()) (makeElementType $ fromJust $ TD.key td) (makeElementType $ fromJust $ TD.element td)+        | otherwise = error $ "internal error: schema validation missed invalid type tag " ++ show (TD.id td)+        where+        defnothing v = if nothing variant then DefaultNothing else DefaultValue v+    makeElementType td+        | TD.id td == bT_BOOL = ElementBool+        | TD.id td == bT_INT8 = ElementInt8+        | TD.id td == bT_INT16 = ElementInt16+        | TD.id td == bT_INT32 = ElementInt32+        | TD.id td == bT_INT64 = ElementInt64+        | TD.id td == bT_UINT8 = ElementUInt8+        | TD.id td == bT_UINT16 = ElementUInt16+        | TD.id td == bT_UINT32 = ElementUInt32+        | TD.id td == bT_UINT64 = ElementUInt64+        | TD.id td == bT_FLOAT = ElementFloat+        | TD.id td == bT_DOUBLE = ElementDouble+        | TD.id td == bT_STRING = ElementString+        | TD.id td == bT_WSTRING = ElementWString+        | TD.id td == bT_STRUCT && TD.bonded_type td = ElementBonded (V.unsafeIndex substructs $ fromIntegral $ TD.struct_def td)+        | TD.id td == bT_STRUCT = ElementStruct (V.unsafeIndex substructs $ fromIntegral $ TD.struct_def td)+        | TD.id td == bT_LIST = ElementList (makeElementType $ fromJust $ TD.element td)+        | TD.id td == bT_SET = ElementSet (makeElementType $ fromJust $ TD.element td)+        | TD.id td == bT_MAP = ElementMap (makeElementType $ fromJust $ TD.key td) (makeElementType $ fromJust $ TD.element td)+        | otherwise = error $ "internal error: schema validation missed invalid type tag " ++ show (TD.id td)++data SchemaState = SchemaState+    { knownStructs :: V.Vector SD.StructDef+    , structMap :: M.Map TypeRep Word16+    }++-- |Convert internal schema representation to 'SchemaDef' for storage or transfer.+assembleSchema :: StructSchema -> SchemaDef+assembleSchema schema = SchemaDef { structs = structVector, root = rootStruct }+    where+    (rootStruct, SchemaState{knownStructs = structVector}) = runState (makeStructDef schema) (SchemaState V.empty M.empty)+    makeStructDef :: StructSchema -> State SchemaState TD.TypeDef+    makeStructDef struct = do+        m <- gets structMap+        idx <- case M.lookup (structTag struct) m of+            Just i -> return i+            Nothing -> do+                vec <- gets knownStructs+                let i = V.length vec+                let vnew = V.snoc vec (error "internal error: unfinished StructDef used")+                put $ SchemaState vnew (M.insert (structTag struct) (fromIntegral i) m)+                baseTypeDef <- case structBase struct of+                    Nothing -> return Nothing+                    Just s -> Just <$> makeStructDef s+                fieldVec <- fmap V.fromList $ mapM makeFieldDef $ M.toAscList $ structFields struct+                let structDef = SD.StructDef+                        { SD.metadata = defaultValue+                            { name = fromText (structName struct)+                            , qualified_name = fromText (structQualifiedName struct)+                            , attributes = M.fromList $ map (fromText *** fromText) $ M.toList $ structAttrs struct+                            }+                        , SD.base_def = baseTypeDef+                        , SD.fields = fieldVec+                        }+                modify $ \ s -> let bigvec = knownStructs s+                                 in s{ knownStructs = bigvec // [(i, structDef)] }+                return (fromIntegral i)+        return defaultValue{ TD.struct_def = idx }+    makeFieldDef (Ordinal n, field) = do+        fieldTypeDef <- makeFieldTypeDef (fieldType field)+        return defaultValue+            { FD.metadata = defaultValue+                { name = fromText (fieldName field)+                , attributes = M.fromList $ map (fromText *** fromText) $ M.toList $ fieldAttrs field+                , modifier = case fieldModifier field of+                    FieldOptional -> optional+                    FieldRequired -> required+                    FieldRequiredOptional -> requiredOptional+                , default_value = makeDefaultValue (fieldType field)+                }+            , FD.id = n+            , FD.typedef = fieldTypeDef+            }++    makeFieldTypeDef (FieldBool _) = return defaultValue{TD.id = bT_BOOL}+    makeFieldTypeDef (FieldInt8 _) = return defaultValue{TD.id = bT_INT8}+    makeFieldTypeDef (FieldInt16 _) = return defaultValue{TD.id = bT_INT16}+    makeFieldTypeDef (FieldInt32 _) = return defaultValue{TD.id = bT_INT32}+    makeFieldTypeDef (FieldInt64 _) = return defaultValue{TD.id = bT_INT64}+    makeFieldTypeDef (FieldUInt8 _) = return defaultValue{TD.id = bT_UINT8}+    makeFieldTypeDef (FieldUInt16 _) = return defaultValue{TD.id = bT_UINT16}+    makeFieldTypeDef (FieldUInt32 _) = return defaultValue{TD.id = bT_UINT32}+    makeFieldTypeDef (FieldUInt64 _) = return defaultValue{TD.id = bT_UINT64}+    makeFieldTypeDef (FieldFloat _) = return defaultValue{TD.id = bT_FLOAT}+    makeFieldTypeDef (FieldDouble _) = return defaultValue{TD.id = bT_DOUBLE}+    makeFieldTypeDef (FieldString _) = return defaultValue{TD.id = bT_STRING}+    makeFieldTypeDef (FieldWString _) = return defaultValue{TD.id = bT_WSTRING}+    makeFieldTypeDef (FieldStruct _ substruct) = makeStructDef substruct+    makeFieldTypeDef (FieldBonded _ substruct) = do+        typeDef <- makeStructDef substruct+        return typeDef{TD.bonded_type = True}+    makeFieldTypeDef (FieldList _ element) = do+        typeDef <- makeElementTypeDef element+        return defaultValue{TD.id = bT_LIST, TD.element = Just typeDef}+    makeFieldTypeDef (FieldSet _ element) = do+        typeDef <- makeElementTypeDef element+        return defaultValue{TD.id = bT_SET, TD.element = Just typeDef}+    makeFieldTypeDef (FieldMap _ key value) = do+        keyTypeDef <- makeElementTypeDef key+        valueTypeDef <- makeElementTypeDef value+        return defaultValue+            { TD.id = bT_MAP+            , TD.element = Just valueTypeDef+            , TD.key = Just keyTypeDef+            }++    makeElementTypeDef ElementBool = return defaultValue{TD.id = bT_BOOL}+    makeElementTypeDef ElementInt8 = return defaultValue{TD.id = bT_INT8}+    makeElementTypeDef ElementInt16 = return defaultValue{TD.id = bT_INT16}+    makeElementTypeDef ElementInt32 = return defaultValue{TD.id = bT_INT32}+    makeElementTypeDef ElementInt64 = return defaultValue{TD.id = bT_INT64}+    makeElementTypeDef ElementUInt8 = return defaultValue{TD.id = bT_UINT8}+    makeElementTypeDef ElementUInt16 = return defaultValue{TD.id = bT_UINT16}+    makeElementTypeDef ElementUInt32 = return defaultValue{TD.id = bT_UINT32}+    makeElementTypeDef ElementUInt64 = return defaultValue{TD.id = bT_UINT64}+    makeElementTypeDef ElementFloat = return defaultValue{TD.id = bT_FLOAT}+    makeElementTypeDef ElementDouble = return defaultValue{TD.id = bT_DOUBLE}+    makeElementTypeDef ElementString = return defaultValue{TD.id = bT_STRING}+    makeElementTypeDef ElementWString = return defaultValue{TD.id = bT_WSTRING}+    makeElementTypeDef (ElementStruct substruct) = makeStructDef substruct+    makeElementTypeDef (ElementBonded substruct) = do+        typeDef <- makeStructDef substruct+        return typeDef{TD.bonded_type = True}+    makeElementTypeDef (ElementList element) = do+        typeDef <- makeElementTypeDef element+        return defaultValue{TD.id = bT_LIST, TD.element = Just typeDef}+    makeElementTypeDef (ElementSet element) = do+        typeDef <- makeElementTypeDef element+        return defaultValue{TD.id = bT_SET, TD.element = Just typeDef}+    makeElementTypeDef (ElementMap key value) = do+        keyTypeDef <- makeElementTypeDef key+        valueTypeDef <- makeElementTypeDef value+        return defaultValue+            { TD.id = bT_MAP+            , TD.element = Just valueTypeDef+            , TD.key = Just keyTypeDef+            }++    makeDefaultValue (FieldBool DefaultNothing) = defaultValue{nothing = True}+    makeDefaultValue (FieldInt8 DefaultNothing) = defaultValue{nothing = True}+    makeDefaultValue (FieldInt16 DefaultNothing) = defaultValue{nothing = True}+    makeDefaultValue (FieldInt32 DefaultNothing) = defaultValue{nothing = True}+    makeDefaultValue (FieldInt64 DefaultNothing) = defaultValue{nothing = True}+    makeDefaultValue (FieldUInt8 DefaultNothing) = defaultValue{nothing = True}+    makeDefaultValue (FieldUInt16 DefaultNothing) = defaultValue{nothing = True}+    makeDefaultValue (FieldUInt32 DefaultNothing) = defaultValue{nothing = True}+    makeDefaultValue (FieldUInt64 DefaultNothing) = defaultValue{nothing = True}+    makeDefaultValue (FieldFloat DefaultNothing) = defaultValue{nothing = True}+    makeDefaultValue (FieldDouble DefaultNothing) = defaultValue{nothing = True}+    makeDefaultValue (FieldString DefaultNothing) = defaultValue{nothing = True}+    makeDefaultValue (FieldWString DefaultNothing) = defaultValue{nothing = True}+    makeDefaultValue (FieldStruct DefaultNothing _) = defaultValue{nothing = True}+    makeDefaultValue (FieldBonded DefaultNothing _) = defaultValue{nothing = True}+    makeDefaultValue (FieldList DefaultNothing _) = defaultValue{nothing = True}+    makeDefaultValue (FieldSet DefaultNothing _) = defaultValue{nothing = True}+    makeDefaultValue (FieldMap DefaultNothing _ _) = defaultValue{nothing = True}+    makeDefaultValue (FieldBool (DefaultValue v)) = defaultValue{uint_value = if v then 1 else 0}+    makeDefaultValue (FieldInt8 (DefaultValue v)) = defaultValue{int_value = fromIntegral v}+    makeDefaultValue (FieldInt16 (DefaultValue v)) = defaultValue{int_value = fromIntegral v}+    makeDefaultValue (FieldInt32 (DefaultValue v)) = defaultValue{int_value = fromIntegral v}+    makeDefaultValue (FieldInt64 (DefaultValue v)) = defaultValue{int_value = v}+    makeDefaultValue (FieldUInt8 (DefaultValue v)) = defaultValue{uint_value = fromIntegral v}+    makeDefaultValue (FieldUInt16 (DefaultValue v)) = defaultValue{uint_value = fromIntegral v}+    makeDefaultValue (FieldUInt32 (DefaultValue v)) = defaultValue{uint_value = fromIntegral v}+    makeDefaultValue (FieldUInt64 (DefaultValue v)) = defaultValue{uint_value = v}+    makeDefaultValue (FieldFloat (DefaultValue v)) = defaultValue{double_value = realToFrac v}+    makeDefaultValue (FieldDouble (DefaultValue v)) = defaultValue{double_value = v}+    makeDefaultValue (FieldString (DefaultValue v)) = defaultValue{string_value = v}+    makeDefaultValue (FieldWString (DefaultValue v)) = defaultValue{wstring_value = v}+    makeDefaultValue (FieldStruct (DefaultValue ()) _) = defaultValue+    makeDefaultValue (FieldBonded (DefaultValue ()) _) = defaultValue+    makeDefaultValue (FieldList (DefaultValue ()) _) = defaultValue+    makeDefaultValue (FieldSet (DefaultValue ()) _) = defaultValue+    makeDefaultValue (FieldMap (DefaultValue ()) _ _) = defaultValue++-- |Verify that 'Struct' matches 'StructSchema' and is internally consistent.+checkStructSchema :: MonadError String m => StructSchema -> Struct -> m Struct+checkStructSchema rootSchema rootStruct = do+    when (length schemaStack > length structStack) $ throwError "schema depth is larger than struct depth"+    let shortStructStack = take (length schemaStack) structStack+    let errs = lefts $ zipWith checkStackLevel schemaStack shortStructStack+    unless (null errs) $ throwError $ intercalate "\n" errs+    return $ head shortStructStack+    where+    checkStackLevel schema struct = mapM_ (checkField struct) (M.toList $ structFields schema)+    checkField struct (fieldId, fieldInfo) = case M.lookup fieldId (fields struct) of+        Nothing -> when (fieldModifier fieldInfo /= FieldOptional) $ Left $ "non-optional field " ++ show (fieldName fieldInfo) ++ " missing"+        Just v -> checkValueType (fieldToElementType $ fieldType fieldInfo) v+    checkValueType ElementBool (BOOL _) = Right ()+    checkValueType ElementInt8 (INT8 _) = Right ()+    checkValueType ElementInt16 (INT16 _) = Right ()+    checkValueType ElementInt32 (INT32 _) = Right ()+    checkValueType ElementInt64 (INT64 _) = Right ()+    checkValueType ElementUInt8 (UINT8 _) = Right ()+    checkValueType ElementUInt16 (UINT16 _) = Right ()+    checkValueType ElementUInt32 (UINT32 _) = Right ()+    checkValueType ElementUInt64 (UINT64 _) = Right ()+    checkValueType ElementFloat (FLOAT _) = Right ()+    checkValueType ElementDouble (DOUBLE _) = Right ()+    checkValueType ElementString (STRING _) = Right ()+    checkValueType ElementWString (WSTRING _) = Right ()+    checkValueType (ElementStruct schema) (STRUCT struct) = void $ checkStructSchema schema struct+    checkValueType (ElementBonded _) (BONDED _) = Right ()+    checkValueType (ElementBonded _) (STRUCT _) = Right ()+    checkValueType (ElementList element) (LIST bt xs) = do+        let expectedbt = elementToBondDataType element+        when (bt /= expectedbt) $ Left $ "list element type " ++ bondTypeName bt ++ " does not match schema type " ++ bondTypeName expectedbt+        mapM_ (checkValueType element) xs+    checkValueType (ElementSet element) (SET bt xs) = do+        let expectedbt = elementToBondDataType element+        when (bt /= expectedbt) $ Left $ "set element type " ++ bondTypeName bt ++ " does not match schema type " ++ bondTypeName expectedbt+        mapM_ (checkValueType element) xs+    checkValueType (ElementMap key value) (MAP btkey btvalue xs) = do+        let expectedbtkey = elementToBondDataType key+        let expectedbtvalue = elementToBondDataType value+        when (btkey /= expectedbtkey) $ Left $ "map key element type " ++ bondTypeName btkey ++ " does not match schema type " ++ bondTypeName expectedbtkey+        when (btvalue /= expectedbtvalue) $ Left $ "map value element type " ++ bondTypeName btvalue ++ " does not match schema type " ++ bondTypeName expectedbtvalue+        forM_ xs $ \(k, v) -> checkValueType key k >> checkValueType value v+    checkValueType t v = Left $ "field type " ++ valueName v ++ " does not match schema type " ++ bondTypeName (elementToBondDataType t)++    structStack = let step s = case base s of+                                Nothing -> [s]+                                Just b -> s : step b+                   in step rootStruct+    schemaStack = let step s = case structBase s of+                                Nothing -> [s]+                                Just b -> s : step b+                   in step rootSchema++defaultFieldValue :: FieldTypeInfo -> Maybe Value+defaultFieldValue (FieldBool DefaultNothing) = Nothing+defaultFieldValue (FieldInt8 DefaultNothing) = Nothing+defaultFieldValue (FieldInt16 DefaultNothing) = Nothing+defaultFieldValue (FieldInt32 DefaultNothing) = Nothing+defaultFieldValue (FieldInt64 DefaultNothing) = Nothing+defaultFieldValue (FieldUInt8 DefaultNothing) = Nothing+defaultFieldValue (FieldUInt16 DefaultNothing) = Nothing+defaultFieldValue (FieldUInt32 DefaultNothing) = Nothing+defaultFieldValue (FieldUInt64 DefaultNothing) = Nothing+defaultFieldValue (FieldFloat DefaultNothing) = Nothing+defaultFieldValue (FieldDouble DefaultNothing) = Nothing+defaultFieldValue (FieldString DefaultNothing) = Nothing+defaultFieldValue (FieldWString DefaultNothing) = Nothing+defaultFieldValue (FieldStruct DefaultNothing _) = Nothing+defaultFieldValue (FieldBonded DefaultNothing _) = Nothing+defaultFieldValue (FieldList DefaultNothing _) = Nothing+defaultFieldValue (FieldSet DefaultNothing _) = Nothing+defaultFieldValue (FieldMap DefaultNothing _ _) = Nothing+defaultFieldValue (FieldBool (DefaultValue v)) = Just (BOOL v)+defaultFieldValue (FieldInt8 (DefaultValue v)) = Just (INT8 v)+defaultFieldValue (FieldInt16 (DefaultValue v)) = Just (INT16 v)+defaultFieldValue (FieldInt32 (DefaultValue v)) = Just (INT32 v)+defaultFieldValue (FieldInt64 (DefaultValue v)) = Just (INT64 v)+defaultFieldValue (FieldUInt8 (DefaultValue v)) = Just (UINT8 v)+defaultFieldValue (FieldUInt16 (DefaultValue v)) = Just (UINT16 v)+defaultFieldValue (FieldUInt32 (DefaultValue v)) = Just (UINT32 v)+defaultFieldValue (FieldUInt64 (DefaultValue v)) = Just (UINT64 v)+defaultFieldValue (FieldFloat (DefaultValue v)) = Just (FLOAT v)+defaultFieldValue (FieldDouble (DefaultValue v)) = Just (DOUBLE v)+defaultFieldValue (FieldString (DefaultValue v)) = Just (STRING v)+defaultFieldValue (FieldWString (DefaultValue v)) = Just (WSTRING v)+defaultFieldValue (FieldStruct (DefaultValue ()) schema) = Just (STRUCT $ defaultStruct schema)+defaultFieldValue (FieldBonded (DefaultValue ()) schema) = Just (BONDED $ BondedObject $ defaultStruct schema)+defaultFieldValue (FieldList (DefaultValue ()) et) = Just (LIST (elementToBondDataType et) [])+defaultFieldValue (FieldSet (DefaultValue ()) et) = Just (SET (elementToBondDataType et) [])+defaultFieldValue (FieldMap (DefaultValue ()) kt vt) = Just (MAP (elementToBondDataType kt) (elementToBondDataType vt) [])++-- |Create minimal valid 'Struct' representing given @schema@+defaultStruct :: StructSchema -> Struct+defaultStruct schema = Struct (defaultStruct <$> structBase schema) requiredFields+    where+    requiredFields = ML.mapMaybe makeDefault $ structFields schema+    makeDefault field+        | fieldModifier field == FieldOptional = Nothing+        | otherwise = defaultFieldValue $ fieldType field
+ src/Data/Bond/Internal/SchemaUtils.hs view
@@ -0,0 +1,68 @@+module Data.Bond.Internal.SchemaUtils where++import Data.Bond.TypedSchema+import Data.Bond.Types+import Data.Bond.Internal.Protocol+import Data.Bond.Schema.BondDataType++import Data.Proxy+import Data.Text+import qualified Data.Map.Strict as M++bondTypeName :: BondDataType -> String+bondTypeName t+    | t == bT_BOOL = "bool"+    | t == bT_UINT8 = "uint8"+    | t == bT_UINT16 = "uint16"+    | t == bT_UINT32 = "uint32"+    | t == bT_UINT64 = "uint64"+    | t == bT_FLOAT = "float"+    | t == bT_DOUBLE = "double"+    | t == bT_STRING = "string"+    | t == bT_STRUCT = "struct"+    | t == bT_LIST = "list"+    | t == bT_SET = "set"+    | t == bT_MAP = "map"+    | t == bT_INT8 = "int8"+    | t == bT_INT16 = "int16"+    | t == bT_INT32 = "int32"+    | t == bT_INT64 = "int64"+    | t == bT_WSTRING = "wstring"+    | otherwise = let BondDataType v = t in "tag " ++ show v++elementToBondDataType :: ElementTypeInfo -> BondDataType+elementToBondDataType ElementBool = bT_BOOL+elementToBondDataType ElementInt8 = bT_INT8+elementToBondDataType ElementInt16 = bT_INT16+elementToBondDataType ElementInt32 = bT_INT32+elementToBondDataType ElementInt64 = bT_INT64+elementToBondDataType ElementUInt8 = bT_UINT8+elementToBondDataType ElementUInt16 = bT_UINT16+elementToBondDataType ElementUInt32 = bT_UINT32+elementToBondDataType ElementUInt64 = bT_UINT64+elementToBondDataType ElementFloat = bT_FLOAT+elementToBondDataType ElementDouble = bT_DOUBLE+elementToBondDataType ElementString = bT_STRING+elementToBondDataType ElementWString = bT_WSTRING+elementToBondDataType (ElementStruct _) = bT_STRUCT+elementToBondDataType (ElementBonded _) = bT_STRUCT+elementToBondDataType (ElementList _) = bT_LIST+elementToBondDataType (ElementSet _) = bT_SET+elementToBondDataType (ElementMap _ _) = bT_MAP++getWireType :: BondType a => Proxy a -> BondDataType+getWireType = elementToBondDataType . getElementType++isOptionalField :: BondStruct a => Proxy a -> Ordinal -> Bool+isOptionalField p n =+    let schema = getSchema p+        field = M.lookup n (structFields schema)+     in case field of+            Nothing -> True -- unknown fields presumed optional+            Just f -> fieldModifier f == FieldOptional++getFieldName :: StructSchema -> Ordinal -> String+getFieldName schema ordinal =+    case M.lookup ordinal (structFields schema) of+        Nothing -> show ordinal+        Just f -> unpack (fieldName f)
+ src/Data/Bond/Internal/SimpleBinaryProto.hs view
@@ -0,0 +1,382 @@+{-# Language ScopedTypeVariables, TypeFamilies, FlexibleContexts, MultiWayIf #-}+module Data.Bond.Internal.SimpleBinaryProto (+        SimpleBinaryProto(..),+        SimpleBinaryV1Proto(..)+    ) where++import Data.Bond.Proto+import Data.Bond.Struct+import Data.Bond.TypedSchema+import Data.Bond.Types+import Data.Bond.Internal.BinaryUtils+import Data.Bond.Internal.Cast+import Data.Bond.Internal.CompactBinaryProto+import Data.Bond.Internal.Protocol+import Data.Bond.Internal.ProtoUtils+import Data.Bond.Internal.SchemaOps+import Data.Bond.Internal.SchemaUtils++import Data.Bond.Schema.ProtocolType++import Control.Applicative+import Control.Monad.Error+import Data.List+import Data.Maybe+import Prelude          -- ghc 7.10 workaround for Control.Applicative++import qualified Data.Binary.Get as B+import qualified Data.Binary.Put as B+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.HashSet as H+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import qualified Data.Traversable as T -- XXX lts-2+import qualified Data.Vector as V++{-|+A binary, untagged protocol which is a good choice for storage scenarios as it offers potential for big saving on payload size. Because Simple is an untagged protocol, it requires that the payload schema is available during deserialization.+Version 2 of Simple Protocol uses variable integer encoding for string and container lengths, resulting in more compact payload.+-}+data SimpleBinaryProto = SimpleBinaryProto+-- |A binary, untagged protocol which is a good choice for storage scenarios as it offers potential for big saving on payload size. Because Simple is an untagged protocol, it requires that the payload schema is available during deserialization.+data SimpleBinaryV1Proto = SimpleBinaryV1Proto++class Protocol t => SimpleProtocol t where+    getListHeader :: BondGet t Int+    putListHeader :: Int -> BondPut t++instance BondProto SimpleBinaryProto where+    bondRead = decode+    bondWrite = encode+    bondReadWithSchema = decodeWithSchema+    bondWriteWithSchema = encodeWithSchema+    protoSig _ = protoHeader sIMPLE_PROTOCOL 2++instance Protocol SimpleBinaryProto where+    type ReaderM SimpleBinaryProto = B.Get+    type WriterM SimpleBinaryProto = ErrorT String B.PutM++    bondGetStruct = bondStructGetUntagged+    bondGetBaseStruct = bondStructGetUntagged++    bondGetBool = do+        v <- getWord8+        return $ v /= 0+    bondGetUInt8 = getWord8+    bondGetUInt16 = getWord16le+    bondGetUInt32 = getWord32le+    bondGetUInt64 = getWord64le+    bondGetInt8 = fromIntegral <$> getWord8+    bondGetInt16 = fromIntegral <$> getWord16le+    bondGetInt32 = fromIntegral <$> getWord32le+    bondGetInt64 = fromIntegral <$> getWord64le+    bondGetFloat = wordToFloat <$> getWord32le+    bondGetDouble = wordToDouble <$> getWord64le+    bondGetString = do+        n <- getVarInt+        Utf8 <$> getByteString n+    bondGetWString = do+        n <- getVarInt+        Utf16 <$> getByteString (n * 2)+    bondGetBlob = do+        n <- getVarInt+        Blob <$> getByteString n+    bondGetDefNothing = Just <$> bondGet+    bondGetList = do+        n <- getVarInt+        replicateM n bondGet+    bondGetHashSet = H.fromList <$> bondGetList+    bondGetSet = S.fromList <$> bondGetList+    bondGetMap = do+        n <- getVarInt+        fmap M.fromList $ replicateM n $ liftM2 (,) bondGet bondGet+    bondGetVector = do+        n <- getVarInt+        V.replicateM n bondGet+    bondGetNullable = do+        v <- bondGetList+        case v of+            [] -> return Nothing+            [x] -> return (Just x)+            _ -> fail $ "list of length " ++ show (length v) ++ " where nullable expected"+    bondGetBonded = do+        size <- getWord32le+        bs <- getLazyByteString (fromIntegral size)+        return $ BondedStream bs++    bondPutStruct = bondStructPut+    bondPutBaseStruct = bondStructPut+    bondPutField _ _ = bondPut+    bondPutDefNothingField _ _ Nothing = throwError "can't save empty \"default nothing\" field with untagged protocol"+    bondPutDefNothingField _ _ (Just v) = bondPut v++    bondPutBool True = putWord8 1+    bondPutBool False = putWord8 0+    bondPutUInt8 = putWord8+    bondPutUInt16 = putWord16le+    bondPutUInt32 = putWord32le+    bondPutUInt64 = putWord64le+    bondPutInt8 = putWord8 . fromIntegral+    bondPutInt16 = putWord16le . fromIntegral+    bondPutInt32 = putWord32le . fromIntegral+    bondPutInt64 = putWord64le . fromIntegral+    bondPutFloat = putWord32le . floatToWord+    bondPutDouble = putWord64le . doubleToWord+    bondPutString (Utf8 s) = do+        putVarInt $ BS.length s+        putByteString s+    bondPutWString (Utf16 s) = do+        putVarInt $ BS.length s `div` 2+        putByteString s+    bondPutList xs = do+        putVarInt $ length xs+        mapM_ bondPut xs+    bondPutNullable = bondPutList . maybeToList+    bondPutHashSet = bondPutList . H.toList+    bondPutSet = bondPutList . S.toList+    bondPutMap m = do+        putVarInt $ M.size m+        forM_ (M.toList m) $ \(k, v) -> do+            bondPut k+            bondPut v+    bondPutVector xs = do+        putVarInt $ V.length xs+        V.mapM_ bondPut xs+    bondPutBlob (Blob b) = do+        putVarInt $ BS.length b+        putByteString b+    bondPutBonded (BondedObject v) = do+        stream <- either throwError return $ bondMarshal CompactBinaryProto v+        putWord32le $ fromIntegral $ BL.length stream+        putLazyByteString stream+    bondPutBonded (BondedStream stream) = do+        putWord32le $ fromIntegral $ BL.length stream+        putLazyByteString stream++instance SimpleProtocol SimpleBinaryProto where+    getListHeader = getVarInt+    putListHeader = putVarInt++instance BondProto SimpleBinaryV1Proto where+    bondRead = decode+    bondWrite = encode+    bondReadWithSchema = decodeWithSchema+    bondWriteWithSchema = encodeWithSchema+    protoSig _ = protoHeader sIMPLE_PROTOCOL 1++instance Protocol SimpleBinaryV1Proto where+    type ReaderM SimpleBinaryV1Proto = B.Get+    type WriterM SimpleBinaryV1Proto = ErrorT String B.PutM++    bondGetStruct = bondStructGetUntagged+    bondGetBaseStruct = bondStructGetUntagged++    bondGetBool = do+        v <- getWord8+        return $ v /= 0+    bondGetUInt8 = getWord8+    bondGetUInt16 = getWord16le+    bondGetUInt32 = getWord32le+    bondGetUInt64 = getWord64le+    bondGetInt8 = fromIntegral <$> getWord8+    bondGetInt16 = fromIntegral <$> getWord16le+    bondGetInt32 = fromIntegral <$> getWord32le+    bondGetInt64 = fromIntegral <$> getWord64le+    bondGetFloat = wordToFloat <$> getWord32le+    bondGetDouble = wordToDouble <$> getWord64le+    bondGetString = do+        n <- fromIntegral <$> getWord32le+        Utf8 <$> getByteString n+    bondGetWString = do+        n <- fromIntegral <$> getWord32le+        Utf16 <$> getByteString (n * 2)+    bondGetBlob = do+        n <- fromIntegral <$> getWord32le+        Blob <$> getByteString n+    bondGetDefNothing = Just <$> bondGet+    bondGetList = do+        n <- fromIntegral <$> getWord32le+        replicateM n bondGet+    bondGetHashSet = H.fromList <$> bondGetList+    bondGetSet = S.fromList <$> bondGetList+    bondGetMap = do+        n <- fromIntegral <$> getWord32le+        fmap M.fromList $ replicateM n $ liftM2 (,) bondGet bondGet+    bondGetVector = do+        n <- fromIntegral <$> getWord32le+        V.replicateM n bondGet+    bondGetNullable = do+        v <- bondGetList+        case v of+            [] -> return Nothing+            [x] -> return (Just x)+            _ -> fail $ "list of length " ++ show (length v) ++ " where nullable expected"+    bondGetBonded = do+        size <- getWord32le+        bs <- getLazyByteString (fromIntegral size)+        return $ BondedStream bs++    bondPutStruct = bondStructPut+    bondPutBaseStruct = bondStructPut+    bondPutField _ _ = bondPut+    bondPutDefNothingField _ _ Nothing = throwError "can't save empty \"default nothing\" field with untagged protocol"+    bondPutDefNothingField _ _ (Just v) = bondPut v++    bondPutBool True = putWord8 1+    bondPutBool False = putWord8 0+    bondPutUInt8 = putWord8+    bondPutUInt16 = putWord16le+    bondPutUInt32 = putWord32le+    bondPutUInt64 = putWord64le+    bondPutInt8 = putWord8 . fromIntegral+    bondPutInt16 = putWord16le . fromIntegral+    bondPutInt32 = putWord32le . fromIntegral+    bondPutInt64 = putWord64le . fromIntegral+    bondPutFloat = putWord32le . floatToWord+    bondPutDouble = putWord64le . doubleToWord+    bondPutString (Utf8 s) = do+        putWord32le $ fromIntegral $ BS.length s+        putByteString s+    bondPutWString (Utf16 s) = do+        putWord32le $ fromIntegral $ BS.length s `div` 2+        putByteString s+    bondPutList xs = do+        putWord32le $ fromIntegral $ length xs+        mapM_ bondPut xs+    bondPutNullable = bondPutList . maybeToList+    bondPutHashSet = bondPutList . H.toList+    bondPutSet = bondPutList . S.toList+    bondPutMap m = do+        putWord32le $ fromIntegral $ M.size m+        forM_ (M.toList m) $ \(k, v) -> do+            bondPut k+            bondPut v+    bondPutVector xs = do+        putWord32le $ fromIntegral $ V.length xs+        V.mapM_ bondPut xs+    bondPutBlob (Blob b) = do+        putWord32le $ fromIntegral $ BS.length b+        putByteString b+    bondPutBonded (BondedObject v) = do+        stream <- either throwError return $ bondMarshal CompactBinaryProto v+        putWord32le $ fromIntegral $ BL.length stream+        putLazyByteString stream+    bondPutBonded (BondedStream s) = do+        putWord32le $ fromIntegral $ BL.length s+        putLazyByteString s++instance SimpleProtocol SimpleBinaryV1Proto where+    getListHeader = fromIntegral <$> getWord32le+    putListHeader = putWord32le . fromIntegral++decode :: forall a t. (BondStruct a, Protocol t, ReaderM t ~ B.Get) => t -> BL.ByteString -> Either String a+decode _ s =+    let BondGet g = bondGetStruct :: BondGet t a+     in case B.runGetOrFail g s of+            Left (_, used, msg) -> Left $ "parse error at " ++ show used ++ ": " ++ msg+            Right (rest, used, _) | not (BL.null rest) -> Left $ "incomplete parse, used " ++ show used ++ ", left " ++ show (BL.length rest)+            Right (_, _, a) -> Right a++encode :: forall a t. (BondStruct a, Protocol t, WriterM t ~ ErrorT String B.PutM) => t -> a -> Either String BL.ByteString+encode _ a =+    let BondPut g = bondPutStruct a :: BondPut t+     in tryPut g++decodeWithSchema :: forall t. (SimpleProtocol t, ReaderM t ~ B.Get) => t -> StructSchema -> BL.ByteString -> Either String Struct+decodeWithSchema _ rootSchema bs =+    case B.runGetOrFail reader bs of+        Left (_, used, msg) -> Left $ "parse error at " ++ show used ++ ": " ++ msg+        Right (rest, used, _) | not (BL.null rest) -> Left $ "incomplete parse, used " ++ show used ++ ", left " ++ show (BL.length rest)+        Right (_, _, a) -> Right a+    where+    BondGet reader = readStruct rootSchema+    readStruct :: StructSchema -> BondGet t Struct+    readStruct schema = do+        parent <- case structBase schema of+            Nothing -> return Nothing+            Just baseSchema -> Just <$> readStruct baseSchema+        fs <- T.mapM (readField . fieldType) (structFields schema)+        return $ Struct parent fs+    readField = readValue . fieldToElementType++    readValue ElementBool = BOOL <$> bondGetBool+    readValue ElementUInt8 = UINT8 <$> bondGetUInt8+    readValue ElementUInt16 = UINT16 <$> bondGetUInt16+    readValue ElementUInt32 = UINT32 <$> bondGetUInt32+    readValue ElementUInt64 = UINT64 <$> bondGetUInt64+    readValue ElementInt8 = INT8 <$> bondGetInt8+    readValue ElementInt16 = INT16 <$> bondGetInt16+    readValue ElementInt32 = INT32 <$> bondGetInt32+    readValue ElementInt64 = INT64 <$> bondGetInt64+    readValue ElementFloat = FLOAT <$> bondGetFloat+    readValue ElementDouble = DOUBLE <$> bondGetDouble+    readValue ElementString = STRING <$> bondGetString+    readValue ElementWString = WSTRING <$> bondGetWString+    readValue (ElementBonded _) = do+        n <- getWord32le+        BONDED . BondedStream <$> getLazyByteString (fromIntegral n)+    readValue (ElementStruct schema) = STRUCT <$> readStruct schema+    readValue (ElementList element) = do+        n <- getListHeader+        LIST (elementToBondDataType element) <$> replicateM n (readValue element)+    readValue (ElementSet element) = do+        n <- getListHeader+        SET (elementToBondDataType element) <$> replicateM n (readValue element)+    readValue (ElementMap key value) = do+        n <- getListHeader+        fmap (MAP (elementToBondDataType key) (elementToBondDataType value)) $ replicateM n $ do+            k <- readValue key+            v <- readValue value+            return (k, v)++encodeWithSchema :: forall t. (SimpleProtocol t, WriterM t ~ ErrorT String B.PutM) => t -> StructSchema -> Struct -> Either String BL.ByteString+encodeWithSchema _ rootSchema s = do+    struct <- checkStructSchema rootSchema s+    let BondPut writer = putStruct rootSchema struct+    tryPut writer+    where+    putStruct :: StructSchema -> Struct -> BondPut t+    putStruct schema struct = do+        case (structBase schema, base struct) of +            (Nothing, Nothing) -> return ()+            (Just baseSchema, Just baseStruct) -> putStruct baseSchema baseStruct+            _ -> error "internal error: inheritance chain in schema do not match one in struct"+        mapM_ (putField $ fields struct) $ M.toAscList $ structFields schema+    putField fieldmap (fieldId, fieldInfo) = do+        value <- maybe (getDefault $ fieldType fieldInfo) return $ M.lookup fieldId fieldmap+        putValue (fieldToElementType $ fieldType fieldInfo) value++    getDefault = maybe (throwError "can't serialize default nothing with SimpleBinary protocol") return . defaultFieldValue++    putValue ElementBool (BOOL b) = bondPutBool b+    putValue ElementInt8 (INT8 v) = bondPutInt8 v+    putValue ElementInt16 (INT16 v) = bondPutInt16 v+    putValue ElementInt32 (INT32 v) = bondPutInt32 v+    putValue ElementInt64 (INT64 v) = bondPutInt64 v+    putValue ElementUInt8 (UINT8 v) = bondPutUInt8 v+    putValue ElementUInt16 (UINT16 v) = bondPutUInt16 v+    putValue ElementUInt32 (UINT32 v) = bondPutUInt32 v+    putValue ElementUInt64 (UINT64 v) = bondPutUInt64 v+    putValue ElementFloat (FLOAT v) = bondPutFloat v+    putValue ElementDouble (DOUBLE v) = bondPutDouble v+    putValue ElementString (STRING v) = bondPutString v+    putValue ElementWString (WSTRING v) = bondPutWString v+    putValue (ElementStruct schema) (STRUCT v) = putStruct schema v+    putValue (ElementList element) (LIST _ xs) = do+        putListHeader $ length xs+        mapM_ (putValue element) xs+    putValue (ElementSet element) (SET _ xs) = do+        putListHeader $ length xs+        mapM_ (putValue element) xs+    putValue (ElementMap key value) (MAP _ _ xs) = do+        putListHeader $ length xs+        forM_ xs $ \ (k, v) -> putValue key k >> putValue value v+    putValue ElementBonded{} (BONDED (BondedStream stream)) = do+        putWord32le $ fromIntegral $ BL.length stream+        putLazyByteString stream+    putValue (ElementBonded schema) (BONDED (BondedObject struct)) = do+        stream <- either throwError return $ bondMarshalWithSchema CompactBinaryProto schema struct+        putWord32le $ fromIntegral $ BL.length stream+        putLazyByteString stream+    putValue _ _ = error "internal error: schema type do not match value type"
+ src/Data/Bond/Internal/SimpleBinaryProto.hs-boot view
@@ -0,0 +1,9 @@+module Data.Bond.Internal.SimpleBinaryProto where++import Data.Bond.Proto++data SimpleBinaryProto = SimpleBinaryProto+data SimpleBinaryV1Proto = SimpleBinaryV1Proto++instance BondProto SimpleBinaryProto+instance BondProto SimpleBinaryV1Proto
+ src/Data/Bond/Internal/TaggedProtocol.hs view
@@ -0,0 +1,211 @@+{-# Language ScopedTypeVariables, MultiWayIf, TypeFamilies, FlexibleContexts #-}+module Data.Bond.Internal.TaggedProtocol where++import Data.Bond.Schema.BondDataType++import Data.Bond.Struct+import Data.Bond.TypedSchema+import Data.Bond.Types+import Data.Bond.Internal.BinaryUtils+import Data.Bond.Internal.Default+import Data.Bond.Internal.OrdinalSet+import Data.Bond.Internal.Protocol+import Data.Bond.Internal.SchemaOps+import Data.Bond.Internal.SchemaUtils++import Control.Applicative+import Control.Monad+import Control.Monad.Error+import Data.Bits+import Data.Proxy+import Prelude          -- ghc 7.10 workaround for Control.Applicative+import qualified Data.Binary.Get as B+import qualified Data.Binary.Put as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Map as M+import qualified Data.Map.Strict as MS++data StructLevel = TopLevelStruct | BaseStruct+    deriving (Show, Eq)++class Protocol t => TaggedProtocol t where+    getFieldHeader :: BondGet t (BondDataType, Ordinal)+    getListHeader :: BondGet t (BondDataType, Int)+    getTaggedStruct :: BondGet t Struct+    putFieldHeader :: BondDataType -> Ordinal -> BondPut t+    putListHeader :: (Integral a, FiniteBits a) => BondDataType -> a -> BondPut t+    putTaggedStruct :: MonadError String (BondPutM t) => Struct -> BondPut t+    skipStruct :: BondGet t ()+    skipRestOfStruct :: BondGet t ()+    skipType :: TaggedProtocol t => BondDataType -> BondGet t ()++getStruct :: forall a t. (Functor (ReaderM t), Monad (ReaderM t), TaggedProtocol t, BondStruct a) => StructLevel -> BondGet t a+getStruct level = do+    let schema = getSchema (Proxy :: Proxy a)+    let fieldsMap = structFields schema+    b <- bondStructGetBase defaultValue+    -- iterate over stream, update fields+    let readField wiretype ordinal s =+            if M.member ordinal fieldsMap+                then bondStructGetField ordinal s+                else do+                    skipType wiretype -- unknown field, ignore it+                    return s+    let loop (s, ords) = do+            (wiretype, ordinal) <- getFieldHeader+            if | wiretype == bT_STOP && level == BaseStruct -> fail "BT_STOP found where BT_STOP_BASE expected"+               | wiretype == bT_STOP && level == TopLevelStruct -> return (s, ords)+               | wiretype == bT_STOP_BASE && level == BaseStruct -> return (s, ords)+               | wiretype == bT_STOP_BASE && level == TopLevelStruct -> skipRestOfStruct >> return (s, ords)+               | otherwise -> do+                    s' <- readField wiretype ordinal s+                    loop (s', deleteOrdinal ordinal ords)+    (value, notRead) <- loop (b, structRequiredOrdinals schema)+    unless (isEmptySet notRead) $ fail $ "required fields not read: " ++ show (map (getFieldName schema) $ toOrdinalList notRead)+    return value++putStruct :: (WriterM t ~ ErrorT String B.PutM, TaggedProtocol t, BondStruct a) => StructLevel -> a -> BondPut t+putStruct level a = do+    bondStructPut a+    case level of+        TopLevelStruct -> putTag bT_STOP+        BaseStruct -> putTag bT_STOP_BASE++putBaseStruct :: (WriterM t ~ ErrorT String B.PutM, TaggedProtocol t, BondStruct a) => a -> BondPut t+putBaseStruct = putStruct BaseStruct++putField :: forall a b t. (Monad (BondPutM t), TaggedProtocol t, BondType a, BondStruct b) => Proxy b -> Ordinal -> a -> BondPut t+putField p ordinal value = do+    let tag = getWireType (Proxy :: Proxy a)+    let info = M.findWithDefault (error "internal error: unknown field ordinal") ordinal (structFields $ getSchema p)+    let needToSave = not (equalToDefault (fieldType info) value) || fieldModifier info /= FieldOptional+    when needToSave $ do+        putFieldHeader tag ordinal+        bondPut value++putTag :: WriterM t ~ ErrorT String B.PutM => BondDataType -> BondPut t+putTag = putWord8 . fromIntegral . fromEnum++binaryDecode :: forall a t. (ReaderM t ~ B.Get, BondStruct a, Protocol t) => t -> BL.ByteString -> Either String a+binaryDecode _ s =+    let BondGet g = bondGetStruct :: BondGet t a+     in case B.runGetOrFail g s of+            Left (_, used, msg) -> Left $ "parse error at " ++ show used ++ ": " ++ msg+            Right (rest, used, _) | not (BL.null rest) -> Left $ "incomplete parse, used " ++ show used ++ ", left " ++ show (BL.length rest)+            Right (_, _, a) -> Right a++binaryEncode :: forall a t. (WriterM t ~ ErrorT String B.PutM, BondStruct a, Protocol t) => t -> a -> Either String BL.ByteString+binaryEncode _ a =+    let BondPut g = bondPutStruct a :: BondPut t+     in tryPut g++getTaggedData :: forall t. (ReaderM t ~ B.Get, TaggedProtocol t) => BondGet t Struct+getTaggedData = fieldLoop $ Struct Nothing M.empty+    where+    getValue :: BondDataType -> BondGet t Value+    getValue t =+        if | t == bT_BOOL -> BOOL <$> bondGetBool+           | t == bT_UINT8 -> UINT8 <$> bondGetUInt8+           | t == bT_UINT16 -> UINT16 <$> bondGetUInt16+           | t == bT_UINT32 -> UINT32 <$> bondGetUInt32+           | t == bT_UINT64 -> UINT64 <$> bondGetUInt64+           | t == bT_FLOAT -> FLOAT <$> bondGetFloat+           | t == bT_DOUBLE -> DOUBLE <$> bondGetDouble+           | t == bT_STRING -> STRING <$> bondGetString+           | t == bT_STRUCT -> STRUCT <$> getTaggedStruct+           | t == bT_LIST -> do+                (td, n) <- getListHeader+                LIST td <$> replicateM n (getValue td)+           | t == bT_SET -> do+                (td, n) <- getListHeader+                SET td <$> replicateM n (getValue td)+           | t == bT_MAP -> do+                tk <- BondDataType . fromIntegral <$> getWord8+                tv <- BondDataType . fromIntegral <$> getWord8+                n <- getVarInt+                MAP tk tv <$> replicateM n (do+                    k <- getValue tk+                    v <- getValue tv+                    return (k, v))+           | t == bT_INT8 -> INT8 <$> bondGetInt8+           | t == bT_INT16 -> INT16 <$> bondGetInt16+           | t == bT_INT32 -> INT32 <$> bondGetInt32+           | t == bT_INT64 -> INT64 <$> bondGetInt64+           | t == bT_WSTRING -> WSTRING <$> bondGetWString+           | otherwise -> fail $ "invalid field type " ++ bondTypeName t+    setField s o v = return $ s { fields = MS.insert o v (fields s) }+    fieldLoop s = do+        (t, o) <- getFieldHeader+        if | t == bT_STOP -> return s+           | t == bT_STOP_BASE -> fieldLoop $ Struct (Just s) M.empty+           | otherwise -> getValue t >>= setField s o >>= fieldLoop++readTagged :: forall t. (ReaderM t ~ B.Get, TaggedProtocol t) => t -> BL.ByteString -> Either String Struct+readTagged _ s =+    let BondGet g = getTaggedStruct :: BondGet t Struct+     in case B.runGetOrFail g s of+            Left (_, used, msg) -> Left $ "parse error at " ++ show used ++ ": " ++ msg+            Right (rest, used, _) | not (BL.null rest) -> Left $ "incomplete parse, used " ++ show used ++ ", left " ++ show (BL.length rest)+            Right (_, _, a) -> Right a++readTaggedWithSchema :: forall t. (ReaderM t ~ B.Get, TaggedProtocol t) => t -> StructSchema -> BL.ByteString -> Either String Struct+readTaggedWithSchema _ schema s =+    let BondGet g = getTaggedStruct :: BondGet t Struct+     in case B.runGetOrFail g s of+            Left (_, used, msg) -> Left $ "parse error at " ++ show used ++ ": " ++ msg+            Right (rest, used, _) | not (BL.null rest) -> Left $ "incomplete parse, used " ++ show used ++ ", left " ++ show (BL.length rest)+            Right (_, _, a) -> checkStructSchema schema a++putTaggedData :: forall t. (MonadError String (BondPutM t), WriterM t ~ ErrorT String B.PutM, TaggedProtocol t) => Struct -> BondPut t+putTaggedData s = do+    case base s of+        Just b -> putTaggedData b >> putTag bT_STOP_BASE+        Nothing -> return ()+    forM_ (M.toList $ fields s) $ \ (o, v) -> do+        let (typ, writer) = saveValue v+        putFieldHeader typ o+        writer+    where+    saveValue :: Value -> (BondDataType, BondPut t)+    saveValue (BOOL v) = (bT_BOOL, bondPutBool v)+    saveValue (INT8 v) = (bT_INT8, bondPutInt8 v)+    saveValue (INT16 v) = (bT_INT16, bondPutInt16 v)+    saveValue (INT32 v) = (bT_INT32, bondPutInt32 v)+    saveValue (INT64 v) = (bT_INT64, bondPutInt64 v)+    saveValue (UINT8 v) = (bT_UINT8, bondPutUInt8 v)+    saveValue (UINT16 v) = (bT_UINT16, bondPutUInt16 v)+    saveValue (UINT32 v) = (bT_UINT32, bondPutUInt32 v)+    saveValue (UINT64 v) = (bT_UINT64, bondPutUInt64 v)+    saveValue (FLOAT v) = (bT_FLOAT, bondPutFloat v)+    saveValue (DOUBLE v) = (bT_DOUBLE, bondPutDouble v)+    saveValue (STRING v) = (bT_STRING, bondPutString v)+    saveValue (WSTRING v) = (bT_WSTRING, bondPutWString v)+    saveValue (STRUCT v) = (bT_STRUCT, putTaggedStruct v)+    saveValue (LIST td xs) = (bT_LIST, putListHeader td (length xs) >> mapM_ (saveTypedValue td) xs)+    saveValue (SET td xs) = (bT_SET, putListHeader td (length xs) >> mapM_ (saveTypedValue td) xs)+    saveValue (MAP tk tv xs) = (bT_MAP, do+        putTag tk+        putTag tv+        putVarInt $ length xs+        forM_ xs $ \ (k, v) -> do+            saveTypedValue tk k+            saveTypedValue tv v+      )+    saveValue (BONDED (BondedObject v)) = (bT_STRUCT, putTaggedStruct v)+    saveValue (BONDED _) = (bT_STRUCT, throwError "not implemented: should decode bonded values before tagged writes")+            -- FIXME be smart here+            -- same sig - copy stream+            -- tagged sig - unmarshal struct blindly, then marshal+            -- untagged sig - return error, but do untagged decoding while matching struct with schema+    saveTypedValue td v+        = let (realtd, writer) = saveValue v+           in if td == realtd+                then writer+                else throwError $ "element type do not match container type: " ++ bondTypeName td ++ " expected, " ++ bondTypeName realtd ++ " found"++writeTagged :: forall t. (MonadError String (BondPutM t), WriterM t ~ ErrorT String B.PutM, TaggedProtocol t) => t -> Struct -> Either String BL.ByteString+writeTagged _ a = let BondPut g = putTaggedStruct a :: BondPut t+                   in tryPut g++writeTaggedWithSchema :: (MonadError String (BondPutM t), WriterM t ~ ErrorT String B.PutM, TaggedProtocol t) => t -> StructSchema -> Struct -> Either String BL.ByteString+writeTaggedWithSchema t schema struct = checkStructSchema schema struct >>= writeTagged t
+ src/Data/Bond/Internal/Utils.hs view
@@ -0,0 +1,12 @@+module Data.Bond.Internal.Utils where++import qualified Data.Map as M+import qualified Data.Text as T++makeGenericName :: T.Text -> [T.Text] -> T.Text+makeGenericName upper xs = upper `T.append` T.singleton '<'+                            `T.append` T.intercalate (T.singleton '.') xs+                            `T.append` T.singleton '>'++makeMap :: Ord k => [(k, v)] -> M.Map k v+makeMap = M.fromList
+ src/Data/Bond/Internal/ZigZag.hs view
@@ -0,0 +1,18 @@+module Data.Bond.Internal.ZigZag where++import Data.Int+import Data.Word++class Integral t => ZigZagable t where+    toZigZag :: t -> Word64+    toZigZag i | i >= 0 = 2 * fromIntegral i+    toZigZag i = let long = fromIntegral i :: Int64+                  in (2 * fromIntegral (abs long)) - 1+    fromZigZag :: Word64 -> t+    fromZigZag w | even w = fromIntegral (w `div` 2)+    fromZigZag w = let long = (negate $ fromIntegral ((w - 1) `div` 2) + 1) :: Int64+                    in fromIntegral long++instance ZigZagable Int16+instance ZigZagable Int32+instance ZigZagable Int64
+ src/Data/Bond/Marshal.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE ScopedTypeVariables, MultiWayIf #-}+module Data.Bond.Marshal (+    bondUnmarshal,+    bondUnmarshalWithSchema,+    bondUnmarshalTagged+  ) where++import {-# SOURCE #-} Data.Bond.Internal.CompactBinaryProto+import {-# SOURCE #-} Data.Bond.Internal.FastBinaryProto+import {-# SOURCE #-} Data.Bond.Internal.JsonProto+import {-# SOURCE #-} Data.Bond.Internal.SimpleBinaryProto+import Data.Bond.Proto+import Data.Bond.Struct+import Data.Bond.TypedSchema+import Data.Bond.Internal.Protocol++import qualified Data.ByteString.Lazy as BL++-- |Deserialize structure from stream, finding protocol from stream header.+bondUnmarshal :: BondStruct a => BL.ByteString -> Either String a+bondUnmarshal s+    = let (sig, rest) = BL.splitAt 4 s+       in if | sig == protoSig FastBinaryProto -> bondRead FastBinaryProto rest+             | sig == protoSig CompactBinaryProto -> bondRead CompactBinaryProto rest+             | sig == protoSig CompactBinaryV1Proto -> bondRead CompactBinaryV1Proto rest+             | sig == protoSig SimpleBinaryProto -> bondRead SimpleBinaryProto rest+             | sig == protoSig SimpleBinaryV1Proto -> bondRead SimpleBinaryV1Proto rest+             | sig == protoSig JsonProto -> bondRead JsonProto rest+             | otherwise -> Left "unknown signature in marshalled stream"++-- |Deserialize structure from stream with provided schema, finding protocol from stream header.+bondUnmarshalWithSchema :: StructSchema -> BL.ByteString -> Either String Struct+bondUnmarshalWithSchema schema s+    = let (sig, rest) = BL.splitAt 4 s+       in if | sig == protoSig FastBinaryProto -> bondReadWithSchema FastBinaryProto schema rest+             | sig == protoSig CompactBinaryProto -> bondReadWithSchema CompactBinaryProto schema rest+             | sig == protoSig CompactBinaryV1Proto -> bondReadWithSchema CompactBinaryV1Proto schema rest+             | sig == protoSig SimpleBinaryProto -> bondReadWithSchema SimpleBinaryProto schema rest+             | sig == protoSig SimpleBinaryV1Proto -> bondReadWithSchema SimpleBinaryV1Proto schema rest+             | sig == protoSig JsonProto -> bondReadWithSchema JsonProto schema rest+             | otherwise -> Left "unknown signature in marshalled stream"++-- |Deserialize structure from stream without schema, finding protocol from stream header.+bondUnmarshalTagged :: BL.ByteString -> Either String Struct+bondUnmarshalTagged s+    = let (sig, rest) = BL.splitAt 4 s+       in if | sig == protoSig FastBinaryProto -> bondReadTagged FastBinaryProto rest+             | sig == protoSig CompactBinaryProto -> bondReadTagged CompactBinaryProto rest+             | sig == protoSig CompactBinaryV1Proto -> bondReadTagged CompactBinaryV1Proto rest+             | sig == protoSig SimpleBinaryProto -> Left "SimpleBinaryProto does not support schemaless operations"+             | sig == protoSig SimpleBinaryV1Proto -> Left "SimpleBinaryV1Proto does not support schemaless operations"+             | sig == protoSig JsonProto -> Left "JsonProto does not support schemaless operations"+             | otherwise -> Left "unknown signature in marshalled stream"
+ src/Data/Bond/Proto.hs view
@@ -0,0 +1,36 @@+module Data.Bond.Proto where++import Data.Bond.Struct+import Data.Bond.TypedSchema+import Data.Bond.Internal.Protocol++import qualified Data.ByteString.Lazy as BL++-- |Typeclass for Bond serialization protocols.+class BondProto t where+    -- |Deserialize structure from stream.+    bondRead :: BondStruct a => t -> BL.ByteString -> Either String a+    -- |Serialize structure to stream.+    bondWrite :: BondStruct a => t -> a -> Either String BL.ByteString+    -- |Deserialize structure from stream using provided schema.+    bondReadWithSchema :: t -> StructSchema -> BL.ByteString -> Either String Struct+    -- |Serialize structure to stream using provided schema.+    bondWriteWithSchema :: t -> StructSchema -> Struct -> Either String BL.ByteString+    -- |Serialize structure to stream and add protocol header. See 'Data.Bond.Marshal.bondUnmarshal' for deserialization.+    bondMarshal :: BondStruct a => t -> a -> Either String BL.ByteString+    bondMarshal t = fmap (BL.append $ protoSig t) . bondWrite t+    -- |Serialize structure to stream using provided schema and add protocol header. See 'Data.Bond.Marshal.bondUnmarshalWithSchema' for deserialization.+    bondMarshalWithSchema :: t -> StructSchema -> Struct -> Either String BL.ByteString+    bondMarshalWithSchema t s = fmap (BL.append $ protoSig t) . bondWriteWithSchema t s+    -- |Get protocol header.+    protoSig :: t -> BL.ByteString++-- |Typeclass for tagged Bond serialization protocols. Such protocols support schemaless operations.+class BondProto t => BondTaggedProto t where+    -- |Deserialize structure from stream without schema.+    bondReadTagged :: t -> BL.ByteString -> Either String Struct+    -- |Serialize structure to stream without schema.+    bondWriteTagged :: t -> Struct -> Either String BL.ByteString+    -- |Serialize structure to stream without schema and add protocol header. See 'Data.Bond.Marshal.bondUnmarshalTagged' for deserialization.+    bondMarshalTagged :: t -> Struct -> Either String BL.ByteString+    bondMarshalTagged t = fmap (BL.append $ protoSig t) . bondWriteTagged t
+ src/Data/Bond/Proto.hs-boot view
@@ -0,0 +1,6 @@+module Data.Bond.Proto where++import Data.Bond.Internal.Protocol++class BondProto t+class BondTaggedProto t
+ src/Data/Bond/Struct.hs view
@@ -0,0 +1,74 @@+module Data.Bond.Struct where++import {-# SOURCE #-} Data.Bond.Schema.BondDataType+import Data.Bond.Types++import qualified Data.Map.Strict as M++-- |Representation of bond serializable type used in runtime-schema operations.+data Value+    = BOOL Bool+    | INT8 Int8+    | INT16 Int16+    | INT32 Int32+    | INT64 Int64+    | UINT8 Word8+    | UINT16 Word16+    | UINT32 Word32+    | UINT64 Word64+    | FLOAT Float+    | DOUBLE Double+    | STRING Utf8+    | WSTRING Utf16+    | STRUCT Struct+    | LIST BondDataType [Value]+    | SET BondDataType [Value]+    | MAP BondDataType BondDataType [(Value, Value)]+    | BONDED (Bonded Struct)+    deriving Show++instance Eq Value where+    (BOOL a) == (BOOL b) = a == b+    (INT8 a) == (INT8 b) = a == b+    (INT16 a) == (INT16 b) = a == b+    (INT32 a) == (INT32 b) = a == b+    (INT64 a) == (INT64 b) = a == b+    (UINT8 a) == (UINT8 b) = a == b+    (UINT16 a) == (UINT16 b) = a == b+    (UINT32 a) == (UINT32 b) = a == b+    (UINT64 a) == (UINT64 b) = a == b+    (FLOAT a) == (FLOAT b) = a == b+    (DOUBLE a) == (DOUBLE b) = a == b+    (STRING a) == (STRING b) = a == b+    (WSTRING a) == (WSTRING b) = a == b+    (STRUCT a) == (STRUCT b) = a == b+    (LIST ta a) == (LIST tb b) = ta == tb && a == b+    (SET ta a) == (SET tb b) = ta == tb && a == b+    (MAP ka va a) == (MAP kb vb b) = ka == kb && va == vb && a == b+    (BONDED (BondedObject a)) == (BONDED (BondedObject b)) = a == b+    (BONDED (BondedStream a)) == (BONDED (BondedStream b)) = a == b+    _ == _ = False++-- |Representation of bond structure used in runtime-schema operations.+data Struct = Struct { base :: Maybe Struct, fields :: M.Map Ordinal Value }+    deriving (Show, Eq)++valueName :: Value -> String+valueName (BOOL _) = "bool"+valueName (INT8 _) = "int8"+valueName (INT16 _) = "int16"+valueName (INT32 _) = "int32"+valueName (INT64 _) = "int64"+valueName (UINT8 _) = "uint8"+valueName (UINT16 _) = "uint16"+valueName (UINT32 _) = "uint32"+valueName (UINT64 _) = "uint64"+valueName (FLOAT _) = "float"+valueName (DOUBLE _) = "double"+valueName (STRING _) = "string"+valueName (WSTRING _) = "wstring"+valueName (STRUCT _) = "struct"+valueName LIST{} = "list"+valueName SET{} = "set"+valueName MAP{} = "map"+valueName (BONDED _) = "bonded"
+ src/Data/Bond/TypedSchema.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.Bond.TypedSchema where++import Data.Bond.Types+import Data.Bond.Internal.OrdinalSet++import Data.Text+import Data.Typeable+import qualified Data.Map.Strict as M++data DefaultValue a = DefaultNothing | DefaultValue a++-- |Inner value type+data ElementTypeInfo+    = ElementBool+    | ElementInt8+    | ElementInt16+    | ElementInt32+    | ElementInt64+    | ElementUInt8+    | ElementUInt16+    | ElementUInt32+    | ElementUInt64+    | ElementFloat+    | ElementDouble+    | ElementString+    | ElementWString+    | ElementStruct StructSchema+    | ElementBonded StructSchema+    | ElementList ElementTypeInfo+    | ElementSet ElementTypeInfo+    | ElementMap ElementTypeInfo ElementTypeInfo++-- |Field type and default value+data FieldTypeInfo+    = FieldBool (DefaultValue Bool)+    | FieldInt8 (DefaultValue Int8)+    | FieldInt16 (DefaultValue Int16)+    | FieldInt32 (DefaultValue Int32)+    | FieldInt64 (DefaultValue Int64)+    | FieldUInt8 (DefaultValue Word8)+    | FieldUInt16 (DefaultValue Word16)+    | FieldUInt32 (DefaultValue Word32)+    | FieldUInt64 (DefaultValue Word64)+    | FieldFloat (DefaultValue Float)+    | FieldDouble (DefaultValue Double)+    | FieldString (DefaultValue Utf8)+    | FieldWString (DefaultValue Utf16)+    | FieldStruct (DefaultValue ()) StructSchema+    | FieldBonded (DefaultValue ()) StructSchema+    | FieldList (DefaultValue ()) ElementTypeInfo+    | FieldSet (DefaultValue ()) ElementTypeInfo+    | FieldMap (DefaultValue ()) ElementTypeInfo ElementTypeInfo++data FieldModifier = FieldOptional | FieldRequired | FieldRequiredOptional+    deriving Eq++data FieldSchema = FieldSchema+    { fieldName :: Text+    , fieldAttrs :: M.Map Text Text+    , fieldModifier :: FieldModifier+    , fieldType :: FieldTypeInfo+    }++data StructSchema = StructSchema+    { structTag :: TypeRep+    , structName :: Text+    , structQualifiedName :: Text+    , structAttrs :: M.Map Text Text+    , structBase :: Maybe StructSchema+    , structFields :: M.Map Ordinal FieldSchema+    , structRequiredOrdinals :: OrdinalSet+    }++fieldToElementType :: FieldTypeInfo -> ElementTypeInfo+fieldToElementType (FieldBool _) = ElementBool+fieldToElementType (FieldInt8 _) = ElementInt8+fieldToElementType (FieldInt16 _) = ElementInt16+fieldToElementType (FieldInt32 _) = ElementInt32+fieldToElementType (FieldInt64 _) = ElementInt64+fieldToElementType (FieldUInt8 _) = ElementUInt8+fieldToElementType (FieldUInt16 _) = ElementUInt16+fieldToElementType (FieldUInt32 _) = ElementUInt32+fieldToElementType (FieldUInt64 _) = ElementUInt64+fieldToElementType (FieldFloat _) = ElementFloat+fieldToElementType (FieldDouble _) = ElementDouble+fieldToElementType (FieldString _) = ElementString+fieldToElementType (FieldWString _) = ElementWString+fieldToElementType (FieldStruct _ schema) = ElementStruct schema+fieldToElementType (FieldBonded _ schema) = ElementBonded schema+fieldToElementType (FieldList _ element) = ElementList element+fieldToElementType (FieldSet _ element) = ElementSet element+fieldToElementType (FieldMap _ key value) = ElementMap key value++elementToFieldType :: ElementTypeInfo -> FieldTypeInfo+elementToFieldType ElementBool = FieldBool (DefaultValue False)+elementToFieldType ElementInt8 = FieldInt8 (DefaultValue 0)+elementToFieldType ElementInt16 = FieldInt16 (DefaultValue 0)+elementToFieldType ElementInt32 = FieldInt32 (DefaultValue 0)+elementToFieldType ElementInt64 = FieldInt64 (DefaultValue 0)+elementToFieldType ElementUInt8 = FieldUInt8 (DefaultValue 0)+elementToFieldType ElementUInt16 = FieldUInt16 (DefaultValue 0)+elementToFieldType ElementUInt32 = FieldUInt32 (DefaultValue 0)+elementToFieldType ElementUInt64 = FieldUInt64 (DefaultValue 0)+elementToFieldType ElementFloat = FieldFloat (DefaultValue 0)+elementToFieldType ElementDouble = FieldDouble (DefaultValue 0)+elementToFieldType ElementString = FieldString (DefaultValue "")+elementToFieldType ElementWString = FieldWString (DefaultValue "")+elementToFieldType (ElementStruct schema) = FieldStruct (DefaultValue ()) schema+elementToFieldType (ElementBonded schema) = FieldBonded (DefaultValue ()) schema+elementToFieldType (ElementList element) = FieldList (DefaultValue ()) element+elementToFieldType (ElementSet element) = FieldSet (DefaultValue ()) element+elementToFieldType (ElementMap key value) = FieldMap (DefaultValue ()) key value++elementToDefNothingFieldType :: ElementTypeInfo -> FieldTypeInfo+elementToDefNothingFieldType ElementBool = FieldBool DefaultNothing+elementToDefNothingFieldType ElementInt8 = FieldInt8 DefaultNothing+elementToDefNothingFieldType ElementInt16 = FieldInt16 DefaultNothing+elementToDefNothingFieldType ElementInt32 = FieldInt32 DefaultNothing+elementToDefNothingFieldType ElementInt64 = FieldInt64 DefaultNothing+elementToDefNothingFieldType ElementUInt8 = FieldUInt8 DefaultNothing+elementToDefNothingFieldType ElementUInt16 = FieldUInt16 DefaultNothing+elementToDefNothingFieldType ElementUInt32 = FieldUInt32 DefaultNothing+elementToDefNothingFieldType ElementUInt64 = FieldUInt64 DefaultNothing+elementToDefNothingFieldType ElementFloat = FieldFloat DefaultNothing+elementToDefNothingFieldType ElementDouble = FieldDouble DefaultNothing+elementToDefNothingFieldType ElementString = FieldString DefaultNothing+elementToDefNothingFieldType ElementWString = FieldWString DefaultNothing+elementToDefNothingFieldType (ElementStruct schema) = FieldStruct DefaultNothing schema+elementToDefNothingFieldType (ElementBonded schema) = FieldBonded DefaultNothing schema+elementToDefNothingFieldType (ElementList element) = FieldList DefaultNothing element+elementToDefNothingFieldType (ElementSet element) = FieldSet DefaultNothing element+elementToDefNothingFieldType (ElementMap key value) = FieldMap DefaultNothing key value
+ src/Data/Bond/Types.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}+module Data.Bond.Types (+    Blob(..),+    Bonded(..),+    Bool,+    Double,+    EncodedString(..),+    Float,+    H.HashSet,+    S.Set,+    Int,+    Int16,+    Int32,+    Int64,+    Int8,+    Maybe,+    M.Map,+    Ordinal(..),+    Utf16(..),+    Utf8(..),+    V.Vector,+    Word16,+    Word32,+    Word64,+    Word8,+    fromString+  ) where++import {-# SOURCE #-} Data.Bond.Internal.Bonded++import Data.Data+import Data.Int+import Data.String+import Data.Word+import Data.Hashable+import qualified Data.ByteString as BS+import qualified Data.HashSet as H+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Vector as V++-- |Bond "string" type+newtype Utf8 = Utf8 BS.ByteString+    deriving (Eq, Ord, Hashable, Typeable)++-- |Bond "wstring" type+newtype Utf16 = Utf16 BS.ByteString+    deriving (Eq, Ord, Hashable, Typeable)++-- |Bond "blob" type+newtype Blob = Blob BS.ByteString+    deriving (Show, Eq, Ord, Hashable, Typeable)++-- |Bond string\/wstring transformations from/to 'String' and 'T.Text'.+class IsString a => EncodedString a where+    -- |Convert to 'String'+    toString :: a -> String+    toString = T.unpack . toText++    -- |Make bond string from 'T.Text'+    fromText :: T.Text -> a+    -- |Convert to 'T.Text'+    toText :: a -> T.Text++instance IsString Utf8 where+    fromString = fromText . T.pack++instance EncodedString Utf8 where+    fromText = Utf8 . T.encodeUtf8+    toText (Utf8 s) = T.decodeUtf8 s++instance IsString Utf16 where+    fromString = fromText . T.pack++instance EncodedString Utf16 where+    fromText = Utf16 . T.encodeUtf16LE+    toText (Utf16 s) = T.decodeUtf16LE s++instance Show Utf8 where show s = show $ toString s+instance Show Utf16 where show s = show $ toString s++-- |Bond structure field ordinal.+newtype Ordinal = Ordinal Word16+    deriving (Eq, Ord, Show, Hashable)
+ test/Spec.hs view
@@ -0,0 +1,479 @@+{-# Language GADTs, ScopedTypeVariables, OverloadedStrings #-}+import Data.Bond+import Data.Bond.Internal.ZigZag+import Unittest.Compat.Another.Another+import Unittest.Compat.BasicTypes+import Unittest.Compat.Compat+import Unittest.Simple.Inner as Inner+import Unittest.Simple.Outer as Outer+import Unittest.Simple.Reqopt as ReqOpt++import Control.Monad+import Control.Monad.Trans+import Control.Monad.Trans.Either hiding (left, right)+import Data.Int+import Data.Proxy+import Data.Word+import System.FilePath+import Test.Tasty+import Test.Tasty.Golden+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BL8+import qualified Data.Map as M++import DataPath++main :: IO ()+main = defaultMain tests++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"+    ]++jsonProtocol :: ProtoWrapper+jsonProtocol = ProtoWrapper "JSON" JsonProto "compat.json.dat"++untaggedProtocols :: [ProtoWrapper]+untaggedProtocols = jsonProtocol : simpleProtocols++allProtocols :: [ProtoWrapper]+allProtocols = untaggedProtocols ++ taggedProtocols++compatDataPath :: String+compatDataPath = "test" </> "compat" </> "data"++brokenSchemasPath :: String+brokenSchemasPath = "test" </> "broken_schemas"++tests :: TestTree+tests = testGroup "Haskell runtime tests"+    [ testGroup "Runtime schema tests"+        [ testCase "check saved Compat schema matching our schema" matchCompatSchemaDef,+          testCase "check gbc-generated SchemaDef schema matching our schema" matchGeneratedSchemaDef,+          testCase "check compile/decompile schema is identity" checkCompileIdentity,+          testCase "defaultStruct is correct" checkDefaultStruct+        ],+      testGroup "Runtime schema validation tests"+        [ testCaseInfo "loop in inheritance chain" $ checkSchemaError "inheritance_loop.json",+          testCaseInfo "non-struct in inheritance chain" $ checkSchemaError "inherit_from_int.json",+          testCaseInfo "index out of range" $ checkSchemaError "index_out_of_range.json",+          testCaseInfo "field type mismatch" $+            checkSchemaMismatch (Proxy :: Proxy Outer) $ Struct Nothing $ M.fromList [(Ordinal 10, BOOL True)],+          testCaseInfo "field type mismatch in field struct" $+            checkSchemaMismatch (Proxy :: Proxy Outer) $ Struct Nothing $ M.fromList+              [+                (Ordinal 20, STRUCT $ Struct Nothing $ M.fromList [(Ordinal 10, BOOL True)])+              ],+          testCaseInfo "type mismatch in list" $+            checkSchemaMismatch (Proxy :: Proxy Outer) $+                Struct Nothing $ M.fromList [(Ordinal 40, LIST bT_BOOL [])],+          testCaseInfo "type mismatch in list element struct" $+            checkSchemaMismatch (Proxy :: Proxy Outer) $+                Struct Nothing $ M.fromList [(Ordinal 40, LIST bT_STRUCT+                  [+                    STRUCT $ Struct (Just $ Struct Nothing M.empty) $ M.fromList [(Ordinal 10, BOOL True)]+                  ])],+          testCaseInfo "type mismatch in set" $+            checkSchemaMismatch (Proxy :: Proxy Outer) $+                Struct Nothing $ M.fromList [(Ordinal 50, SET bT_BOOL [])],+          testCaseInfo "type mismatch in map key" $+            checkSchemaMismatch (Proxy :: Proxy Outer) $+                Struct Nothing $ M.fromList [(Ordinal 60, MAP bT_BOOL bT_STRUCT [])],+          testCaseInfo "type mismatch in map value" $+            checkSchemaMismatch (Proxy :: Proxy Outer) $+                Struct Nothing $ M.fromList [(Ordinal 60, MAP bT_UINT32 bT_BOOL [])],+          testCaseInfo "type mismatch in map element key" $+            checkSchemaMismatch (Proxy :: Proxy Outer) $+                Struct Nothing $ M.fromList [(Ordinal 60, MAP bT_UINT32 bT_STRUCT+                  [+                    (BOOL True, STRUCT $ Struct (Just $ Struct Nothing M.empty) M.empty)+                  ])],+          testCaseInfo "type mismatch in map element value" $+            checkSchemaMismatch (Proxy :: Proxy Outer) $+                Struct Nothing $ M.fromList [(Ordinal 60, MAP bT_UINT32 bT_STRUCT+                  [+                    (UINT32 42, BOOL True)+                  ])],+          testCaseInfo "type mismatch in map element field" $+            checkSchemaMismatch (Proxy :: Proxy Outer) $+                Struct Nothing $ M.fromList [(Ordinal 60, MAP bT_UINT32 bT_STRUCT+                  [+                    (UINT32 42, STRUCT $ Struct (Just $ Struct Nothing M.empty) $ M.fromList [(Ordinal 10, BOOL True)])+                  ])],+          testCaseInfo "schema too deep for struct" $+            checkSchemaMismatch (Proxy :: Proxy Inner) $ Struct Nothing M.empty,+          testCase "shallow schema" checkShallowSchema+        ],+      testGroup "Protocol tests" $+        (map testTagged taggedProtocols) +++        (map testSimple simpleProtocols) +++          [ testGroup "JSON"+            [ testJson "read/write original Compat value" "compat.json.dat",+              testJson "read/write golden Compat value" "golden.json.dat",+--              testJsonWithSchema "read/write original Compat value with schema" "compat.json.dat",+              testJsonWithSchema "read/write golden Compat value with schema" "golden.json.dat",+--              testJsonWithRuntimeSchema "read/write original Compat value with runtime schema" "compat.json.dat",+              testJsonWithRuntimeSchema "read/write golden Compat value with runtime schema" "golden.json.dat",+              testCase "read BasicTypes value" $+                readAsType JsonProto (Proxy :: Proxy BasicTypes) "compat.json.dat",+              testCase "read Another value" $+                readAsType JsonProto (Proxy :: Proxy Another) "compat.json.dat",+              testCaseInfo "fail to read with required field missing" $ jsonFailToReadMissingRequired,+              testCaseInfo "fail to write nothing to required field" $ failToWriteRequiredNothing JsonProto+            ],+          testGroup "Marshalling"+            [ testCase "read/write SchemaDef value" readSchema,+              testCase "read/write SchemaDef value with schema" readSchemaWithSchema,+              testCase "read/write SchemaDef value w/o schema" readSchemaTagged+            ],+          testGroup "Cross-tests" crossTests,+          testGroup "Bonded recoding" bondedRecodeTests+        ],+      testGroup "ZigZag encoding"+        [ testProperty "Int16" zigzagInt16,+          testProperty "Int32" zigzagInt32,+          testProperty "Int64" zigzagInt64,+          testProperty "Word64" zigzagWord64+        ]+    ]+    where+    testTagged (TaggedProtoWrapper name proto dat) = testGroup name+        [ testCase "read/write Compat value" $ readCompat proto dat+        , testCase "read BasicTypes value" $ readAsType proto (Proxy :: Proxy BasicTypes) dat+        , testCase "read Another value" $ readAsType proto (Proxy :: Proxy Another) dat+        , testCase "read Compat w/o schema" $ readCompatTagged proto dat+        , testCase "read Compat with compile-time schema" $ readCompatWithSchema proto dat+        , testCase "read Compat with runtime schema" $ readCompatWithRuntimeSchema proto dat+        , testCaseInfo "fail to read with required field missing" $ failToReadMissingRequired proto+        , testCaseInfo "fail to read with schema and required field missing" $ failToReadMissingRequiredWithSchema proto+        , testCaseInfo "fail to write nothing to required field" $ failToWriteRequiredNothing proto+        , testCaseInfo "fail to write nothing to required field with schema" $ failToWriteRequiredNothingWithSchema proto+        , invalidTaggedWriteTests proto+        ]+    testTagged _ = error "invalid protocol"++    testSimple (ProtoWrapper name proto dat) = testGroup name+        [ testCase "read/write Compat value" $ readCompat proto dat+        , testCase "read Compat with compile-time schema" $ readCompatWithSchema proto dat+        , testCase "read Compat with runtime schema" $ readCompatWithRuntimeSchema proto dat+        , testCaseInfo "fail to save default nothing" $ failToSaveDefaultNothing proto+        ]+    testSimple _ = error "invalid protocol"++bondedRecodeTests :: [TestTree]+bondedRecodeTests = [testCase (name1 ++ " - " ++ name2) (recodeFromTo t1 t2)+                        | ProtoWrapper name1 t1 _ <- map fromTagged allProtocols+                        , ProtoWrapper name2 t2 _ <- map fromTagged allProtocols+                    ]++invalidTaggedWriteTests :: BondTaggedProto t => t -> TestTree+invalidTaggedWriteTests t = testGroup "invalid tagged write tests"+  [+    testCaseInfo "type mismatch in list" $+        testInvalidTaggedWrite t $ Struct Nothing $ M.fromList [(Ordinal 1, LIST bT_BOOL [INT16 42, BOOL True])],+    testCaseInfo "type mismatch inside list element" $+        testInvalidTaggedWrite t $ Struct Nothing+            $ M.fromList [(Ordinal 1, LIST bT_SET [SET bT_INT32 [INT32 5, UINT32 6]])],+    testCaseInfo "type mismatch in set" $+        testInvalidTaggedWrite t $ Struct Nothing+            $ M.fromList [(Ordinal 1, SET bT_STRUCT [STRUCT $ Struct Nothing M.empty, BOOL True])],+    testCaseInfo "type mismatch in map key" $+        testInvalidTaggedWrite t $ Struct Nothing+            $ M.fromList [(Ordinal 1, MAP bT_UINT32 bT_STRING [(UINT64 1, STRING "bar")])],+    testCaseInfo "type mismatch in map value" $+        testInvalidTaggedWrite t $ Struct Nothing+            $ M.fromList [(Ordinal 1, MAP bT_UINT64 bT_WSTRING [(UINT64 1, STRING "foo")])]+  ]++-- Simple protocol has different m_defaults from all others. Also some enum values differ.+-- Json differs in uint64 values.+-- See comments in https://github.com/Microsoft/bond/blob/master/cpp/test/compat/serialization.cpp+crossTests :: [TestTree]+crossTests =+    [crossTest left right+        | left <- simpleProtocols+        , right <- simpleProtocols+        , getName left < getName right+    ] +++    [crossTest left right+        | left <- taggedProtocols+        , right <- taggedProtocols+        , getName left < getName right+    ] +++    [crossTestTagged left right+        | left <- taggedProtocols+        , right <- taggedProtocols+        , getName left < getName right+    ]+    where+    getName (ProtoWrapper name _ _) = name+    getName (TaggedProtoWrapper name _ _) = name++    crossTest (ProtoWrapper lname lproto lfile) (ProtoWrapper rname rproto rfile)+        = testCase (lname ++ " - " ++ rname) $ assertEither $ do+            ldata <- readData (compatDataPath </> lfile)+            left <- hoistEither (bondRead lproto ldata :: Either String Compat)+            rdata <- readData (compatDataPath </> rfile)+            right <- hoistEither $ bondRead rproto rdata+            checkEqual "values do not match" left right+            lout <- hoistEither $ bondWrite lproto right+            checkEqual ("value saved with " ++ lname ++ " do not match original") ldata lout+            rout <- hoistEither $ bondWrite rproto left+            checkEqual ("value saved with " ++ rname ++ " do not match original") rdata rout+    crossTest left right  = crossTest (fromTagged left) (fromTagged right)++    crossTestTagged (TaggedProtoWrapper lname lproto lfile) (TaggedProtoWrapper rname rproto rfile)+        = testCase ("w/o schema: " ++ lname ++ " - " ++ rname) $ assertEither $ do+            ldata <- readData (compatDataPath </> lfile)+            left <- hoistEither $ bondReadTagged lproto ldata+            rdata <- readData (compatDataPath </> rfile)+            right <- hoistEither $ bondReadTagged rproto rdata+            checkEqual "values do not match" left right+            lout <- hoistEither $ bondWriteTagged lproto right+            checkEqual ("value saved with " ++ lname ++ " do not match original") ldata lout+            rout <- hoistEither $ bondWriteTagged rproto left+            checkEqual ("value saved with " ++ rname ++ " do not match original") rdata rout+    crossTestTagged _ _ = error "invalid protocols"++readCompat :: BondProto t => t -> String -> Assertion+readCompat p f = assertEither $ do+    dat <- readData (compatDataPath </> f)+    s <- hoistEither (bondRead p dat :: Either String Compat)+    d' <- hoistEither $ bondWrite p s+    checkEqual "serialized value do not match original" dat d'++readCompatTagged :: BondTaggedProto t => t -> String -> Assertion+readCompatTagged p f = assertEither $ do+    dat <- readData (compatDataPath </> f)+    s <- hoistEither $ bondReadTagged p dat+    outdat <- hoistEither $ bondWriteTagged p s+    checkEqual "serialized value do not match original" dat outdat++readCompatWithSchema :: BondProto t => t -> String -> Assertion+readCompatWithSchema p f = assertEither $ do+    dat <- readData (compatDataPath </> f)+    let schema = getSchema (Proxy :: Proxy Compat)+    s <- hoistEither $ bondReadWithSchema p schema dat+    outdat <- hoistEither $ bondWriteWithSchema p schema s+    checkEqual "serialized value do not match original" dat outdat++readCompatWithRuntimeSchema :: BondProto t => t -> String -> Assertion+readCompatWithRuntimeSchema p f = assertEither $ do+    schemadat <- readData (compatDataPath </> "compat.schema.dat")+    schemadef <- hoistEither (bondUnmarshal schemadat :: Either String SchemaDef)+    schema <- hoistEither $ parseSchema schemadef+    dat <- readData (compatDataPath </> f)+    s <- hoistEither $ bondReadWithSchema p schema dat+    outdat <- hoistEither $ bondWriteWithSchema p schema s+    checkEqual "serialized value do not match original" dat outdat++readSchema :: Assertion+readSchema = assertEither $ do+    dat <- readData (compatDataPath </> "compat.schema.dat")+    s <- hoistEither (bondUnmarshal dat :: Either String SchemaDef)+    d' <- hoistEither $ bondMarshal CompactBinaryV1Proto s+    checkEqual "serialized value do not match original" dat d'++readSchemaWithSchema :: Assertion+readSchemaWithSchema = assertEither $ do+    let schema = getSchema (Proxy :: Proxy SchemaDef)+    dat <- readData (compatDataPath </> "compat.schema.dat")+    struct <- hoistEither $ bondUnmarshalWithSchema schema dat+    out <- hoistEither $ bondMarshalWithSchema CompactBinaryV1Proto schema struct+    checkEqual "serialized value do not match original" dat out++readSchemaTagged :: Assertion+readSchemaTagged = assertEither $ do+    dat <- readData (compatDataPath </> "compat.schema.dat")+    struct <- hoistEither $ bondUnmarshalTagged dat+    let schema = getSchema (Proxy :: Proxy SchemaDef)+    checked <- hoistEither $ checkStructSchema schema struct+    out <- hoistEither $ bondMarshalTagged CompactBinaryV1Proto checked+    checkEqual "serialized value do not match original" dat out++-- compat.json.dat file has several properties making it incompatible with usual test:+-- all float values saved with extra precision+-- double values are saved in a way different from one used by scientific+-- fields are saved in declaration order, while aeson saves them in pseudorandom hash order+-- optional fields with default values are present++-- Golden file is manually checked to match compat data as best as it could++testJson :: String -> FilePath -> TestTree+testJson name f = goldenVsString name (compatDataPath </> "golden.json.dat") $ do+    dat <- BL.readFile (compatDataPath </> f)+    let parse = bondRead JsonProto dat :: Either String Compat+    case parse of+        Left msg -> assertFailure msg >> return BL.empty+        Right s -> case bondWrite JsonProto s of+            Left msg -> assertFailure msg >> return BL.empty +            Right out -> return out++testJsonWithSchema :: String -> FilePath -> TestTree+testJsonWithSchema name f = goldenVsString name (compatDataPath </> "golden.json.dat") $+    eitherT (\ msg -> assertFailure msg >> return BL.empty) return $ do+        let schema = getSchema (Proxy :: Proxy Compat)+        dat <- readData (compatDataPath </> f)+        s <- hoistEither $ bondReadWithSchema JsonProto schema dat+        hoistEither $ bondWriteWithSchema JsonProto schema s++testJsonWithRuntimeSchema :: String -> FilePath -> TestTree+testJsonWithRuntimeSchema name f = goldenVsString name (compatDataPath </> "golden.json.dat") $+    eitherT (\ msg -> assertFailure msg >> return BL.empty) return $ do+        schemadat <- readData (compatDataPath </> "compat.schema.dat")+        schemadef <- hoistEither (bondUnmarshal schemadat :: Either String SchemaDef)+        schema <- hoistEither $ parseSchema schemadef+        dat <- readData (compatDataPath </> f)+        s <- hoistEither $ bondReadWithSchema JsonProto schema dat+        hoistEither $ bondWriteWithSchema JsonProto schema s++readAsType :: forall t a. (Show a, BondProto t, BondStruct a) => t -> Proxy a -> String -> Assertion+readAsType p _ f = assertEither $ do+    dat <- readData (compatDataPath </> f)+    void $ hoistEither (bondRead p dat :: Either String a)++matchCompatSchemaDef :: Assertion+matchCompatSchemaDef = assertEither $ do+    dat <- readData (compatDataPath </> "compat.schema.dat")+    fileSchema <- hoistEither $ bondUnmarshal dat+    let schema = getSchema (Proxy :: Proxy Compat)+    let assembledSchema = assembleSchema schema+    checkEqual "schemas do not match" fileSchema assembledSchema++-- gbc's json schemas differ slightly from bond.bond definition,+-- so tests can't compare json representations.+matchGeneratedSchemaDef :: Assertion+matchGeneratedSchemaDef = assertEither $ do+    dat <- readData (autogenPath </> "bond.SchemaDef.json")+    fileSchema <- hoistEither $ bondRead JsonProto dat+    let schema = getSchema (Proxy :: Proxy SchemaDef)+    let assembledSchema = assembleSchema schema+    checkEqual "schemas do not match" fileSchema assembledSchema++checkSchemaError :: FilePath -> IO String+checkSchemaError f = assertWithMsg $ do+    dat <- readData (brokenSchemasPath </> f)+    schema <- hoistEither $ bondRead JsonProto dat+    checkHasError $ parseSchema schema++checkSchemaMismatch :: BondStruct a => Proxy a -> Struct -> IO String+checkSchemaMismatch a s = assertWithMsg $ do+    let schema = getSchema a+    checkHasError $ checkStructSchema schema s++checkShallowSchema :: Assertion+checkShallowSchema = assertEither $ do+    let schema = getSchema (Proxy :: Proxy Outer)+    void $ hoistEither $ checkStructSchema schema $ Struct (Just $ Struct Nothing M.empty) M.empty++testInvalidTaggedWrite :: BondTaggedProto t => t -> Struct -> IO String+testInvalidTaggedWrite p s = assertWithMsg $ checkHasError $ bondWriteTagged p s++failToSaveDefaultNothing :: BondProto t => t -> IO String+failToSaveDefaultNothing p =+    let struct = Struct (Just $ Struct Nothing M.empty)+            $ M.fromList [(Ordinal 13, UINT8 0), (Ordinal 16, INT32 0)]+        schema = getSchema (Proxy :: Proxy BasicTypes)+     in assertWithMsg $ checkHasError $ bondWriteWithSchema p schema struct++failToReadMissingRequired :: BondTaggedProto t => t -> IO String+failToReadMissingRequired p = assertWithMsg $ do+    let struct = Struct Nothing M.empty+    out <- hoistEither $ bondWriteTagged p struct+    checkHasError $ (bondRead p out :: Either String Reqopt)++jsonFailToReadMissingRequired :: IO String+jsonFailToReadMissingRequired = assertWithMsg $ do+    let dat = BL8.pack "{}"+    checkHasError $ (bondRead JsonProto dat :: Either String Reqopt)++failToReadMissingRequiredWithSchema :: BondTaggedProto t => t -> IO String+failToReadMissingRequiredWithSchema p = assertWithMsg $ do+    let struct = Struct Nothing M.empty+    out <- hoistEither $ bondWriteTagged p struct+    let schema = getSchema (Proxy :: Proxy Reqopt)+    checkHasError $ bondReadWithSchema p schema out++failToWriteRequiredNothing :: BondProto t => t -> IO String+failToWriteRequiredNothing p = assertWithMsg $ do+    let struct = defaultValue :: Reqopt+    checkHasError $ bondWrite p struct++failToWriteRequiredNothingWithSchema :: BondTaggedProto t => t -> IO String+failToWriteRequiredNothingWithSchema p = assertWithMsg $ do+    let struct = Struct Nothing $ M.fromList [(Ordinal 10, INT8 5)]+    let schema = getSchema (Proxy :: Proxy Reqopt)+    checkHasError $ bondWriteWithSchema p schema struct++recodeFromTo :: forall t1 t2. (BondProto t1, BondProto t2) => t1 -> t2 -> Assertion+recodeFromTo t1 t2 = assertEither $ do+    let inner = defaultValue{ Inner.m_uint64 = 5, Inner.m_uint32 = [12, 34] } :: Inner+    bonded <- hoistEither $ marshalValue t1 inner+    let outer = defaultValue{ m_bonded_inner = bonded }+    saved <- hoistEither $ bondWrite t2 outer+    v <- hoistEither (bondRead t2 saved :: Either String Outer)+    unpacked <- hoistEither $ getValue (m_bonded_inner v)+    checkEqual "deserialized value do not match with original" inner unpacked++checkCompileIdentity :: Assertion+checkCompileIdentity = assertEither $ do+    schemadat <- readData (compatDataPath </> "compat.schema.dat")+    schemadef <- hoistEither (bondUnmarshal schemadat :: Either String SchemaDef)+    parsedSchema <- hoistEither $ parseSchema schemadef+    let assembledSchema = assembleSchema parsedSchema+    checkEqual "original and decompiled schema do not match" schemadef assembledSchema+--    reparsedSchema <- hoistEither $ parseSchema assembledSchema+--    checkEqual "original and parsed schema do not match" parsedSchema reparsedSchema++checkDefaultStruct :: Assertion+checkDefaultStruct = do+    let schema = getSchema (Proxy :: Proxy Reqopt)+    let defStruct = defaultStruct schema+    assertEqual "struct is not as expected"+        (Struct Nothing $ M.fromList [(Ordinal 10, INT8 5), (Ordinal 20, STRING "")])+        defStruct++zigzagInt16 :: Int16 -> Bool+zigzagInt16 x = x == fromZigZag (toZigZag x)++zigzagInt32 :: Int32 -> Bool+zigzagInt32 x = x == fromZigZag (toZigZag x)++zigzagInt64 :: Int64 -> Bool+zigzagInt64 x = x == fromZigZag (toZigZag x)++zigzagWord64 :: Word64 -> Bool+zigzagWord64 x = x == toZigZag (fromZigZag x :: Int64)++assertEither :: EitherT String IO () -> Assertion+assertEither = eitherT assertFailure (const $ return ())++assertWithMsg :: EitherT String IO String -> IO String+assertWithMsg = eitherT (\ msg -> assertFailure msg >> return "") (\ msg -> return $ "error caught: " ++ msg)++readData :: FilePath -> EitherT String IO BL.ByteString+readData = lift . BL.readFile++checkEqual :: (Eq a, Show a, MonadTrans t) => String -> a -> a -> t IO ()+checkEqual m a b = lift $ assertEqual m a b++checkHasError :: Either String a -> EitherT String IO String+checkHasError = bimapEitherT (const "error not found") id . swapEitherT . hoistEither