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.2.1.0 +version: 0.2.2 synopsis: Type-safe binary serialization Description: `Binary` serialization tagged with type information, allowing for 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 @@ -4,7 +4,6 @@ -- For usage information, see the "Data.Binary.Typed.Tutorial" module. {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_HADDOCK show-extensions #-} module Data.Binary.Typed ( 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 @@ -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 diff --git a/tests/QuickCheck.hs b/tests/QuickCheck.hs --- a/tests/QuickCheck.hs +++ b/tests/QuickCheck.hs @@ -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"