diff --git a/benchmark/Criterion.hs b/benchmark/Criterion.hs --- a/benchmark/Criterion.hs +++ b/benchmark/Criterion.hs @@ -55,20 +55,6 @@ [ NF someInt , NF someShortString , NF someLongString - , NF defaultInt - , NF defaultString - , NF (encode intValUntyped) -- Evaluate the encodings to NF to force a 'Typed'. Hacky but works :-) - , NF (encode intValHashed) - , NF (encode intValShown) - , NF (encode intValFull) - , NF (encode strSValUntyped) - , NF (encode strSValHashed) - , NF (encode strSValShown) - , NF (encode strSValFull) - , NF (encode strLValUntyped) - , NF (encode strLValHashed) - , NF (encode strLValShown) - , NF (encode strLValFull) ] forceCafs :: IO () @@ -79,79 +65,24 @@ bench_binaryVsTyped = [ bgroup "Int" [ bench_int_untyped - , bgroup "recalculate" bench_int - , bgroup "precache" (bench_encode_precached intValUntyped - intValHashed - intValShown - intValFull - someInt) + , bgroup "Typed" bench_int ] , bgroup "\"hello\"" [ bench_short_string_untyped - , bgroup "recalculate" bench_short_string - , bgroup "precache" (bench_encode_precached strSValUntyped - strSValHashed - strSValShown - strSValFull - someShortString) + , bgroup "Typed" bench_short_string ] , bgroup "Lipsum (length 100)" [ bench_long_string_untyped - , bgroup "recalculate" bench_long_string - , bgroup "precache" (bench_encode_precached strLValUntyped - strLValHashed - strLValShown - strLValFull - someLongString) + , bgroup "Typed" bench_long_string ] , bgroup "Complicated type" [ bench_complicated_untyped - , bgroup "recalculate" bench_complicated - , bgroup "precache" (bench_encode_precached compLValUntyped - compLValHashed - compLValShown - compLValFull - someComplicated) + , bgroup "Typed" bench_complicated ] ] -defaultInt :: Int -defaultInt = 0 - -defaultString :: String -defaultString = "" - -defaultComplicated :: Complicated -defaultComplicated = Left (' ', 0) - -intValUntyped, intValHashed, intValShown, intValFull :: Typed Int -intValUntyped = precache (typed Untyped defaultInt) -intValHashed = precache (typed Hashed defaultInt) -intValShown = precache (typed Shown defaultInt) -intValFull = precache (typed Full defaultInt) - -strSValUntyped, strSValHashed, strSValShown, strSValFull :: Typed String -strSValUntyped = precache (typed Untyped defaultString) -strSValHashed = precache (typed Hashed defaultString) -strSValShown = precache (typed Shown defaultString) -strSValFull = precache (typed Full defaultString) - -strLValUntyped, strLValHashed, strLValShown, strLValFull :: Typed String -strLValUntyped = precache (typed Untyped defaultString) -strLValHashed = precache (typed Hashed defaultString) -strLValShown = precache (typed Shown defaultString) -strLValFull = precache (typed Full defaultString) - -compLValUntyped, compLValHashed, compLValShown, compLValFull :: Typed Complicated -compLValUntyped = precache (typed Untyped defaultComplicated) -compLValHashed = precache (typed Hashed defaultComplicated) -compLValShown = precache (typed Shown defaultComplicated) -compLValFull = precache (typed Full defaultComplicated) - - - bench_int :: [Benchmark] bench_int = map (bench_encode someInt) formats @@ -178,7 +109,8 @@ formats :: [TypeFormat] formats = [ Untyped - , Hashed + , Hashed32 + , Hashed64 , Shown , Full ] @@ -190,23 +122,4 @@ -> TypeFormat -> Benchmark bench_encode x format = bench description (nf (encodeTyped format) x) - where description = "Typed: " ++ show format - - - --- | Encode a value using a precached 'Typed' value. -bench_encode_precached - :: (Binary a, Typeable a) - => Typed a -- ^ Precached 'Untyped' dummy value - -> Typed a -- ^ dito, with 'Hashed' - -> Typed a -- ^ dito, with 'Shown' - -> Typed a -- ^ dito, with 'Full' - -> a -- ^ Actual value to encode - -> [Benchmark] -bench_encode_precached untyped hashed shown full x = - [ bench (description Untyped) (nf (encodeTypedLike untyped) x) - , bench (description Hashed) (nf (encodeTypedLike hashed ) x) - , bench (description Shown) (nf (encodeTypedLike shown ) x) - , bench (description Full) (nf (encodeTypedLike full ) x) - ] - where description format = "Typed: " ++ show format + where description = show format diff --git a/benchmark/CriterionOverview.hs b/benchmark/CriterionOverview.hs --- a/benchmark/CriterionOverview.hs +++ b/benchmark/CriterionOverview.hs @@ -15,7 +15,7 @@ -- Encoding mode to be used mode :: TypeFormat -mode = Hashed +mode = Hashed64 type Complicated = Either (Char, Int) (Either String (Maybe Integer)) @@ -30,19 +30,11 @@ --- Cached typed encoder -encodeTyped' :: Complicated -> ByteString -encodeTyped' = encodeTypedLike (typed mode dummyValue) - where dummyValue :: Complicated - dummyValue = Left ('x', 0) - - - main :: IO () main = do evaluate (value `deepseq` ()) - defaultMain [ bgroup "encode only" bench_encode - , bgroup "decode only" bench_decode + defaultMain [ bgroup "encode" bench_encode + , bgroup "decode" bench_decode , bgroup "encode+decode" bench_both ] @@ -55,29 +47,23 @@ bench_encode :: [Benchmark] bench_encode = [ bench_encode_binaryOnly - , bench_encode_uncached - , bench_encode_cached + , bench_encode_typed ] bench_encode_binaryOnly :: Benchmark bench_encode_binaryOnly = bench d (nf f value) - where d = "Binary only" + where d = "Binary" f = encode -bench_encode_uncached :: Benchmark -bench_encode_uncached = bench d (nf f value) - where d = "Uncached" +bench_encode_typed :: Benchmark +bench_encode_typed = bench d (nf f value) + where d = "Typed with " ++ show mode f = encodeTyped mode -bench_encode_cached :: Benchmark -bench_encode_cached = bench d (nf f value) - where d = "Cached" - f = encodeTyped' - -- ############################################################################# -- ### Decode only ########################################################### -- ############################################################################# @@ -97,7 +83,7 @@ bench_decode_typed :: Benchmark bench_decode_typed = bench d (nf f value_encodedTyped) - where d = "Typed" + where d = "Typed with " ++ show mode f :: ByteString -> Complicated f = unsafeDecodeTyped @@ -111,8 +97,7 @@ bench_both :: [Benchmark] bench_both = [ bench_both_binaryOnly - , bench_both_uncached - , bench_both_cached + , bench_both_typed ] @@ -122,14 +107,8 @@ f :: Complicated -> Complicated f = decode . encode -bench_both_uncached :: Benchmark -bench_both_uncached = bench d (nf f value) - where d = "Uncached" +bench_both_typed :: Benchmark +bench_both_typed = bench d (nf f value) + where d = "Typed with " ++ show mode f :: Complicated -> Complicated f = unsafeDecodeTyped . encodeTyped mode - -bench_both_cached :: Benchmark -bench_both_cached = bench d (nf f value) - where d = "Cached" - f :: Complicated -> Complicated - f = unsafeDecodeTyped . encodeTyped' diff --git a/benchmark/MessageLength.hs b/benchmark/MessageLength.hs --- a/benchmark/MessageLength.hs +++ b/benchmark/MessageLength.hs @@ -24,31 +24,36 @@ lipsum = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Nam\ \ vitae lacinia tellus. Maecenas posuere." -data EncodeLengths = EL { info :: String - , binary :: Int64 - , typedUntyped :: Int64 - , typedHashed :: Int64 - , typedShown :: Int64 - , typedFull :: Int64 +data EncodeLengths = EL { info :: String + , binary :: Int64 + , typedUntyped :: Int64 + , typedHashed32 :: Int64 + , typedHashed64 :: Int64 + , typedShown :: Int64 + , typedFull :: Int64 } -- | Prettyprint 'EncodeLengths' ppr :: EncodeLengths -> String ppr el = unlines [ info el - , printf " Binary: %d" (binary el) - , printf " Typed/Untyped: %d (+%d, +%2.2f%%)" + , printf " Binary: %d" (binary el) + , printf " Typed/Untyped: %d (+%d, +%2.2f%%)" (typedUntyped el) (absolute (binary el) (typedUntyped el)) (percent (binary el) (typedUntyped el)) - , printf " Typed/Hashed: %d (+%d, +%2.2f%%)" - (typedHashed el) - (absolute (binary el) (typedHashed el)) - (percent (binary el) (typedHashed el)) - , printf " Typed/Shown: %d (+%d, +%2.2f%%)" + , printf " Typed/Hashed32: %d (+%d, +%2.2f%%)" + (typedHashed32 el) + (absolute (binary el) (typedHashed32 el)) + (percent (binary el) (typedHashed32 el)) + , printf " Typed/Hashed64: %d (+%d, +%2.2f%%)" + (typedHashed64 el) + (absolute (binary el) (typedHashed64 el)) + (percent (binary el) (typedHashed64 el)) + , printf " Typed/Shown: %d (+%d, +%2.2f%%)" (typedShown el) (absolute (binary el) (typedShown el)) (percent (binary el) (typedShown el)) - , printf " Typed/Full: %d (+%d, +%2.2f%%)" + , printf " Typed/Full: %d (+%d, +%2.2f%%)" (typedFull el) (absolute (binary el) (typedFull el)) (percent (binary el) (typedFull el)) @@ -68,17 +73,19 @@ -- | Measure the message lengths generated by different encodings. measure :: (Binary a, Typeable a) => String -> a -> EncodeLengths measure i x = EL { info = i - , binary = BSL.length binary' - , typedUntyped = BSL.length typedUntyped' - , typedHashed = BSL.length typedHashed' - , typedShown = BSL.length typedShown' - , typedFull = BSL.length typedFull' + , binary = BSL.length binary' + , typedUntyped = BSL.length typedUntyped' + , typedHashed32 = BSL.length typedHashed32' + , typedHashed64 = BSL.length typedHashed64' + , typedShown = BSL.length typedShown' + , typedFull = BSL.length typedFull' } where - binary' = encode x - typedUntyped' = encodeTyped Untyped x - typedHashed' = encodeTyped Hashed x - typedShown' = encodeTyped Shown x - typedFull' = encodeTyped Full x + binary' = encode x + typedUntyped' = encodeTyped Untyped x + typedHashed32' = encodeTyped Hashed32 x + typedHashed64' = encodeTyped Hashed64 x + typedShown' = encodeTyped Shown x + typedFull' = encodeTyped Full x diff --git a/binary-typed.cabal b/binary-typed.cabal --- a/binary-typed.cabal +++ b/binary-typed.cabal @@ -1,5 +1,5 @@ name: binary-typed -version: 0.1.0.1 +version: 0.2.0.0 synopsis: Type-safe binary serialization Description: `Binary` serialization tagged with type information, allowing for @@ -26,9 +26,9 @@ . Performance-wise, here is a value @Right (Left \<100 chars lipsum\>)@ of type @Either (Char, Int) (Either String (Maybe Integer))@ benchmarked - using the @Hashed@ type representation: + using the @Hashed64@ type representation: . - <> + <> . homepage: https://github.com/quchen/binary-typed @@ -56,7 +56,7 @@ ghc-options: -Wall hs-source-dirs: src other-extensions: GADTs, DeriveGeneric - build-depends: base >= 4.7 && < 5 + build-depends: base >= 4.6 && < 5 , binary >= 0.7 , bytestring >= 0.9 , murmur-hash >= 0.1 @@ -70,9 +70,10 @@ other-modules: HUnit, QuickCheck other-extensions: ScopedTypeVariables, NumDecimals type: exitcode-stdio-1.0 - build-depends: base >= 4.7 && < 5 + build-depends: base , binary >= 0.7 , binary-typed + , bytestring , tasty >= 0.8 , tasty-hunit >= 0.8 , tasty-quickcheck >= 0.8 @@ -81,6 +82,7 @@ test-suite message-length default-language: Haskell2010 + ghc-options: -Wall type: exitcode-stdio-1.0 hs-source-dirs: benchmark main-is: MessageLength.hs @@ -94,6 +96,7 @@ benchmark criterion default-language: Haskell2010 + ghc-options: -Wall type: exitcode-stdio-1.0 hs-source-dirs: benchmark main-is: Criterion.hs @@ -108,6 +111,7 @@ benchmark criterion-overview default-language: Haskell2010 + ghc-options: -Wall type: exitcode-stdio-1.0 hs-source-dirs: benchmark main-is: CriterionOverview.hs diff --git a/doc/bench-overview.png b/doc/bench-overview.png Binary files a/doc/bench-overview.png and b/doc/bench-overview.png differ diff --git a/src/Data/Binary/Typed.hs b/src/Data/Binary/Typed.hs --- a/src/Data/Binary/Typed.hs +++ b/src/Data/Binary/Typed.hs @@ -16,7 +16,7 @@ , mapTyped , reValue , reType - , precache + , preserialize -- * Typed serialization @@ -36,7 +36,7 @@ import qualified Data.ByteString.Lazy as BSL -import Data.Typeable (Typeable) +import Data.Typeable (Typeable, typeOf) import Data.Binary import Data.Binary.Get (ByteOffset) @@ -81,44 +81,34 @@ -- | Encode a 'Typeable' value to 'BSL.ByteString' that includes type --- information. If at all possible, prefer the more efficient 'encodeTypedLike' --- though. +-- information. This function is useful to create specialized typed encoding +-- functions, because the type information is cached and does not need to be +-- recalculated on every serialization. -- --- @ --- 'encodeTyped' format value = 'encode' ('typed' format value) --- @ +-- Observationally, @'encodeTyped' format value@ is equivalent to +-- @'encode' ('typed' format value)@. However, 'encodeTyped' does the type +-- information related calculations in advance and shares the results between +-- future invocations of it, making it much more efficient to serialize many +-- values of the same type. encodeTyped :: (Typeable a, Binary a) => TypeFormat -> a -> BSL.ByteString -encodeTyped format value = encode (typed format value) +encodeTyped format = \x -> + let ty = preserialize (makeTypeInformation format (typeOf x)) + in encode (Typed ty x) --- | Version of 'encodeTyped' that avoids recomputing the type representation --- of the input by using the one already contained in the first parameter. --- This is usually /much/ more efficient than using 'encode', having a --- computational cost similar to using 'Binary' directly. --- --- @ --- 'encodeTypedLike' ty x --- -- is observationally identical to --- 'encode' ('reValue' ('const' x) ty) --- @ --- --- This function is intended to generate new encoding functions like so: --- --- @ --- encodeInt :: 'Int' -> 'Data.ByteString.Lazy.ByteString' --- encodeInt = 'encodeTypedLike' ('typed' 'Full' 0) --- @ -encodeTypedLike - :: (Typeable a, Binary a) +encodeTypedLike :: + (Typeable a, Binary a) => Typed a -> a -> BSL.ByteString -encodeTypedLike dummy = let (Typed ty _) = precache dummy - in encode . Typed ty +encodeTypedLike (Typed ty _) = encodeTyped (getFormat ty) + +{-# DEPRECATED encodeTypedLike + "'encodeTyped' now caches automatically for all types" #-} diff --git a/src/Data/Binary/Typed/Internal.hs b/src/Data/Binary/Typed/Internal.hs --- a/src/Data/Binary/Typed/Internal.hs +++ b/src/Data/Binary/Typed/Internal.hs @@ -10,19 +10,22 @@ -- * 'Typed' Typed(..) , TypeInformation(..) - , Hash(..) + , Hash32(..) + , Hash64(..) , typed + , makeTypeInformation , TypeFormat(..) , getFormat , typecheck , erase - , precache + , preserialize -- * 'TypeRep' , TypeRep(..) , stripTypeRep , unStripTypeRep - , hashType + , hashType32 + , hashType64 -- * 'TyCon' , TyCon(..) @@ -44,7 +47,8 @@ import Data.Binary -- Crypto stuff for hashing -import Data.Digest.Murmur64 +import qualified Data.Digest.Murmur32 as H32 +import qualified Data.Digest.Murmur64 as H64 @@ -52,10 +56,11 @@ -- recipient can do consistency checks. See 'TypeFormat' for more detailed -- information on the fields. data TypeInformation = Untyped' - | Hashed' Hash - | Shown' Hash String - | Full' TypeRep - | Cached' BSL.ByteString + | Hashed32' Hash32 + | Hashed64' Hash64 + | Shown' Hash32 String + | Full' TypeRep + | Cached' BSL.ByteString deriving (Eq, Ord, Show, Generic) instance Binary TypeInformation @@ -63,22 +68,33 @@ -- | Extract which 'TypeFormat' was used to create a certain 'TypeInformation'. +-- +-- If the type is 'Cached'', then the contained information is assumed +-- well-formed. In the public API, this is safe to do, since only well-typed +-- 'Typed' values can be created in the first place. getFormat :: TypeInformation -> TypeFormat -getFormat (Untyped' {}) = Untyped -getFormat (Hashed' {}) = Hashed -getFormat (Shown' {}) = Shown -getFormat (Full' {}) = Full -getFormat (Cached' bs) = getFormat (decode bs) - -- decode is safe here since caching ensures - -- a well-formed input ByteString +getFormat (Untyped' {}) = Untyped +getFormat (Hashed32' {}) = Hashed32 +getFormat (Hashed64' {}) = Hashed64 +getFormat (Shown' {}) = Shown +getFormat (Full' {}) = Full +getFormat (Cached' bs) = getFormat (decode bs) +-- | A hash value of a 'TypeRep'. Currently a 32-bit value created using +-- the MurmurHash2 algorithm. +newtype Hash32 = Hash32 Word32 + deriving (Eq, Ord, Show, Generic) +instance Binary Hash32 + + + -- | A hash value of a 'TypeRep'. Currently a 64-bit value created using -- the MurmurHash2 algorithm. -newtype Hash = Hash Word64 +newtype Hash64 = Hash64 Word64 deriving (Eq, Ord, Show, Generic) -instance Binary Hash +instance Binary Hash64 @@ -106,54 +122,86 @@ --- | Calculate the serialization of a 'TypeInformation' and store it in a --- 'Typed' value so it does not have to be recalculated on every call to --- 'encode'. +-- | Sometimes it can be beneficial to serialize the type information in +-- advance, so that the maybe costly serialization step does not have to be +-- repeated on every invocation of 'encode'. Preserialization comes at a price +-- though, as the directly contained 'BSL.ByteString'requires its length to +-- be included in the final serialization, yielding a 8-byte overhead for the +-- required 'Data.Int.Int64', and one for the tag of what was serialized +-- ("shown or full?"). -- --- This is typically applied to a dummy value created using 'typed' and --- the desired 'TypeFormat'; the actual data is then inserted using --- 'Data.Binary.Typed.reValue', which is how --- 'Data.Binary.Typed.encodeTyped' works. -precache :: Typed a -> Typed a -precache t@(Typed (Cached' _) _) = t -precache (Typed ty x) = Typed (Cached' (encode ty)) x - -- This is the only place that constructs a - -- Cached' value. +-- This function calculates the serialized version of 'TypeInformation' in +-- cases where the required 8 bytes are negligible (determined by an +-- arbitrary threshold, currently 10*9 bytes). +-- +-- Used to make 'Data.Binary.Typed.encodeTyped' more efficient; the source +-- there also makes a good usage example. +preserialize :: TypeInformation -> TypeInformation +preserialize x@(Cached' _) = x +preserialize x@(Untyped' ) = x +preserialize x@(Hashed32' _) = x +preserialize x@(Hashed64' _) = x +-- Explicit cases for Shown' and Full' so exhaustiveness can be checked when +-- new constructors are added. (The default pattern of just "x" would do right +-- now as well, but not provide that.) +preserialize x@(Shown' _ _) = preserialize' x +preserialize x@(Full' _) = preserialize' x +-- | Preserializes type information if its encoded byte length is larger than +-- an arbitrary threshold. Less efficient than 'preserialize' since it +-- always preserializes and always calculates the encoded version no matter +-- what. +preserialize' :: TypeInformation -> TypeInformation +preserialize' x | BSL.length encoded > 10*9 = Cached' encoded + | otherwise = x + where encoded = encode x + + + -- | Different ways of including/verifying type information of serialized -- messages. data TypeFormat = -- | Include no type information. -- - -- * Requires one byte more than using 'Binary' directly (namely to - -- tag the data as untyped, required for the decoding step). + -- * Requires one byte more compared to using 'Binary' directly + -- (to tag the data as untyped, required for the decoding step). Untyped -- | Compare types by their hash values (using the MurmurHash2 -- algorithm). -- - -- * Requires only 8 additional bytes for the type information. + -- * Requires five bytes more compared to using 'Binary' directly for + -- the type information (one to tag as 'Hashed32', four for the + -- hash value) -- * Subject to false positive due to hash collisions, although in -- practice this should almost never happen. -- * Type errors cannot tell the provided type ("Expected X, received -- type with hash H") + | Hashed32 - | Hashed + -- | Like 'Hashed32', but uses a 64-bit hash value. + -- + -- * Requires nine bytes more compared to using 'Binary'. + -- * Hash collisions are even less likely to occur than with + -- 'Hashed32'. + | Hashed64 -- | Compare 'String' representation of types, obtained by calling -- 'show' on the 'TypeRep', and also include a hash value - -- (like 'Hashed'). The former is mostly for readable error messages, - -- the latter provides collision resistance. + -- (like 'Hashed32'). The former is mostly for readable error + -- messages, the latter provides better collision resistance. -- - -- * Data size larger than 'Hashed', but usually smaller than 'Full'. + -- * Data size larger than 'Hashed32', but usually smaller than + -- 'Full'. -- * Both the hash and the shown type must match to satisfy the -- typechecker. -- * Useful type errors ("expected X, received Y"). All types are -- shown unqualified though, making @Foo.X@ and @Bar.X@ look - -- identical in error messages. + -- identical in error messages. Remember this when you get a + -- seemingly silly error "expected Foo, but given Foo". | Shown -- | Compare the full representation of a data type. @@ -167,7 +215,8 @@ -- type. -- * Useful type errors ("expected X, received Y"). All types are -- shown unqualified though, making @Foo.X@ and @Bar.X@ look - -- identical in error messages. + -- identical in error messages. Remember this when you get a + -- seemingly silly error "expected Foo, but given Foo". | Full deriving (Eq, Ord, Show) @@ -185,16 +234,23 @@ -- -- The decode site can now verify whether decoding happens with the right type. typed :: Typeable a => TypeFormat -> a -> Typed a -typed format x = Typed typeInformation x where - ty = typeOf x - typeInformation = case format of - Untyped -> Untyped' - Hashed -> Hashed' (hashType ty) - Shown -> Shown' (hashType ty) (show ty) - Full -> Full' (stripTypeRep ty) +typed format x = Typed (makeTypeInformation format (typeOf x)) x +-- | Create the 'TypeInformation' to be stored inside a 'Typed' value from +-- a 'Ty.TypeRep'. +makeTypeInformation :: TypeFormat -> Ty.TypeRep -> TypeInformation +makeTypeInformation format ty = case format of + Untyped -> Untyped' + Hashed32 -> Hashed32' (hashType32 ty) + Hashed64 -> Hashed64' (hashType64 ty) + Shown -> Shown' (hashType32 ty) (show ty) + Full -> Full' (stripTypeRep ty) + + + + -- | Extract the value of a 'Typed', i.e. strip off the explicit type -- information. -- @@ -215,25 +271,27 @@ typecheck :: Typeable a => Typed a -> Either String (Typed a) typecheck ty@(Typed typeInformation x) = case typeInformation of Cached' cache -> decode' cache >>= \ty' -> typecheck (Typed ty' x) - Full' full | exFull /= full -> Left (fullError full) - Hashed' hash | exHash /= hash -> Left (hashError hash) - Shown' hash str | (exHash, exShow) /= (hash, str) - -> Left (shownError hash str) + Full' full | exFull /= full -> Left (fullError full) + Hashed32' hash32 | exHash32 /= hash32 -> Left (hashError exHash32 hash32) + Hashed64' hash64 | exHash64 /= hash64 -> Left (hashError exHash64 hash64) + Shown' hash32 str | (exHash32, exShow) /= (hash32, str) + -> Left (shownError hash32 str) _no_type_error -> Right ty where -- ex = expected - exType = typeOf x - exHash = hashType exType - exShow = show exType - exFull = stripTypeRep exType + exType = typeOf x + exHash32 = hashType32 exType + exHash64 = hashType64 exType + exShow = show exType + exFull = stripTypeRep exType - hashError hash = printf pat exShow (show exHash) (show hash) + hashError eHash hash = printf pat exShow (show eHash) (show hash) where pat = "Type error: expected type %s with hash %s,\ \ but received data with hash %s" - shownError hash str = printf pat exShow (show exHash) str (show hash) + shownError hash str = printf pat exShow (show exHash32) str (show hash) where pat = "Type error: expected type %s and hash %s,\ \ but received data with type %s and hash %s" fullError full = printf pat exShow (show full) @@ -246,12 +304,18 @@ --- | Hash a 'Ty.TypeRep'. -hashType :: Ty.TypeRep -> Hash -hashType = Hash . asWord64 . hash64 . stripTypeRep +-- | Hash a 'Ty.TypeRep' to a 32-bit digest. +hashType32 :: Ty.TypeRep -> Hash32 +hashType32 = Hash32 . H32.asWord32 . H32.hash32 . stripTypeRep +-- | Hash a 'Ty.TypeRep' to a 64-bit digest. +hashType64 :: Ty.TypeRep -> Hash64 +hashType64 = Hash64 . H64.asWord64 . H64.hash64 . stripTypeRep + + + -- | 'Ty.TypeRep' without the (internal) fingerprint. data TypeRep = TypeRep TyCon [TypeRep] deriving (Eq, Ord, Generic) @@ -260,12 +324,15 @@ instance Show TypeRep where show = show . unStripTypeRep -instance Hashable64 TypeRep where - hash64Add (TypeRep tycon args) = hash64Add (tycon, args) +instance H32.Hashable32 TypeRep where + hash32Add (TypeRep tycon args) = H32.hash32Add (tycon, args) +instance H64.Hashable64 TypeRep where + hash64Add (TypeRep tycon args) = H64.hash64Add (tycon, args) + -- | 'Ty.TyCon' without the (internal) fingerprint. data TyCon = TyCon String String String -- ^ Package, module, constructor name deriving (Eq, Ord, Generic) @@ -274,8 +341,11 @@ instance Show TyCon where show = show . unStripTyCon -instance Hashable64 TyCon where - hash64Add (TyCon p m c) = hash64Add (p, m, c) +instance H32.Hashable32 TyCon where + hash32Add (TyCon p m c) = H32.hash32Add (p, m, c) + +instance H64.Hashable64 TyCon where + hash64Add (TyCon p m c) = H64.hash64Add (p, m, c) diff --git a/src/Data/Binary/Typed/Tutorial.hs b/src/Data/Binary/Typed/Tutorial.hs --- a/src/Data/Binary/Typed/Tutorial.hs +++ b/src/Data/Binary/Typed/Tutorial.hs @@ -68,7 +68,7 @@ -- $usage -- --- This package is typically used for debugging purposes. 'Hashed' type +-- This package is typically used for debugging purposes. 'Hashed32' type -- information keeps the size overhead relatively low, but requires a certain -- amount of computational ressources. It is reliable at detecting errors, but -- not very good at telling specifics about it. If a problem is identified, the @@ -83,29 +83,29 @@ -- -- @ -- test3 = let val = 10 :: 'Int' --- enc = 'encodeTyped' val +-- enc = 'encodeTyped' 'Hashed32' val -- dec = 'decodeTyped' enc :: 'Either' 'String' 'Bool' -- in 'print' dec -- @ -- --- However, using 'encodeTyped' is computationally inefficient when many --- messages of the same type are serialized, since it recomputes a serialized --- version of that type for every single serialized value from scratch. --- 'encodeTypedLike' exists to remedy that: it takes a separately constructed --- 'Typed' dummy value, and computes a new serialization function for that type --- out of it. This serialization function then re-uses the type representation --- of the dummy value, and simply replaces the contained value on each --- serialization so that no unnecessary overhead is introduced. +-- Using 'encodeTyped' in particular has a significant advantage: when used to +-- create new specialized encoding functions, the type information has to be +-- calculated only once, and can be shared among further invocations of the +-- function. In other words, using -- -- @ --- -- Computes 'Int's type representation 100 times: --- manyIntsNaive = map 'encodeTyped' [1..100 :: 'Int'] +-- encodeInt :: 'Int' -> 'Data.ByteString.Lazy.ByteString' +-- encodeInt = 'encodeTyped' 'Hashed32' +-- @ -- --- -- Much more efficient: prepare dummy value to precache the --- -- type representation, computing it only once: --- 'encodeInt' = 'encodeTypedLike' ('typed' 'Full' (0 :: 'Int')) --- manyIntsCached = map 'encodeInt' [1..100] +-- is much more efficient than +-- -- @ +-- encodeInt :: 'Int' -> 'Data.ByteString.Lazy.ByteString' +-- encodeInt = 'encode' . 'typed' 'Hashed32' +-- @ +-- +-- since the latter recalculates the hash of \"Int\" on every invocation. @@ -127,13 +127,11 @@ -- * 'mapTyped' (change values contained in 'Typed's) -- * 'reValue' (change value, but don't recompute type representation) -- * 'reType' (change type representation, but keep value) --- * 'precache' (compute serialized type representation, useful as an optimization) +-- * 'preserialize' (compute serialized type representation and cache it, useful as an optimization) -- --- Lastly, there are a number of encoding/decoding functions, mostly for --- convenience: +-- Lastly, there are a number of encoding/decoding functions: -- --- * 'encodeTyped' (pack in 'Typed' and then 'encode') --- * 'encodeTypedLike' (usually much more efficient version of 'encodeTyped') +-- * 'encodeTyped' (pack in 'Typed' and then 'encode', but more efficient) -- * 'decodeTyped' (decode 'Typed' 'Data.ByteString.Lazy.ByteString' to @'Either' 'String' a@) -- * 'decodeTypedOrFail' (like 'decodeTyped', but with more meta information) -- * 'unsafeDecodeTyped' (which throws a runtime error on type mismatch) diff --git a/tests/HUnit.hs b/tests/HUnit.hs --- a/tests/HUnit.hs +++ b/tests/HUnit.hs @@ -26,7 +26,7 @@ -- | The entire HUnit test tree, to be imported qualified props :: TestTree props = tree tests where - tree = testGroup "HUnit" + tree x = testGroup "HUnit" [ testGroup "Should be type errors" x ] tests = [ error_coercions_simple_large_to_small , error_coercions_simple_small_to_large , error_coercions_complicated @@ -56,22 +56,32 @@ -- memory (Bool). error_coercions_simple_large_to_small :: TestTree error_coercions_simple_large_to_small = tree tests where - tree = testGroup "Encode Int, decode Bool => Type error" - tests = [ error_int_bool_hashed + tree = testGroup "Encode Int, decode Bool" + tests = [ error_int_bool_hashed32 + , error_int_bool_hashed64 , error_int_bool_shown , error_int_bool_full ] -- | See 'error_coercions_simple_large_to_small' -error_int_bool_hashed :: TestTree -error_int_bool_hashed = - testCase "Hashed" $ +error_int_bool_hashed32 :: TestTree +error_int_bool_hashed32 = + testCase "Hashed32" $ - isLeft (wackyCoercion Hashed (123 :: Int) :: Either String Bool) + isLeft (wackyCoercion Hashed32 (123 :: Int) :: Either String Bool) @? - "No type error when coercing Int to Bool (with hashed type info)" + "No type error when coercing Int to Bool (with 32 bit hashed type info)" -- | See 'error_coercions_simple_large_to_small' +error_int_bool_hashed64 :: TestTree +error_int_bool_hashed64 = + testCase "Hashed64" $ + + isLeft (wackyCoercion Hashed64 (123 :: Int) :: Either String Bool) + @? + "No type error when coercing Int to Bool (with 64 bit hashed type info)" + +-- | See 'error_coercions_simple_large_to_small' error_int_bool_shown :: TestTree error_int_bool_shown = testCase "Shown" $ @@ -97,22 +107,32 @@ -- memory (Bool). error_coercions_simple_small_to_large :: TestTree error_coercions_simple_small_to_large = tree tests where - tree = testGroup "Encode Bool, decode Int => Type error" - tests = [ error_bool_int_hashed + tree = testGroup "Encode Bool, decode Int" + tests = [ error_bool_int_hashed32 + , error_bool_int_hashed64 , error_bool_int_shown , error_bool_int_full ] -- | See 'error_coercions_simple_small_to_large' -error_bool_int_hashed :: TestTree -error_bool_int_hashed = - testCase "Hashed" $ +error_bool_int_hashed32 :: TestTree +error_bool_int_hashed32 = + testCase "Hashed32" $ - isLeft (wackyCoercion Hashed True :: Either String Int) + isLeft (wackyCoercion Hashed32 True :: Either String Int) @? - "No type error when coercing Bool to Int (with hashed type info)" + "No type error when coercing Bool to Int (with 32 bit hashed type info)" -- | See 'error_coercions_simple_small_to_large' +error_bool_int_hashed64 :: TestTree +error_bool_int_hashed64 = + testCase "Hashed64" $ + + isLeft (wackyCoercion Hashed64 True :: Either String Int) + @? + "No type error when coercing Bool to Int (with 64 bit hashed type info)" + +-- | See 'error_coercions_simple_small_to_large' error_bool_int_shown :: TestTree error_bool_int_shown = testCase "Shown" $ @@ -145,7 +165,8 @@ error_coercions_complicated :: TestTree error_coercions_complicated = tree tests where tree = testGroup "Complicated type coercion with small discrepancy" - tests = [ error_long_type_hashed + tests = [ error_long_type_hashed32 + , error_long_type_hashed64 , error_long_type_shown , error_long_type_full ] @@ -153,13 +174,24 @@ -- | See 'error_coercions_complicated' -error_long_type_hashed :: TestTree -error_long_type_hashed = - testCase "Hashed" $ +error_long_type_hashed32 :: TestTree +error_long_type_hashed32 = + testCase "Hashed32" $ - isLeft (wackyCoercion Hashed long_type_input `asTypeOf` long_type_output) + isLeft (wackyCoercion Hashed32 long_type_input `asTypeOf` long_type_output) @? - "No type error doing a complicated coercion (with hashed type info)" + "No type error doing a complicated coercion (with 32 bit hashed type info)" + + + +-- | See 'error_coercions_complicated' +error_long_type_hashed64 :: TestTree +error_long_type_hashed64 = + testCase "Hashed64" $ + + isLeft (wackyCoercion Hashed64 long_type_input `asTypeOf` long_type_output) + @? + "No type error doing a complicated coercion (with 64 bit hashed type info)" diff --git a/tests/QuickCheck.hs b/tests/QuickCheck.hs --- a/tests/QuickCheck.hs +++ b/tests/QuickCheck.hs @@ -1,11 +1,14 @@ {-# LANGUAGE NumDecimals #-} +{-# LANGUAGE RankNTypes #-} module QuickCheck (props) where import Control.Applicative import Data.Typeable (Typeable) +import Data.Int +import Data.ByteString.Lazy as BSL import Data.Binary import Data.Binary.Typed import Data.Binary.Typed.Internal @@ -21,14 +24,22 @@ props :: TestTree props = tree tests where tree = testGroup "QuickCheck" - tests = [ prop_typerep - , prop_inverses + tests = [ prop_inverses , prop_api , prop_internal + , prop_sizes ] + + +-- ############################################################################# +-- ### Decode is left-inverse to encode ###################################### +-- ############################################################################# + + + -- | Check whether typed encoding and decoding are inverses of each other prop_inverses :: TestTree prop_inverses = tree tests where @@ -44,80 +55,44 @@ prop_inverses_int = tree tests where tree = localOption (QuickCheckMaxSize maxBound) - . localOption (QuickCheckTests 1e3) . testGroup "Int" - tests = [ testProperty "Untyped" (prop Untyped) - , testProperty "Hashed" (prop Hashed) - , testProperty "Shown" (prop Shown) - , testProperty "Full" (prop Full) - , testProperty "Cached" prop_cached + tests = [ testProperty "Untyped" (prop Untyped) + , testProperty "Hashed32" (prop Hashed32) + , testProperty "Hashed64" (prop Hashed64) + , testProperty "Shown" (prop Shown) + , testProperty "Full" (prop Full) ] prop :: TypeFormat -> Int -> Bool prop format i = unsafeDecodeTyped (encodeTyped format i) == i - prop_cached :: Typed Int -> Int -> Bool - prop_cached dummy i = unsafeDecodeTyped (encodeTypedLike dummy i) == i - -- | Check whether encoding and decoding a String works properly prop_inverses_string :: TestTree prop_inverses_string = tree tests where tree = localOption (QuickCheckMaxSize 100) - . localOption (QuickCheckTests 1e3) . testGroup "String" - tests = [ testProperty "Untyped" (prop Untyped) - , testProperty "Hashed" (prop Hashed) - , testProperty "Shown" (prop Shown) - , testProperty "Full" (prop Full) - , testProperty "Cached" prop_cached + tests = [ testProperty "Untyped" (prop Untyped) + , testProperty "Hashed32" (prop Hashed32) + , testProperty "Hashed64" (prop Hashed64) + , testProperty "Shown" (prop Shown) + , testProperty "Full" (prop Full) ] prop :: TypeFormat -> String -> Bool prop format i = unsafeDecodeTyped (encodeTyped format i) == i - prop_cached :: Typed String -> String -> Bool - prop_cached dummy i = unsafeDecodeTyped (encodeTypedLike dummy i) == i --- | Test properties of 'TypeRep's and 'TyCon's. -prop_typerep :: TestTree -prop_typerep = tree tests where - tree = localOption (QuickCheckTests 1e3) - . localOption (QuickCheckMaxSize 10) - . testGroup "TypeRep, TyCon" - tests = [ prop_hash_total - ] - - - --- | Generate lots of hashes from random 'typeRep's and see whether one of them --- crashes. -prop_hash_total :: TestTree -prop_hash_total = testProperty "Hash function total" prop where - prop = forAll arbitrary - (\tyCon -> hashType (unStripTypeRep tyCon) `seq` True) - - - -instance Arbitrary TyCon where - arbitrary = TyCon <$> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary TypeRep where - arbitrary = TypeRep <$> arbitrary <*> args - where args = listOf (modifySize (`div` 2) arbitrary) - - - --- | Modify the size parameter of a 'Gen'. -modifySize :: (Int -> Int) -> Gen a -> Gen a -modifySize f gen = sized (\n -> resize (f n) gen) +-- ############################################################################# +-- ### API tests ############################################################# +-- ############################################################################# @@ -127,12 +102,11 @@ tree = testGroup "API" - tests = [ testProperty "erase" prop_erase - , testProperty "mapTyped id law" prop_mapTyped_id - , testProperty "mapTyped f.g law" prop_mapTyped_compose - , testProperty "reType" prop_reType - , testProperty "encodeTyped" prop_encodeTyped - , testProperty "encodeTypedLike" prop_encodeTypedLike + tests = [ testProperty "erase inverse of typed" prop_erase + , testProperty "mapTyped id ~ id" prop_mapTyped_id + , testProperty "mapTyped f.g ~ mapTyped f . mapTyped g" prop_mapTyped_compose + , testProperty "reType equivalent to reconstruction" prop_reType + , testProperty "encodeTyped = encode.typed" prop_encodeTyped ] prop_erase :: TypeFormat -> Int -> Bool @@ -154,13 +128,9 @@ prop_encodeTyped :: TypeFormat -> Int -> Bool prop_encodeTyped format value = - encodeTyped format value == encode (typed format value) - - prop_encodeTypedLike :: Typed Int -> Int -> Bool - prop_encodeTypedLike ty value = - (unsafeDecodeTyped (encodeTypedLike ty value) :: Int) + (unsafeDecodeTyped (encodeTyped format value) :: Int) == - unsafeDecodeTyped (encode (reValue (const value) ty)) + (unsafeDecodeTyped (encode (typed format value)) :: Int) @@ -183,22 +153,115 @@ instance (Arbitrary a, Typeable a) => Arbitrary (Typed a) where arbitrary = frequency [(10, plain), (5, cached), (3, cached2)] where plain = typed <$> arbitrary <*> arbitrary - cached = fmap precache plain - cached2 = fmap precache cached + cached = fmap preserializeTyped plain + cached2 = fmap preserializeTyped cached + preserializeTyped (Typed ty x) = Typed (preserialize ty) x instance Arbitrary TypeFormat where - arbitrary = elements [Untyped, Hashed, Shown, Full] + arbitrary = elements [Untyped, Hashed32, Hashed64, Shown, Full] + +-- ############################################################################# +-- ### Internal functions #################################################### +-- ############################################################################# + + + prop_internal :: TestTree prop_internal = tree tests where tree = testGroup "Internal" - tests = [ testProperty "getFormat" prop_getFormat + tests = [ localOption (QuickCheckMaxSize 10) + (testProperty "stripTypeRep . unStripTypeRep = id" + prop_stripTypeRep_inverses) + , testProperty "stripTyCon . unStripTyCon = id" + prop_stripTyCon_inverses + , testProperty "getFormat extracts format correctly" + prop_getFormat ] - -- getFormat extracts the right format - prop_getFormat :: Typed Double -> Bool - prop_getFormat t@(Typed ty x) = t `isEqual` typed (getFormat ty) x + +-- getFormat extracts the right format +prop_getFormat :: Typed Double -> Bool +prop_getFormat t@(Typed ty x) = t `isEqual` typed (getFormat ty) x + + +prop_stripTypeRep_inverses :: TypeRep -> Bool +prop_stripTypeRep_inverses x = (stripTypeRep . unStripTypeRep) x == x + +prop_stripTyCon_inverses :: TyCon -> Bool +prop_stripTyCon_inverses x = (stripTyCon . unStripTyCon) x == x + + + + +instance Arbitrary TyCon where + arbitrary = TyCon <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary TypeRep where + arbitrary = TypeRep <$> arbitrary <*> args + where args = listOf (modifySize (`div` 2) arbitrary) + + + +-- | Modify the size parameter of a 'Gen'. +modifySize :: (Int -> Int) -> Gen a -> Gen a +modifySize f gen = sized (\n -> resize (f n) gen) + + + + + +-- ############################################################################# +-- ### Encoding sizes ######################################################## +-- ############################################################################# + + + +-- | Are the additional message sizes stated by the docs accurate? +-- +-- Untyped: +1 byte +-- Hashed32: +5 byte +-- Hashed64: +9 byte +prop_sizes :: TestTree +prop_sizes = tree tests where + + tree = testGroup "Data sizes" + + tests = [ testProperty "Untyped: +1 byte" + (prop_size_added (encodeTyped Untyped) 1) + , testProperty "Hashed32: +5 byte" + (prop_size_added (encodeTyped Hashed32) 5) + , testProperty "Hashed64: +9 byte" + (prop_size_added (encodeTyped Hashed64) 9) + ] + + +type Complicated = Either (Char, Int) (Either String (Maybe Integer)) + +-- | Check whether data created with a certain format has a certain +-- overhead over the direct Binary serialization. +prop_size_added :: + (forall a. (Typeable a, Binary a) => a -> BSL.ByteString) + -> Int64 + -> Property +prop_size_added serializer n = + conjoin [ forAll arbitrary (verify :: Integer -> Bool) + , forAll arbitrary (verify :: Double -> Bool) + , forAll arbitrary (verify :: [Double] -> Bool) + , forAll arbitrary (verify :: Complicated -> Bool) + ] + + where + + binSize :: Binary a => a -> Int64 + binSize = BSL.length . encode + + typedSize :: (Binary a, Typeable a) => a -> Int64 + typedSize = BSL.length . serializer + + verify :: (Binary a, Typeable a) => a -> Bool + verify x = binSize x + n == typedSize x