binary-tagged (empty) → 0.1.0.0
raw patch · 10 files changed
+863/−0 lines, 10 filesdep +SHAdep +aesondep +arraysetup-changed
Dependencies added: SHA, aeson, array, base, bifunctors, binary, binary-orphans, binary-tagged, bytestring, containers, criterion, deepseq, generics-sop, hashable, quickcheck-instances, scientific, tagged, tasty, tasty-quickcheck, text, time, unordered-containers, vector
Files
- LICENSE +30/−0
- README.md +31/−0
- Setup.hs +2/−0
- bench/Bench.hs +57/−0
- binary-tagged.cabal +111/−0
- src/Data/Binary/Tagged.hs +485/−0
- test/Generators.hs +10/−0
- test/Rec1.hs +25/−0
- test/Rec2.hs +25/−0
- test/Tests.hs +87/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Oleg Grenrus++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Oleg Grenrus nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,31 @@+# binary-tagged++[](https://travis-ci.org/phadej/binary-tagged)+[](http://hackage.haskell.org/package/binary-tagged)++Structurally tag binary serialisation stream.++Say you have:++```hs+data Record = Record+ { _recordFields :: HM.HashMap Text (Integer, ByteString)+ , _recordEnabled :: Bool+ }+ deriving (Eq, Show, Generic)++instance Binary Record+instance HasStructuralInfo Record+instance HasSemanticVersion Record+```++then you can serialise and deserialise `Record` values with a structure tag by simply++```hs+encodeTaggedFile "cachefile" record+decodeTaggedFile "cachefile" :: IO Record+```++If structure of `Record` changes in between, deserialisation will fail early.++The overhead is next to non-observable, see [a simple benchmark](https://github.com/phadej/binary-tagged/blob/master/bench/Bench.hs) and the [results](https://rawgit.com/phadej/binary-tagged/master/bench.html).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Bench.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE DeriveGeneric #-}+module Main (main) where++import Control.DeepSeq+import Data.ByteString.Lazy as LBS+import Data.Binary.Orphans+import Data.Binary.Tagged+import Criterion.Main+import qualified Data.HashMap.Strict as HM+import Data.Text as T+import GHC.Generics++data Field = Field+ { _fieldName :: Text+ , _fieldValue :: Int+ }+ deriving (Eq, Show, Generic)++instance Binary Field+instance NFData Field+instance HasStructuralInfo Field++data Record = Record+ { _recordFields :: HM.HashMap Text Field+ , _recordEnabled :: Bool+ }+ deriving (Eq, Show, Generic)++instance Binary Record+instance NFData Record+instance HasStructuralInfo Record+instance HasSemanticVersion Record++record :: Record+record = Record fields enabled+ where fields = HM.fromList (fmap mkField [1..1000])+ mkField i = let name = T.pack (show i)+ in (name, Field name i)+ enabled = True++encodedRecord :: LBS.ByteString+encodedRecord = encode record++taggedEncodedRecord :: LBS.ByteString+taggedEncodedRecord = taggedEncode record++main :: IO ()+main = defaultMain+ [ bgroup "encode"+ [ bench "Binary" $ nf encode record+ , bench "Tagged" $ nf taggedEncode record+ ]+ , bgroup "decode"+ [ bench "Binary" $ nf (decode :: LBS.ByteString -> Record) encodedRecord+ , bench "Tagged" $ nf (taggedDecode :: LBS.ByteString -> Record) taggedEncodedRecord+ ]+ ]
+ binary-tagged.cabal view
@@ -0,0 +1,111 @@+-- This file has been generated from package.yaml by hpack version 0.7.0.+--+-- see: https://github.com/sol/hpack++name: binary-tagged+version: 0.1.0.0+synopsis: Tagged binary serialisation.+description: Write me.+category: Web+homepage: https://github.com/phadej/binary-tagged#readme+bug-reports: https://github.com/phadej/binary-tagged/issues+author: Oleg Grenrus <oleg.grenrus@iki.fi>+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>+license: BSD3+license-file: LICENSE+tested-with: GHC==7.8.4, GHC==7.10.2+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ README.md++source-repository head+ type: git+ location: https://github.com/phadej/binary-tagged++library+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <4.9+ , generics-sop >=0.1 && <0.2+ , SHA >=1.6 && <1.7+ , array >=0.5 && <0.6+ , aeson >=0.8 && <0.10+ , binary >=0.7 && <0.8+ , bytestring >=0.10 && <0.11+ , containers >=0.5 && <0.6+ , hashable >=1.2 && <1.3+ , scientific >=0.3 && <0.4+ , tagged >=0.7 && <0.9+ , text >=1.2 && <1.3+ , time >=1.4 && <1.6+ , unordered-containers >=0.2 && <0.3+ , vector >=0.10 && <0.12+ exposed-modules:+ Data.Binary.Tagged+ default-language: Haskell2010++test-suite binary-tagged-test+ type: exitcode-stdio-1.0+ main-is: Tests.hs+ hs-source-dirs:+ test+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <4.9+ , generics-sop >=0.1 && <0.2+ , SHA >=1.6 && <1.7+ , array >=0.5 && <0.6+ , aeson >=0.8 && <0.10+ , binary >=0.7 && <0.8+ , bytestring >=0.10 && <0.11+ , containers >=0.5 && <0.6+ , hashable >=1.2 && <1.3+ , scientific >=0.3 && <0.4+ , tagged >=0.7 && <0.9+ , text >=1.2 && <1.3+ , time >=1.4 && <1.6+ , unordered-containers >=0.2 && <0.3+ , vector >=0.10 && <0.12+ , binary-tagged+ , binary-orphans >=0.1.1+ , bifunctors+ , quickcheck-instances+ , tasty+ , tasty-quickcheck+ other-modules:+ Generators+ Rec1+ Rec2+ default-language: Haskell2010++benchmark binary-tagged-bench+ type: exitcode-stdio-1.0+ main-is: Bench.hs+ hs-source-dirs:+ bench+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <4.9+ , generics-sop >=0.1 && <0.2+ , SHA >=1.6 && <1.7+ , array >=0.5 && <0.6+ , aeson >=0.8 && <0.10+ , binary >=0.7 && <0.8+ , bytestring >=0.10 && <0.11+ , containers >=0.5 && <0.6+ , hashable >=1.2 && <1.3+ , scientific >=0.3 && <0.4+ , tagged >=0.7 && <0.9+ , text >=1.2 && <1.3+ , time >=1.4 && <1.6+ , unordered-containers >=0.2 && <0.3+ , vector >=0.10 && <0.12+ , binary-tagged+ , binary-orphans >=0.1.1+ , deepseq+ , criterion+ default-language: Haskell2010
+ src/Data/Binary/Tagged.hs view
@@ -0,0 +1,485 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+-- We need this for Interleave+{-# LANGUAGE UndecidableInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Binary.Tagged+-- Copyright : (C) 2015 Oleg Grenrus+-- License : BSD3+-- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi>+--+-- Structurally tag binary serialisation stream.+--+-- Say you have:+--+-- > data Record = Record+-- > { _recordFields :: HM.HashMap Text (Integer, ByteString)+-- > , _recordEnabled :: Bool+-- > }+-- > deriving (Eq, Show, Generic)+-- >+-- > instance Binary Record+-- > instance HasStructuralInfo Record+-- > instance HasSemanticVersion Record+--+-- then you can serialise and deserialise @Record@ values with a structure tag by simply+--+-- > encodeTaggedFile "cachefile" record+-- > decodeTaggedFile "cachefile" :: IO Record+--+-- If structure of @Record@ changes in between, deserialisation will fail early.+module Data.Binary.Tagged+ (+ -- * Data+ BinaryTagged(..),+ BinaryTagged',+ binaryTag,+ binaryTag',+ binaryUntag,+ binaryUntag',+ StructuralInfo(..),+ -- * Serialisation+ taggedEncode,+ taggedDecode,+ taggedDecodeOrFail,+ -- * IO functions for serialisation+ taggedEncodeFile,+ taggedDecodeFile,+ taggedDecodeFileOrFail,+ -- * Class+ HasStructuralInfo(..),+ HasSemanticVersion(..),+ Version,+ -- ** Type level calculations+ Interleave,+ SumUpTo,+ -- * Generic derivation+ -- ** GHC+ ghcStructuralInfo,+ ghcNominalType,+ ghcStructuralInfo1,+ -- ** SOP+ sopStructuralInfo,+ sopNominalType,+ sopStructuralInfo1,+ -- ** SOP direct+ sopStructuralInfoS,+ sopNominalTypeS,+ sopStructuralInfo1S,+ -- * Hash+ structuralInfoSha1Digest,+ structuralInfoSha1ByteStringDigest,+ ) where++import Control.Applicative+import Control.Monad+import Data.Binary+import Data.Binary.Get (ByteOffset)+import Data.ByteString as BS+import Data.ByteString.Lazy as LBS+import Data.Digest.Pure.SHA+import Data.Monoid ((<>))+import Data.Proxy+import Generics.SOP as SOP+import Generics.SOP.GGP as SOP++#if !MIN_VERSION_base(4,8,0)+import Data.Foldable (Foldable)+import Data.Traversable (Traversable)+#endif++import qualified GHC.Generics as GHC+import GHC.TypeLits++-- Instances+import qualified Data.Vector as V+import qualified Data.Aeson as Aeson+import qualified Data.Monoid as Monoid+import Data.Int+import qualified Data.Text as S+import qualified Data.Text.Lazy as L+import qualified Data.Array.IArray as Array+import qualified Data.Array.Unboxed as Array+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Map as Map+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import qualified Data.HashSet as HS+import qualified Data.HashMap.Lazy as HML+import qualified Data.Time as Time+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Storable as S+++-- | 'Binary' serialisable class, which tries to be less error-prone to data structure changes.+--+-- Values are serialised with header consisting of version @v@ and hash of 'structuralInfo'.+newtype BinaryTagged (v :: k) a = BinaryTagged { unBinaryTagged :: a }+ deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable, GHC.Generic, GHC.Generic1)+-- TODO: Derive Enum, Bounded, Typeable, Data, Hashable, NFData, Numeric classes?++type BinaryTagged' a = BinaryTagged (SemanticVersion a) a++binaryTag :: Proxy v -> a -> BinaryTagged v a+binaryTag _ = BinaryTagged++binaryTag' :: HasSemanticVersion a => a -> BinaryTagged' a+binaryTag' = BinaryTagged++binaryUntag :: Proxy v -> BinaryTagged v a -> a+binaryUntag _ = unBinaryTagged++binaryUntag' :: HasSemanticVersion a => BinaryTagged' a -> a+binaryUntag' = unBinaryTagged++-- | Tagged version of 'encode'+taggedEncode :: forall a. (HasStructuralInfo a, HasSemanticVersion a, Binary a) => a -> LBS.ByteString+taggedEncode = encode . binaryTag (Proxy :: Proxy (SemanticVersion a))++-- | Tagged version of 'decode'+taggedDecode :: forall a. (HasStructuralInfo a, HasSemanticVersion a, Binary a) => LBS.ByteString -> a+taggedDecode = binaryUntag (Proxy :: Proxy (SemanticVersion a)) . decode++-- | Tagged version of 'decodeOrFail'+taggedDecodeOrFail :: forall a. (HasStructuralInfo a, HasSemanticVersion a, Binary a)+ => LBS.ByteString+ -> Either (LBS.ByteString, ByteOffset, String) (LBS.ByteString, ByteOffset, a)+taggedDecodeOrFail = fmap3 (binaryUntag (Proxy :: Proxy (SemanticVersion a))) . decodeOrFail+ where fmap3 f = fmap (\(a, b, c) -> (a, b, f c))++-- | Tagged version of 'encodeFile'+taggedEncodeFile :: forall a. (HasStructuralInfo a, HasSemanticVersion a, Binary a) => FilePath -> a -> IO ()+taggedEncodeFile filepath = encodeFile filepath . binaryTag (Proxy :: Proxy (SemanticVersion a))++-- | Tagged version of 'decodeFile'+taggedDecodeFile :: forall a. (HasStructuralInfo a, HasSemanticVersion a, Binary a) => FilePath -> IO a+taggedDecodeFile = fmap (binaryUntag (Proxy :: Proxy (SemanticVersion a))) . decodeFile++-- | Tagged version of 'decodeFileOrFail'+taggedDecodeFileOrFail :: forall a. (HasStructuralInfo a, HasSemanticVersion a, Binary a) => FilePath -> IO (Either (ByteOffset, String) a)+taggedDecodeFileOrFail = (fmap . fmap) (binaryUntag (Proxy :: Proxy (SemanticVersion a))) . decodeFileOrFail++instance Applicative (BinaryTagged v) where+ pure = return+ (<*>) = ap++instance Monad (BinaryTagged v) where+ return = BinaryTagged+ BinaryTagged m >>= k = k m++instance Monoid.Monoid a => Monoid.Monoid (BinaryTagged v a) where+ mempty = pure Monoid.mempty+ mappend = liftA2 Monoid.mappend++-- | Type the semantic version is serialised with.+type Version = Word32++-- | Version and structure hash are prepended to serialised stream+instance (Binary a, HasStructuralInfo a, KnownNat v) => Binary (BinaryTagged v a) where+ put (BinaryTagged x) = put ver' >> put hash' >> put x+ where+ proxyV = Proxy :: Proxy v+ proxyA = Proxy :: Proxy a+ ver' = fromIntegral (natVal proxyV) :: Version+ hash' = structuralInfoSha1ByteStringDigest . structuralInfo $ proxyA++ get = do+ ver <- get+ if ver == ver'+ then do hash <- get+ if hash == hash'+ then fmap BinaryTagged get+ else fail $ "Non matching structure hashes: got" <> show hash <> "; expected: " <> show hash'+ else fail $ "Non matching versions: got " <> show ver <> "; expected: " <> show ver'+ where+ proxyV = Proxy :: Proxy v+ proxyA = Proxy :: Proxy a+ ver' = fromIntegral (natVal proxyV) :: Version+ hash' = bytestringDigest . structuralInfoSha1Digest . structuralInfo $ proxyA++-- | Data type structure, with (some) nominal information.+data StructuralInfo = NominalType String+ | NominalNewtype String StructuralInfo+ | StructuralInfo String [[StructuralInfo]]+ deriving (Eq, Ord, Show, GHC.Generic)++instance Binary StructuralInfo++-- | Type class providing `StructuralInfo` for each data type.+--+-- For regular non-recursive ADTs 'HasStructuralInfo' can be derived generically.+--+-- > data Record = Record { a :: Int, b :: Bool, c :: [Char] } deriving (Generic)+-- > instance hasStructuralInfo Record+--+-- For stable types, you can provide only type name+--+-- > instance HasStructuralInfo Int where structuralInfo = ghcNominalType -- infer name from Generic information+-- > instance HasStructuralInfo Integer where structuralInfo _ = NominalType "Integer"+--+-- Recursive type story is a bit sad atm. If the type structure is stable, you can do:+--+-- > instance HasStructuralInfo a => HasStructuralInfo [a] where structuralInfo = ghcStructuralInfo1+class HasStructuralInfo a where+ structuralInfo :: Proxy a -> StructuralInfo++ default structuralInfo :: (GHC.Generic a, All2 HasStructuralInfo (GCode a), GDatatypeInfo a, SingI (GCode a)) => Proxy a -> StructuralInfo+ structuralInfo = ghcStructuralInfo++-- | A helper type family for 'encodeTaggedFile' and 'decodeTaggedFile'.+--+-- The default definition is @'SemanticVersion' a = 0@+class KnownNat (SemanticVersion a) => HasSemanticVersion (a :: *) where+ type SemanticVersion a :: Nat+ type SemanticVersion a = 0++instance HasStructuralInfo StructuralInfo+instance HasSemanticVersion StructuralInfo++structuralInfoSha1Digest :: StructuralInfo -> Digest SHA1State+structuralInfoSha1Digest = sha1 . encode++structuralInfoSha1ByteStringDigest :: StructuralInfo -> LBS.ByteString+structuralInfoSha1ByteStringDigest = bytestringDigest . structuralInfoSha1Digest++-- Generic derivation++ghcStructuralInfo :: (GHC.Generic a, All2 HasStructuralInfo (GCode a), GDatatypeInfo a, SingI (GCode a)) => Proxy a -> StructuralInfo+ghcStructuralInfo proxy = sopStructuralInfoS (gdatatypeInfo proxy)++ghcNominalType :: (GHC.Generic a, GDatatypeInfo a) => Proxy a -> StructuralInfo+ghcNominalType proxy = sopNominalTypeS (gdatatypeInfo proxy)++ghcStructuralInfo1 :: forall f a. (GHC.Generic1 f, GDatatypeInfo (f a), HasStructuralInfo a) => Proxy (f a) -> StructuralInfo+ghcStructuralInfo1 proxy = sopStructuralInfo1S (structuralInfo (Proxy :: Proxy a)) (gdatatypeInfo proxy)++-- SOP derivation++sopStructuralInfo :: forall a. (Generic a, HasDatatypeInfo a, All2 HasStructuralInfo (Code a)) => Proxy a -> StructuralInfo+sopStructuralInfo proxy = sopStructuralInfoS (datatypeInfo proxy)++sopStructuralInfoS :: forall xss. (All2 HasStructuralInfo xss, SingI xss) => DatatypeInfo xss -> StructuralInfo+sopStructuralInfoS di@(Newtype _ _ ci) = NominalNewtype (datatypeName di) (sopNominalNewtype ci)+sopStructuralInfoS di@(ADT _ _ _) = StructuralInfo (datatypeName di) (sopNominalAdt (toNP' (sing :: Sing xss)))++sopNominalNewtype :: forall x. HasStructuralInfo x => ConstructorInfo '[x] -> StructuralInfo+sopNominalNewtype _ = structuralInfo (Proxy :: Proxy x)++sopNominalAdt :: (All2 HasStructuralInfo xss) => NP (NP Proxy) xss -> [[StructuralInfo]]+sopNominalAdt Nil = []+sopNominalAdt (p :* ps) = sopStructuralInfoP p : sopNominalAdt ps++sopStructuralInfoP :: (All HasStructuralInfo xs) => NP Proxy xs -> [StructuralInfo]+sopStructuralInfoP Nil = []+sopStructuralInfoP (proxy :* rest) = structuralInfo proxy : sopStructuralInfoP rest++sopNominalType :: forall a. (Generic a, HasDatatypeInfo a) => Proxy a -> StructuralInfo+sopNominalType proxy = sopNominalTypeS (datatypeInfo proxy)++sopNominalTypeS :: DatatypeInfo xss -> StructuralInfo+sopNominalTypeS di = NominalType (datatypeName di)++sopStructuralInfo1 :: forall f a. (Generic (f a), HasDatatypeInfo (f a), HasStructuralInfo a) => Proxy (f a) -> StructuralInfo+sopStructuralInfo1 proxy = sopStructuralInfo1S (structuralInfo (Proxy :: Proxy a)) (datatypeInfo proxy)++sopStructuralInfo1S :: StructuralInfo -> DatatypeInfo xss -> StructuralInfo+sopStructuralInfo1S nsop di = NominalNewtype (datatypeName di) nsop++-- SOP helpers++datatypeName :: DatatypeInfo xss -> DatatypeName+datatypeName (Newtype _ d _) = d+datatypeName (ADT _ d _) = d++toNP :: Sing xs -> NP Proxy xs+toNP SNil = Nil+toNP SCons = Proxy :* toNP sing++toNP' :: Sing xss -> NP (NP Proxy) xss+toNP' SNil = Nil+toNP' SCons = toNP sing :* toNP' sing++-- | Interleaving+--+-- > 3 | 9 . . . .+-- > 2 | 5 8 . . .+-- > 1 | 2 4 7 11 .+-- > 0 | 0 1 3 6 10+-- > -----------------+-- > 0 1 2 3 4+--+-- This can be calculated by @f x y = sum ([0..x+y]) + y@+type Interleave (n :: Nat) (m :: Nat) = SumUpTo (n + m) + m+type SumUpTo (n :: Nat) = n * (n - 1)++-- Instances++instance HasStructuralInfo Bool where structuralInfo = ghcNominalType+instance HasStructuralInfo Char where structuralInfo = ghcNominalType+instance HasStructuralInfo Int where structuralInfo = ghcNominalType+instance HasStructuralInfo Integer where structuralInfo _ = NominalType "Integer"++instance HasStructuralInfo Int8 where structuralInfo _ = NominalType "Int8"+instance HasStructuralInfo Int16 where structuralInfo _ = NominalType "Int16"+instance HasStructuralInfo Int32 where structuralInfo _ = NominalType "Int32"+instance HasStructuralInfo Int64 where structuralInfo _ = NominalType "Int64"++instance HasStructuralInfo Word8 where structuralInfo _ = NominalType "Word8"+instance HasStructuralInfo Word16 where structuralInfo _ = NominalType "Word16"+instance HasStructuralInfo Word32 where structuralInfo _ = NominalType "Word32"+instance HasStructuralInfo Word64 where structuralInfo _ = NominalType "Word64"++-- Recursive types+instance HasStructuralInfo a => HasStructuralInfo [a] where structuralInfo = ghcStructuralInfo1+instance HasSemanticVersion a => HasSemanticVersion [a] where+ type SemanticVersion [a] = SemanticVersion a++-- Types from base+instance HasStructuralInfo a => HasStructuralInfo (Maybe a)+instance HasSemanticVersion a => HasSemanticVersion (Maybe a) where+ type SemanticVersion (Maybe a) = SemanticVersion a++instance (HasStructuralInfo a, HasStructuralInfo b) => HasStructuralInfo (Either a b)+instance (HasSemanticVersion a, HasSemanticVersion b, KnownNat (SemanticVersion (Either a b))) => HasSemanticVersion (Either a b) where+ type SemanticVersion (Either a b) = Interleave (SemanticVersion a) (SemanticVersion b)++-- Tuples+instance (HasStructuralInfo a, HasStructuralInfo b) => HasStructuralInfo (a, b)+instance (HasStructuralInfo a, HasStructuralInfo b, HasStructuralInfo c) => HasStructuralInfo (a, b, c)+instance (HasStructuralInfo a, HasStructuralInfo b, HasStructuralInfo c, HasStructuralInfo d) => HasStructuralInfo (a, b, c, d)++-- Monoid+instance HasStructuralInfo a => HasStructuralInfo (Monoid.Sum a)+instance HasSemanticVersion a => HasSemanticVersion (Monoid.Sum a) where+ type SemanticVersion (Monoid.Sum a) = SemanticVersion a++instance HasStructuralInfo a => HasStructuralInfo (Monoid.Product a)+instance HasSemanticVersion a => HasSemanticVersion (Monoid.Product a) where+ type SemanticVersion (Monoid.Product a) = SemanticVersion a++-- TODO: add more++-- ByteString+instance HasStructuralInfo BS.ByteString where structuralInfo _ = NominalType "ByteString.Strict"+instance HasStructuralInfo LBS.ByteString where structuralInfo _ = NominalType "ByteString.Lazy"++instance HasSemanticVersion BS.ByteString+instance HasSemanticVersion LBS.ByteString++-- Text+instance HasStructuralInfo S.Text where structuralInfo _ = NominalType "Text.Strict"+instance HasStructuralInfo L.Text where structuralInfo _ = NominalType "Text.Lazy"++instance HasSemanticVersion S.Text+instance HasSemanticVersion L.Text++-- Containers+instance HasStructuralInfo a => HasStructuralInfo (IntMap.IntMap a) where+ structuralInfo _ = NominalNewtype "IntMap" $ structuralInfo (Proxy :: Proxy a)+instance HasSemanticVersion a => HasSemanticVersion (IntMap.IntMap a) where+ type SemanticVersion (IntMap.IntMap a) = SemanticVersion a++instance HasStructuralInfo IntSet.IntSet where+ structuralInfo _ = NominalType "IntSet"+instance HasSemanticVersion IntSet.IntSet++instance (HasStructuralInfo k, HasStructuralInfo v) => HasStructuralInfo (Map.Map k v) where+ structuralInfo _ = StructuralInfo "Map" [[ structuralInfo (Proxy :: Proxy k), structuralInfo (Proxy :: Proxy v) ]]+instance (HasSemanticVersion k, HasSemanticVersion v, KnownNat (SemanticVersion (Map.Map k v))) => HasSemanticVersion (Map.Map k v) where+ type SemanticVersion (Map.Map k v) = Interleave (SemanticVersion k) (SemanticVersion v)++instance HasStructuralInfo a => HasStructuralInfo (Seq.Seq a) where+ structuralInfo _ = NominalNewtype "Seq" $ structuralInfo (Proxy :: Proxy a)+instance HasSemanticVersion a => HasSemanticVersion (Seq.Seq a) where+ type SemanticVersion (Seq.Seq a) = SemanticVersion a++instance HasStructuralInfo a => HasStructuralInfo (Set.Set a) where+ structuralInfo _ = NominalNewtype "Set" $ structuralInfo (Proxy :: Proxy a)+instance HasSemanticVersion a => HasSemanticVersion (Set.Set a) where+ type SemanticVersion (Set.Set a) = SemanticVersion a++-- Unordered containers++instance (HasStructuralInfo k, HasStructuralInfo v) => HasStructuralInfo (HML.HashMap k v) where+ structuralInfo _ = StructuralInfo "HashMap" [[ structuralInfo (Proxy :: Proxy k), structuralInfo (Proxy :: Proxy v) ]]+instance (HasSemanticVersion k, HasSemanticVersion v, KnownNat (SemanticVersion (HML.HashMap k v))) => HasSemanticVersion (HML.HashMap k v) where+ type SemanticVersion (HML.HashMap k v) = Interleave (SemanticVersion k) (SemanticVersion v)++instance HasStructuralInfo a => HasStructuralInfo (HS.HashSet a) where+ structuralInfo _ = NominalNewtype "HashSet" $ structuralInfo (Proxy :: Proxy a)+instance HasSemanticVersion a => HasSemanticVersion (HS.HashSet a) where+ type SemanticVersion (HS.HashSet a) = SemanticVersion a++-- Array+instance (HasStructuralInfo i, HasStructuralInfo e) => HasStructuralInfo (Array.Array i e) where+ structuralInfo _ = StructuralInfo "Array" [[ structuralInfo (Proxy :: Proxy i), structuralInfo (Proxy :: Proxy e) ]]+instance (HasSemanticVersion i, HasSemanticVersion e, KnownNat (SemanticVersion (Array.Array i e))) => HasSemanticVersion (Array.Array i e) where+ type SemanticVersion (Array.Array i e) = Interleave (SemanticVersion i) (SemanticVersion e)++instance (HasStructuralInfo i, HasStructuralInfo e) => HasStructuralInfo (Array.UArray i e) where+ structuralInfo _ = StructuralInfo "UArray" [[ structuralInfo (Proxy :: Proxy i), structuralInfo (Proxy :: Proxy e) ]]+instance (HasSemanticVersion i, HasSemanticVersion e, KnownNat (SemanticVersion (Array.UArray i e))) => HasSemanticVersion (Array.UArray i e) where+ type SemanticVersion (Array.UArray i e) = Interleave (SemanticVersion i) (SemanticVersion e)++-- Vector++instance HasStructuralInfo a => HasStructuralInfo (V.Vector a) where+ structuralInfo _ = NominalNewtype "Vector" $ structuralInfo (Proxy :: Proxy a)+instance HasSemanticVersion a => HasSemanticVersion (V.Vector a) where+ type SemanticVersion (V.Vector a) = SemanticVersion a++instance HasStructuralInfo a => HasStructuralInfo (U.Vector a) where+ structuralInfo _ = NominalNewtype "Vector.Unboxed" $ structuralInfo (Proxy :: Proxy a)+instance HasSemanticVersion a => HasSemanticVersion (U.Vector a) where+ type SemanticVersion (U.Vector a) = SemanticVersion a++instance HasStructuralInfo a => HasStructuralInfo (S.Vector a) where+ structuralInfo _ = NominalNewtype "Vector.Storable" $ structuralInfo (Proxy :: Proxy a)+instance HasSemanticVersion a => HasSemanticVersion (S.Vector a) where+ type SemanticVersion (S.Vector a) = SemanticVersion a++-- Time++instance HasStructuralInfo Time.UTCTime where structuralInfo _ = NominalType "UTCTime"+instance HasStructuralInfo Time.DiffTime where structuralInfo _ = NominalType "DiffTime"+instance HasStructuralInfo Time.UniversalTime where structuralInfo _ = NominalType "UniversalTime"+instance HasStructuralInfo Time.NominalDiffTime where structuralInfo _ = NominalType "NominalDiffTime"+instance HasStructuralInfo Time.Day where structuralInfo _ = NominalType "Day"+instance HasStructuralInfo Time.TimeZone where structuralInfo _ = NominalType "TimeZone"+instance HasStructuralInfo Time.TimeOfDay where structuralInfo _ = NominalType "TimeOfDay"+instance HasStructuralInfo Time.LocalTime where structuralInfo _ = NominalType "LocalTime"++instance HasSemanticVersion Time.UTCTime+instance HasSemanticVersion Time.DiffTime+instance HasSemanticVersion Time.UniversalTime+instance HasSemanticVersion Time.NominalDiffTime+instance HasSemanticVersion Time.Day+instance HasSemanticVersion Time.TimeZone+instance HasSemanticVersion Time.TimeOfDay+instance HasSemanticVersion Time.LocalTime++-- Value++-- TODO: derive sop+instance HasStructuralInfo Aeson.Value where structuralInfo _ = NominalType "Aeson.Value"+instance HasSemanticVersion Aeson.Value
+ test/Generators.hs view
@@ -0,0 +1,10 @@+module Generators where++import Data.Monoid+import Test.Tasty.QuickCheck++arbitrarySum :: Arbitrary a => Gen (Sum a)+arbitrarySum = fmap Sum arbitrary++arbitraryProduct :: Arbitrary a => Gen (Product a)+arbitraryProduct = fmap Product arbitrary
+ test/Rec1.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+module Rec1 where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++import Data.Binary.Orphans+import Data.Binary.Tagged+import Data.Monoid+import GHC.Generics+import Test.Tasty.QuickCheck++import Generators++data Rec = Rec (Sum Int) (Product Int)+ deriving (Eq, Show, Generic)++instance Binary Rec+instance HasStructuralInfo Rec+instance HasSemanticVersion Rec++instance Arbitrary Rec where+ arbitrary = Rec <$> arbitrarySum <*> arbitraryProduct
+ test/Rec2.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+module Rec2 where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++import Data.Binary.Orphans+import Data.Binary.Tagged+import Data.Monoid+import GHC.Generics+import Test.Tasty.QuickCheck++import Generators++data Rec = Rec (Product Int) (Sum Int)+ deriving (Eq, Show, Generic)++instance Binary Rec+instance HasStructuralInfo Rec+instance HasSemanticVersion Rec++instance Arbitrary Rec where+ arbitrary = Rec <$> arbitraryProduct <*> arbitrarySum
+ test/Tests.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Main (main) where++import Data.Bifunctor+import Data.Binary+import Data.Binary.Tagged+import Data.Either+import Data.Monoid+import Data.Proxy+import Test.Tasty+import Test.Tasty.QuickCheck++import qualified Rec1+import qualified Rec2++main :: IO ()+main = defaultMain $ testGroup "Tests"+ [ roundtrips+ , wrongRoundtrips+ , failedRoundtrips+ ]++instance Arbitrary a => Arbitrary (BinaryTagged v a) where+ arbitrary = fmap BinaryTagged arbitrary++proxyRec1 :: Proxy Rec1.Rec+proxyRec1 = Proxy++proxyRec1Ver0 :: Proxy (BinaryTagged 0 Rec1.Rec)+proxyRec1Ver0 = Proxy++proxyRec1Ver1 :: Proxy (BinaryTagged 1 Rec1.Rec)+proxyRec1Ver1 = Proxy++proxyRec2 :: Proxy Rec2.Rec+proxyRec2 = Proxy++proxyRec2Ver0 :: Proxy (BinaryTagged 0 Rec2.Rec)+proxyRec2Ver0 = Proxy++proxyRec2Ver1 :: Proxy (BinaryTagged 1 Rec2.Rec)+proxyRec2Ver1 = Proxy++eqRec1Rec2 :: Rec1.Rec -> Rec2.Rec -> Bool+eqRec1Rec2 (Rec1.Rec (Sum a) (Product b)) (Rec2.Rec (Product a') (Sum b')) =+ a == a' && b == b'++roundtrips :: TestTree+roundtrips = testGroup "Roundtrip"+ [ testProperty "Rec1" $ roundtrip proxyRec1+ , testProperty "BinaryTagged 0 Rec1" $ roundtrip proxyRec1Ver0+ , testProperty "BinaryTagged 1 Rec1" $ roundtrip proxyRec1Ver1+ , testProperty "Rec2" $ roundtrip proxyRec2+ , testProperty "BinaryTagged 0 Rec2" $ roundtrip proxyRec2Ver0+ , testProperty "BinaryTagged 1 Rec2" $ roundtrip proxyRec2Ver1+ ]++wrongRoundtrips :: TestTree+wrongRoundtrips = testGroup "Decode successful, data invalid"+ [ testProperty "Rec1 -> Rec2" $ wrongRoundtrip eqRec1Rec2+ , testProperty "Rec2 -> Rec1" $ wrongRoundtrip eqRec1Rec2+ ]++failedRoundtrips :: TestTree+failedRoundtrips = testGroup "Failed roundtrips"+ [ testProperty "Different version" $ failedRoundtrip proxyRec1Ver0 proxyRec1Ver1+ , testProperty "Different structure" $ failedRoundtrip proxyRec1Ver0 proxyRec2Ver0+ ]++roundtrip :: (Eq a, Show a, Arbitrary a, Binary a) => Proxy a -> a -> Property+roundtrip _ x = x === decode (encode x)++wrongRoundtrip :: (Arbitrary a, Binary a, Binary b) => (a -> b -> Bool) -> a -> Property+wrongRoundtrip eq x = property $ eq x $ decode (encode x)++trdOf3 :: (a, b, c) -> c+trdOf3 (_, _, c) = c++isLeftProperty :: (Show a, Show b) => Either a b -> Property+isLeftProperty x = counterexample ("not isLeft: " <> show x) (isLeft x)++failedRoundtrip :: forall a b. (Arbitrary a, Binary a, Binary b, Show b) => Proxy a -> Proxy b -> a -> Property+failedRoundtrip _ _ x = let x' = bimap trdOf3 trdOf3 $ decodeOrFail (encode x) :: Either String b+ in isLeftProperty x'