binary-typed 0.1.0.1 → 0.2.0.0

raw patch · 10 files changed

+416/−360 lines, 10 filesdep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, bytestring

API changes (from Hackage documentation)

Files

• benchmark/Criterion.hs +7/−94
• benchmark/CriterionOverview.hs +13/−34
• benchmark/MessageLength.hs +31/−24
• binary-typed.cabal +9/−5
• doc/bench-overview.png binary
• src/Data/Binary/Typed.hs +19/−29
• src/Data/Binary/Typed/Internal.hs +132/−62
• src/Data/Binary/Typed/Tutorial.hs +19/−21
• tests/HUnit.hs +53/−21
• tests/QuickCheck.hs +133/−70

@@ -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

@@ -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'

@@ -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

@@ -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:       .-      <<http://i.imgur.com/nY6hgMP.png>>+      <<http://i.imgur.com/JzhYqGZ.png>>       .       <doc/bench-overview.png (local copy)> 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

binary file changed (22136 → 21408 bytes)

@@ -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" #-}   

@@ -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)   

@@ -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)

@@ -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)"   

@@ -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