binary-typed 0.2.3 → 0.3
raw patch · 8 files changed
+329/−42 lines, 8 files
Files
- binary-typed.cabal +8/−5
- changelog.md +9/−0
- src/Data/Binary/Typed.hs +10/−20
- src/Data/Binary/Typed/Debug.hs +210/−0
- src/Data/Binary/Typed/Internal.hs +17/−17
- src/Data/Binary/Typed/Tutorial.hs +2/−0
- tests/APIConsistency.hs +71/−0
- tests/Tests.hs +2/−0
binary-typed.cabal view
@@ -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 <dluposchainsky on googles email service>+maintainer: David Luposchainsky <dluposchainsky on googles email service>+copyright: David Luposchainsky <dluposchainsky on googles email service> 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
changelog.md view
@@ -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.
src/Data/Binary/Typed.hs view
@@ -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!
+ src/Data/Binary/Typed/Debug.hs view
@@ -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')+--+-- -- \<value\>+-- '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 \<value\>:+-- '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!
src/Data/Binary/Typed/Internal.hs view
@@ -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)
src/Data/Binary/Typed/Tutorial.hs view
@@ -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.)
+ tests/APIConsistency.hs view
@@ -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]
tests/Tests.hs view
@@ -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 ])