binary-typed 0.2.1.0 → 0.2.2
raw patch · 4 files changed
+117/−8 lines, 4 files
Files
- binary-typed.cabal +1/−1
- src/Data/Binary/Typed.hs +0/−1
- src/Data/Binary/Typed/Internal.hs +89/−4
- tests/QuickCheck.hs +27/−2
binary-typed.cabal view
@@ -1,5 +1,5 @@ name: binary-typed-version: 0.2.1.0+version: 0.2.2 synopsis: Type-safe binary serialization Description: `Binary` serialization tagged with type information, allowing for
src/Data/Binary/Typed.hs view
@@ -4,7 +4,6 @@ -- For usage information, see the "Data.Binary.Typed.Tutorial" module. {-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_HADDOCK show-extensions #-} module Data.Binary.Typed (
src/Data/Binary/Typed/Internal.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE DeriveGeneric #-}-{-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE LambdaCase #-} @@ -11,6 +11,8 @@ -- * 'Typed' Typed(..) , TypeInformation(..)+ , Hash5(..)+ , mkHash5 , Hash32(..) , Hash64(..) , typed@@ -25,6 +27,8 @@ , TypeRep(..) , stripTypeRep , unStripTypeRep+ , hashType5+ , hashed5Split , hashType32 , hashType64 @@ -39,6 +43,8 @@ import GHC.Generics import Text.Printf+import Data.Bits ((.&.), (.|.))+import Control.Applicative -- import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL @@ -57,6 +63,7 @@ -- recipient can do consistency checks. See 'TypeFormat' for more detailed -- information on the fields. data TypeInformation = Untyped'+ | Hashed5' Hash5 | Hashed32' Hash32 | Hashed64' Hash64 | Shown' Hash32 String@@ -64,10 +71,44 @@ | Cached' BSL.ByteString deriving (Eq, Ord, Show, Generic) -instance Binary TypeInformation+instance Binary TypeInformation where+ put Untyped' = putWord8 0+ put (Hashed5' (Hash5 x)) = putWord8 (x .|. 1) -- See 'Hash5' for info+ put (Hashed32' x) = putWord8 2 >> put x+ put (Hashed64' x) = putWord8 3 >> put x+ put (Shown' x y) = putWord8 4 >> put x >> put y+ put (Full' x) = putWord8 5 >> put x+ put (Cached' x) = putWord8 6 >> put x + get = getWord8 >>= \case+ 0 -> return Untyped'+ -- "1" case handled at the end+ 2 -> fmap Hashed32' get+ 3 -> fmap Hashed64' get+ 4 -> liftA2 Shown' get get+ 5 -> fmap Full' get+ 6 -> fmap Cached' get+ n -> case hashed5Split n of+ (1, hash) -> return (Hashed5' hash)+ _ -> fail ("Invalid TypeInformation (tag: " ++ show (hashed5Split n) ++ ")") ++-- | Split a 'Word8' into the last 3 bit (used to tag the constructor) and+-- the first 5 (data payload). Used by the 'Binary' instance of+-- 'TypeInformation'.+hashed5Split :: Word8 -> (Word8, Hash5)+hashed5Split x = let hash = mkHash5 x+ tag = getHashed5Tag x+ in (tag, hash)++++getHashed5Tag :: Word8 -> Word8+getHashed5Tag = (.&. 0x7) -- = 00000111+++ -- | Extract which 'TypeFormat' was used to create a certain 'TypeInformation'. -- -- If the type is 'Cached'', then the contained information is assumed@@ -75,6 +116,7 @@ -- 'Typed' values can be created in the first place. getFormat :: TypeInformation -> TypeFormat getFormat (Untyped' {}) = Untyped+getFormat (Hashed5' {}) = Hashed5 getFormat (Hashed32' {}) = Hashed32 getFormat (Hashed64' {}) = Hashed64 getFormat (Shown' {}) = Shown@@ -83,6 +125,27 @@ +-- | A hash value of a 'TypeRep'. Currently a 5-bit value created using+-- the MurmurHash2 algorithm.+--+-- Since 'TypeInformation' needs 3 bit to store the sort of the+-- 'TypeInformation', the remaining 5 bit per 'Word8' can be used to store a+-- hash value at no additional space cost. For this reason, it is important that+-- the three rightmost bits of any 'Hashed5' are set to zero.+--+-- This type intentionally doesn't have a 'Binary' instance, since its+-- serialization is part of the 'TypeInformation' 'Binary' class exclusively.+newtype Hash5 = Hash5 Word8+ deriving (Eq, Ord, Show)++-- | Smart constructor for 'Hash5' values. Makes sure the rightmost three bits+-- are not set by applying a bit mask to the input.+mkHash5 :: Integral a => a -> Hash5+mkHash5 x = Hash5 (fromIntegral x .&. 0xF8)+ -- = 11111000+++ -- | A hash value of a 'TypeRep'. Currently a 32-bit value created using -- the MurmurHash2 algorithm. newtype Hash32 = Hash32 Word32@@ -140,6 +203,7 @@ preserialize :: TypeInformation -> TypeInformation preserialize x@(Cached' {}) = x preserialize x@(Untyped' {}) = x+preserialize x@(Hashed5' {}) = x preserialize x@(Hashed32' {}) = x preserialize x@(Hashed64' {}) = x -- Explicit cases for Shown' and Full' so exhaustiveness can be checked when@@ -175,6 +239,18 @@ -- 'Binary'. Untyped + -- | Like 'Hashed32', but uses a 5-bit hash value.+ --+ -- * Requires the same amount of space as 'Untyped', i.e. the only+ -- overhead compared to it is the computational cost to calculate+ -- the hash, which is almost identical to the one of 'Hashed32'.+ --+ -- * Collisions occur with a probability of 1/2^5 = 1/32. For this+ -- reason, this format is only recommended when minimal data size+ -- is top priority.+ --+ | Hashed5+ -- | Compare types by their hash values (using the MurmurHash2 -- algorithm). --@@ -257,6 +333,7 @@ makeTypeInformation :: TypeFormat -> Ty.TypeRep -> TypeInformation makeTypeInformation format ty = case format of Untyped -> Untyped'+ Hashed5 -> Hashed5' (hashType5 ty) Hashed32 -> Hashed32' (hashType32 ty) Hashed64 -> Hashed64' (hashType64 ty) Shown -> Shown' (hashType32 ty) (show ty)@@ -285,11 +362,12 @@ 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)+ Full' full | exFull /= full -> Left (fullError full)+ Hashed5' hash5 | exHash5 /= hash5 -> Left (hashError exHash5 hash5) 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)+ -> Left (shownError hash32 str) _no_type_error -> Right ty @@ -297,6 +375,7 @@ -- ex = expected exType = typeOf x+ exHash5 = hashType5 exType exHash32 = hashType32 exType exHash64 = hashType64 exType exShow = show exType@@ -315,6 +394,12 @@ decode' bs = case decodeOrFail bs of Left (_,_,err) -> Left ("Cache error! " ++ err) Right (_,_,val) -> Right val++++-- | Hash a 'Ty.TypeRep' to a 5-bit digest.+hashType5 :: Ty.TypeRep -> Hash5+hashType5 = mkHash5 . H32.asWord32 . H32.hash32 . stripTypeRep
tests/QuickCheck.hs view
@@ -7,8 +7,9 @@ import Control.Applicative import Data.Typeable (Typeable) import Data.Int+import Data.Bits ((.&.), (.|.)) -import Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy as BSL import Data.Binary import Data.Binary.Typed import Data.Binary.Typed.Internal@@ -58,6 +59,7 @@ . testGroup "Int" tests = [ testProperty "Untyped" (prop Untyped)+ , testProperty "Hashed5" (prop Hashed5) , testProperty "Hashed32" (prop Hashed32) , testProperty "Hashed64" (prop Hashed64) , testProperty "Shown" (prop Shown)@@ -77,6 +79,7 @@ . testGroup "String" tests = [ testProperty "Untyped" (prop Untyped)+ , testProperty "Hashed5" (prop Hashed5) , testProperty "Hashed32" (prop Hashed32) , testProperty "Hashed64" (prop Hashed64) , testProperty "Shown" (prop Shown)@@ -158,7 +161,7 @@ preserializeTyped (Typed ty x) = Typed (preserialize ty) x instance Arbitrary TypeFormat where- arbitrary = elements [Untyped, Hashed32, Hashed64, Shown, Full]+ arbitrary = elements [Untyped, Hashed5, Hashed32, Hashed64, Shown, Full] @@ -181,6 +184,11 @@ prop_stripTyCon_inverses , testProperty "getFormat extracts format correctly" prop_getFormat+ , localOption (QuickCheckMaxSize 10)+ (testProperty "Hash5 has 3 rightmost bits zero"+ prop_hash5_zero)+ , testProperty "hash5Split invertible"+ prop_hash5Split_invertible ] @@ -195,9 +203,24 @@ prop_stripTyCon_inverses :: TyCon -> Bool prop_stripTyCon_inverses x = (stripTyCon . unStripTyCon) x == x +-- | Does every hashed 'TypeRep' result in a 'Hash5' that has its three+-- rightmost bits zero?+prop_hash5_zero :: TypeRep -> Bool+prop_hash5_zero x = let Hash5 x' = hashType5 (unStripTypeRep x)+ in 7 Data.Bits..&. x' == 0+ -- 7 = 00000111 +-- | Splitting and putting the numbers together again should be the identity+prop_hash5Split_invertible :: Word8 -> Bool+prop_hash5Split_invertible x =+ let (tag, Hash5 hash) = hashed5Split x+ in x == tag .|. hash ++++ instance Arbitrary TyCon where arbitrary = TyCon <$> arbitrary <*> arbitrary <*> arbitrary @@ -233,6 +256,8 @@ tests = [ testProperty "Untyped: +1 byte" (prop_size_added (encodeTyped Untyped) 1)+ , testProperty "Hashed5: +1 byte"+ (prop_size_added (encodeTyped Hashed5) 1) , testProperty "Hashed32: +5 byte" (prop_size_added (encodeTyped Hashed32) 5) , testProperty "Hashed64: +9 byte"