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.3 +version: 0.3 synopsis: Type-safe binary serialization Description: `Binary` serialization tagged with type information, allowing for @@ -35,9 +35,9 @@ bug-reports: https://github.com/quchen/binary-typed/issues license: BSD2 license-file: LICENSE -author: David Luposchainsky -maintainer: dluposchainsky on googles email service -copyright: David Luposchainsky +author: David Luposchainsky +maintainer: David Luposchainsky +copyright: David Luposchainsky category: Data, Serialization build-type: Simple cabal-version: >= 1.10 @@ -52,6 +52,7 @@ library default-language: Haskell2010 exposed-modules: Data.Binary.Typed + Data.Binary.Typed.Debug Data.Binary.Typed.Internal Data.Binary.Typed.Tutorial ghc-options: -Wall @@ -68,7 +69,9 @@ ghc-options: -Wall -fno-warn-orphans hs-source-dirs: tests main-is: Tests.hs - other-modules: HUnit, QuickCheck + other-modules: HUnit + , QuickCheck + , APIConsistency other-extensions: ScopedTypeVariables, NumDecimals type: exitcode-stdio-1.0 build-depends: base diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -51,3 +51,12 @@ recalculating the `TypeRep` of the expected type, which previously was the bottleneck. Both encoding and decoding speeds are now very close to untyped `Binary`. + + + +## 0.3 + +- Add `Debug` module, which is a drop-in replacement for the ordinary API. + However, a message is emitted via `Debug.Trace` every time a type + representation is calculated, which makes it possible to debug proper + sharing/caching. 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 @@ -6,9 +6,11 @@ -- | Defines a type-safe 'Data.Binary.Binary' instance to ensure data is --- decoded with the type it was serialized from. +-- ecoded with the type it was serialized from. -- --- For usage information, see the "Data.Binary.Typed.Tutorial" module. +-- * The "Data.Binary.Typed.Tutorial" provides some more examples of usage. +-- * The "Data.Binary.Typed.Debug" is useful to ensure calculated type +-- representations are shared properly. module Data.Binary.Typed ( -- * Core functions @@ -29,7 +31,6 @@ -- ** Encoding , encodeTyped - , encodeTypedLike -- ** Decoding , decodeTyped @@ -110,18 +111,7 @@ -encodeTypedLike :: - (Typeable a, Binary a) - => Typed a - -> a - -> BSL.ByteString -encodeTypedLike (Typed ty _) = encodeTyped (getFormat ty) -{-# DEPRECATED encodeTypedLike - "'encodeTyped' now caches automatically for all types. Will be removed in 0.3." #-} - - - -- | Decode a typed value, throwing a descriptive 'error' at runtime on failure. -- Typed cousin of 'Data.Binary.decode'. Based on 'decodeTypedOrFail'. -- @@ -138,10 +128,10 @@ => BSL.ByteString -> a unsafeDecodeTyped = \x -> case decodeTypedOrFail x of - Left (_, _, err) -> error ("unsafeDecodeTyped' failure: " ++ err) - Right (_, _, value) -> value + Left (_,_,err) -> error ("unsafeDecodeTyped' failure: " ++ err) + Right (_,_,value) -> value -{-# INLINE unsafeDecodeTyped #-} +{-# INLINE unsafeDecodeTyped #-} -- Inlining is crucial for caching to work! @@ -162,10 +152,10 @@ => BSL.ByteString -> Either String a decodeTyped = \x -> case decodeTypedOrFail x of - Left (_, _, err) -> Left err - Right (_, _, value) -> Right value + Left (_,_,err) -> Left err + Right (_,_,value) -> Right value -{-# INLINE decodeTyped #-} +{-# INLINE decodeTyped #-} -- Inlining is crucial for caching to work! diff --git a/src/Data/Binary/Typed/Debug.hs b/src/Data/Binary/Typed/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Typed/Debug.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +-- | This module has the same interface as "Data.Binary.Typed", but emits +-- debugging messages via "Debug.Trace" whenever a 'TypeInformation' is +-- calculated. This is useful to determine whether caching works properly, +-- i.e. if a single serialization point emity a lot of caching messages +-- it's worth having a look at. +-- +-- A simple example to check sharing is to evaluate +-- +-- @ +-- 'map' ('encodeTyped' 'Hashed5') "hello world!" +-- @ +-- +-- This should print only one debug message "TypeRep/Hashed5 calculated", +-- since the encoding function is shared between all invocations. + + + +module Data.Binary.Typed.Debug ( + + -- * Core functions + Normal.Typed + , typed + , Normal.TypeFormat(..) + , Internal.erase + + + -- * Useful general helpers + , Normal.mapTyped + , Normal.reValue + , reType + , Internal.preserialize + + + -- * Typed serialization + + -- ** Encoding + , encodeTyped + + -- ** Decoding + , decodeTyped + , decodeTypedOrFail + , unsafeDecodeTyped + +) where + + + +import qualified Data.ByteString.Lazy as BSL + +import Data.Typeable (Typeable, typeRep, Proxy(..), typeOf) +import qualified Data.Typeable as Ty + +import Data.Binary +import Data.Binary.Get (ByteOffset) + +import qualified Data.Binary.Typed as Normal +import Data.Binary.Typed.Internal as Internal hiding (makeTypeInformation) +import qualified Data.Binary.Typed.Internal as Internal (makeTypeInformation) + +import qualified Debug.Trace as Debug + + + +-- | Similar to 'makeTypeInformation', but prints a message each time it's +-- forced. +makeTypeInformationDebug :: TypeFormat -> Ty.TypeRep -> TypeInformation +makeTypeInformationDebug format typerep = + let message = "TypeRep/" ++ show format ++ " calculated" + in Debug.trace message (Internal.makeTypeInformation format typerep) + + + +-- | Change the way a type is represented inside a 'Typed' value. +-- +-- @ +-- 'reType' format x = 'typed' format ('erase' x) +-- @ +reType :: Typeable a => TypeFormat -> Typed a -> Typed a +reType format (Typed _ty x) = Typed (makeTypeInformationDebug format (typeOf x)) x + + + + + + + + + + + + + + + + + +-- ########################################################################## +-- ### ### +-- ### What follows was simply copied from the normal module, replacing ### +-- ### makeTypeInformation with makeTypeInformationDebug. ### +-- ### ### +-- ########################################################################## + + + +-- | Encode a 'Typeable' value to 'BSL.ByteString' that includes type +-- 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. +-- +-- 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 :: forall a. + (Typeable a, Binary a) + => TypeFormat + -> a + -> BSL.ByteString +encodeTyped format = \x -> encode (Typed typeInfo x) + where typeInfo = preserialize (makeTypeInformationDebug format typerep) + typerep = typeRep (Proxy :: Proxy a) + +{-# INLINE encodeTyped #-} + + + + +-- | Decode a typed value, throwing a descriptive 'error' at runtime on failure. +-- Typed cousin of 'Data.Binary.decode'. Based on 'decodeTypedOrFail'. +-- +-- @ +-- encoded = 'encodeTyped' 'Full' ("hello", 1 :: 'Int', 2.34 :: 'Double') +-- +-- -- \ +-- 'unsafeDecodeTyped' encoded :: ('String', 'Int', 'Double') +-- +-- -- (Descriptive) runtime 'error' +-- 'unsafeDecodeTyped' encoded :: ('Char', 'Int', 'Double') +-- @ +unsafeDecodeTyped :: (Typeable a, Binary a) + => BSL.ByteString + -> a +unsafeDecodeTyped = \x -> case decodeTypedOrFail x of + Left (_,_,err) -> error ("unsafeDecodeTyped' failure: " ++ err) + Right (_,_,value) -> value + +{-# INLINE unsafeDecodeTyped #-} -- Inlining is crucial for caching to work! + + + +-- | Safely decode data, yielding 'Either' an error 'String' or the value. +-- Equivalent to 'decodeTypedOrFail' stripped of the non-essential data. +-- Based on 'decodeTypedOrFail'. +-- +-- @ +-- encoded = 'encodeTyped' 'Full' ("hello", 1 :: 'Int', 2.34 :: 'Double') +-- +-- -- Right \: +-- 'decodeTyped' encoded :: 'Either' 'String' ('String', 'Int', 'Double') +-- +-- -- Left "Type error: expected (Char, Int, Double), got (String, Int, Double)" +-- 'decodeTyped' encoded :: 'Either' 'String' ('Char', 'Int', 'Double') +-- @ +decodeTyped :: (Typeable a, Binary a) + => BSL.ByteString + -> Either String a +decodeTyped = \x -> case decodeTypedOrFail x of + Left (_,_,err) -> Left err + Right (_,_,value) -> Right value + +{-# INLINE decodeTyped #-} -- Inlining is crucial for caching to work! + + + +-- | Safely decode data, yielding 'Either' an error 'String' or the value, +-- along with meta-information of the consumed binary data. +-- +-- * Typed cousin of 'Data.Binary.decodeOrFail'. +-- +-- * Like 'decodeTyped', but with additional data. +-- +-- * Automatically caches 'Hashed5', 'Hashed32' and 'Hashed64' representations, +-- so that typechecking does not need to recalculate them on every decoding. +decodeTypedOrFail :: forall a. + (Typeable a, Binary a) + => BSL.ByteString + -> Either (BSL.ByteString, ByteOffset, String) + (BSL.ByteString, ByteOffset, a) +decodeTypedOrFail = \input -> do + (rest, offset, typed'@(Typed' ty value)) <- decodeOrFail input + let addMeta x = (rest, offset, x) + if isCached ty + then Right (addMeta value) -- cache hit, don't typecheck + else case typecheck' typed' of -- cache miss, typecheck manually + Left err -> Left (addMeta err) + Right _ -> Right (addMeta value) + + where + + exTypeRep = typeRep (Proxy :: Proxy a) + cache = map (\format -> makeTypeInformationDebug format exTypeRep) + [Hashed5, Hashed32, Hashed64] -- List of formats to be cached + isCached = (`elem` cache) + +{-# INLINE decodeTypedOrFail #-} -- Inlining is crucial for caching to work! 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 @@ -80,11 +80,11 @@ 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 + 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' @@ -189,12 +189,14 @@ -- in this particular way. ty <- get value <- get - either fail return (typecheck (Typed ty value)) - -- NB: 'fail' is safe in Get Monad - put (Typed ty value) = put ty >> put value + case typecheck (Typed ty value) of + Left err -> fail err -- NB: 'fail' is safe in Get Monad + Right wellTyped -> return wellTyped + put (Typed ty value) = put ty *> put value + -- | Like 'Typed', but the type information is not checked. Useful to read type -- and value, and do the typechecking externally, as required by the caching -- of 'Data.Binary.Typed.decodeTyped'. Using 'typecheck'', this can be promoted @@ -209,7 +211,7 @@ instance (Binary a) => Binary (Typed' a) where get = liftA2 Typed' get get - put (Typed' ty value) = put ty >> put value + put (Typed' ty value) = put ty *> put value @@ -349,14 +351,12 @@ -- | 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' - Hashed5 -> Hashed5' (hashType5 ty) - Hashed32 -> Hashed32' (hashType32 ty) - Hashed64 -> Hashed64' (hashType64 ty) - Shown -> Shown' (hashType32 ty) (show ty) - Full -> Full' (stripTypeRep ty) - +makeTypeInformation Untyped _ = Untyped' +makeTypeInformation Hashed5 ty = Hashed5' (hashType5 ty) +makeTypeInformation Hashed32 ty = Hashed32' (hashType32 ty) +makeTypeInformation Hashed64 ty = Hashed64' (hashType64 ty) +makeTypeInformation Shown ty = Shown' (hashType32 ty) (show ty) +makeTypeInformation Full ty = Full' (stripTypeRep ty) 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 @@ -143,3 +143,5 @@ -- * 'decodeTypedOrFail' (like 'decodeTyped', but with more meta information) -- -- * 'unsafeDecodeTyped' (which throws a runtime error on type mismatch) +-- +-- (The "Data.Binary.Typed.Debug" module shares the same API.) diff --git a/tests/APIConsistency.hs b/tests/APIConsistency.hs new file mode 100644 --- /dev/null +++ b/tests/APIConsistency.hs @@ -0,0 +1,71 @@ +-- | This dummy module simply makes sure that "Data.Binary.Typed" and +-- "Data.Binary.Typed.Debug" share the same API, so they can be used +-- interchangably. +-- +-- This module will not check anything per se, but will halt the compilation +-- of the testsuite if there's an error. + + +{-# LANGUAGE NumDecimals #-} +{-# LANGUAGE AutoDeriveTypeable #-} + +module APIConsistency (props) where + + +import Data.Binary (Binary) +import Data.Typeable (Typeable) +import Data.Binary.Typed as N +import Data.Binary.Typed.Debug as D +import Data.Binary.Typed.Internal + +import qualified Data.ByteString.Lazy as BSL +import Data.Binary.Get (ByteOffset) + +import Test.Tasty +import Test.Tasty.QuickCheck + + + +props :: TestTree +props = testGroup description [dummyTest] where + description = "API consistency" + dummyTest = localOption (QuickCheckTests 1) + (testProperty "(Static tests)" True) + + + _typeInformation :: [N.TypeFormat] + _typeInformation = + [ N.Untyped, N.Hashed5, N.Hashed32, N.Hashed64, N.Shown, N.Full + , D.Untyped, D.Hashed5, D.Hashed32, D.Hashed64, D.Shown, D.Full + ] + + _typed :: (Typeable a, Binary a) => [TypeFormat -> a -> Typed a] + _typed = [N.typed, D.typed] + + _erase :: [Typed a -> a] + _erase = [N.erase, D.erase] + + _mapTyped :: Typeable b => [(a -> b) -> Typed a -> Typed b] + _mapTyped = [N.mapTyped, D.mapTyped] + + _reValue :: [(a -> a) -> Typed a -> Typed a] + _reValue = [N.reValue, D.reValue] + + + _reType :: Typeable a => [TypeFormat -> Typed a -> Typed a] + _reType = [N.reType, D.reType] + + _preserialize :: [TypeInformation -> TypeInformation] + _preserialize = [N.preserialize, D.preserialize] + + _encodeTyped :: (Typeable a, Binary a) => [TypeFormat -> a -> BSL.ByteString] + _encodeTyped = [N.encodeTyped, D.encodeTyped] + + _decodeTyped :: (Typeable a, Binary a) => [BSL.ByteString -> Either String a] + _decodeTyped = [N.decodeTyped, D.decodeTyped] + + _decodeTypedOrFail :: (Typeable a, Binary a) => [BSL.ByteString -> Either (BSL.ByteString, ByteOffset, String) (BSL.ByteString, ByteOffset, a)] + _decodeTypedOrFail = [N.decodeTypedOrFail, D.decodeTypedOrFail] + + _unsafeDecodeTyped :: (Typeable a, Binary a) => [BSL.ByteString -> a] + _unsafeDecodeTyped = [N.unsafeDecodeTyped, D.unsafeDecodeTyped] diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -3,6 +3,7 @@ import Test.Tasty import qualified QuickCheck import qualified HUnit +import qualified APIConsistency as API @@ -10,4 +11,5 @@ main = defaultMain (testGroup "binary-typed testsuite" [ QuickCheck.props , HUnit.props + , API.props ])