binary-tagged 0.2 → 0.3

raw patch · 8 files changed

+275/−860 lines, 8 filesdep +QuickCheckdep +singleton-booldep +structureddep −SHAdep −aesondep −bifunctorsdep ~arraydep ~basedep ~base16-bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, singleton-bool, structured, transformers

Dependencies removed: SHA, aeson, bifunctors, cryptohash-sha1, generics-sop, hashable, nats, scientific, semigroups, time, vector

Dependency ranges changed: array, base, base16-bytestring, binary-instances, bytestring, containers, tagged, text, unordered-containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +3/−0
• LICENSE +1/−1
• bench/Bench.hs +30/−26
• binary-tagged.cabal +39/−74
• src/Data/Binary/Tagged.hs +120/−695
• test/Rec1.hs +8/−7
• test/Rec2.hs +8/−7
• test/Tests.hs +66/−50

@@ -1,3 +1,6 @@+- 0.3 (2020-05-16)+    - Major rewrite: use `structured`.+ - 0.2 (2019-05-14)     - use cryptohash-sha1,       types of structuralInfoSha1Digest and structuralInfoSha1Digest are changed.

@@ -1,4 +1,4 @@-Copyright (c) 2015, Oleg Grenrus+Copyright (c) 2015-2020, Oleg Grenrus  All rights reserved. 

@@ -1,58 +1,62 @@-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-} module Main (main) where -import Control.DeepSeq-import Data.ByteString.Lazy as LBS-import Data.Binary+import Control.DeepSeq       (NFData)+import Criterion.Main        (bench, bgroup, defaultMain, nf)+import Data.Binary           (Binary, decode, encode) import Data.Binary.Instances ()+import Data.Typeable         (Typeable)+import GHC.Generics          (Generic)++import qualified Data.ByteString.Lazy as LBS+import qualified Data.HashMap.Strict  as HM+import qualified Data.Text            as T+ 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)+    { _fieldName  :: T.Text+    , _fieldValue :: Int+    }+  deriving (Eq, Show, Generic, Typeable)  instance Binary Field instance NFData Field-instance HasStructuralInfo Field+instance Structured Field  data Record = Record-  { _recordFields :: HM.HashMap Text Field-  , _recordEnabled :: Bool-  }-  deriving (Eq, Show, Generic)+    { _recordFields  :: HM.HashMap T.Text Field+    , _recordEnabled :: Bool+    }+  deriving (Eq, Show, Generic, Typeable)  instance Binary Record instance NFData Record-instance HasStructuralInfo Record-instance HasSemanticVersion Record+instance Structured 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+  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+taggedEncodedRecord = structuredEncode record  main :: IO () main = defaultMain   [ bgroup "encode"       [ bench "Binary" $ nf encode record-      , bench "Tagged" $ nf taggedEncode record+      , bench "Tagged" $ nf structuredEncode record       ]   , bgroup "decode"       [ bench "Binary" $ nf (decode :: LBS.ByteString -> Record) encodedRecord-      , bench "Tagged" $ nf (taggedDecode :: LBS.ByteString -> Record) taggedEncodedRecord+      , bench "Tagged" $ nf (structuredDecode :: LBS.ByteString -> Record) taggedEncodedRecord       ]   ]

@@ -1,6 +1,6 @@-cabal-version:      >=1.10+cabal-version:      2.2 name:               binary-tagged-version:            0.2+version:            0.3 synopsis:           Tagged binary serialisation. category:           Data description:@@ -8,6 +8,8 @@   .   Say you have:   .+  Say you have a data type+  .   @   data Record = Record   \  { _recordFields  :: HM.HashMap Text (Integer, ByteString)@@ -15,157 +17,120 @@   \  }   \  deriving (Eq, Show, Generic)   .-  instance Binary Record-  instance HasStructuralInfo Record-  instance HasSemanticVersion Record+  instance @Binary@ Record+  instance 'Structured' Record   @   .   then you can serialise and deserialise @Record@ values with a structure tag by simply   .   @-  encodeTaggedFile "cachefile" record-  decodeTaggedFile "cachefile" :: IO Record+  'structuredEncode' record :: LBS.ByteString+  'structuredDecode' lbs    :: 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).+  The overhead is next to non-observable.   .   @   benchmarking encode/Binary-  time                 362.6 μs   (361.2 μs .. 363.8 μs)+  time                 352.8 μs   (349.5 μs .. 355.9 μs)   .   benchmarking encode/Tagged-  time                 379.2 μs   (375.5 μs .. 382.2 μs)+  time                 350.8 μs   (349.0 μs .. 353.1 μs)   .   benchmarking decode/Binary-  time                 366.3 μs   (365.1 μs .. 368.1 μs)+  time                 346.8 μs   (344.7 μs .. 349.9 μs)   .   benchmarking decode/Tagged-  time                 367.6 μs   (367.0 μs .. 368.2 μs)+  time                 353.8 μs   (352.0 μs .. 355.8 μs)   @ -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:            BSD-3-Clause license-file:       LICENSE build-type:         Simple tested-with:-  GHC ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1+  GHC ==7.8.4+   || ==7.10.3+   || ==8.0.2+   || ==8.2.2+   || ==8.4.4+   || ==8.6.5+   || ==8.8.3+   || ==8.10.1 -extra-source-files:-  CHANGELOG.md+extra-source-files: CHANGELOG.md  source-repository head   type:     git   location: https://github.com/phadej/binary-tagged+  subdir:   binary-tagged  library   hs-source-dirs:   src   ghc-options:      -Wall +  -- we build on top of structured+  build-depends:    structured >=0.1 && <0.1.1+   -- Libraries bundled with GHC   build-depends:-      array       >=0.5.0.0  && <0.6-    , base        >=4.7.0.2  && <4.13+    , array       ^>=0.5.0.0+    , base        >=4.7.0.2  && <4.15     , binary      >=0.7.1.0  && <0.10-    , bytestring  >=0.10.4.0 && <0.11+    , bytestring  ^>=0.10.4.0     , containers  >=0.5.5.1  && <0.7-    , text        >=1.2.3.0  && <1.3-    , time        >=1.4.2    && <1.9    -- other dependencies   build-depends:-      aeson                 >=0.8        && <1.5-    , base16-bytestring     >=0.1.1.6    && <0.2-    , cryptohash-sha1       >=0.11.100.1 && <0.12-    , generics-sop          >=0.3.2.0    && <0.6-    , hashable              >=1.2        && <1.4-    , scientific            >=0.3        && <0.4-    , tagged                >=0.7        && <0.9-    , unordered-containers  >=0.2        && <0.3-    , vector                >=0.10       && <0.13+    , base16-bytestring  ^>=0.1.1.6+    , tagged             ^>=0.8.6    exposed-modules:  Data.Binary.Tagged   default-language: Haskell2010 -  if !impl(ghc >=8.0)-    build-depends: semigroups >=0.18.5 && <0.20--  if !impl(ghc >=7.10)-    build-depends: nats >=1.1.2 && <1.2- test-suite binary-tagged-test+  default-language: Haskell2010   type:             exitcode-stdio-1.0   main-is:          Tests.hs   hs-source-dirs:   test   ghc-options:      -Wall   build-depends:-      aeson-    , array     , base-    , base16-bytestring-    , bifunctors     , binary-    , binary-instances      >=1 && <1.1+    , binary-instances      ^>=1     , binary-tagged     , bytestring-    , containers-    , generics-sop-    , hashable+    , QuickCheck            ^>=2.14     , quickcheck-instances-    , scientific+    , singleton-bool        ^>=0.1.5     , tagged     , tasty-    , tasty-quickcheck     , tasty-hunit-    , text-    , time-    , unordered-containers-    , vector--  if !impl(ghc >=8.0)-    build-depends: semigroups--  if !impl(ghc >=7.10)-    build-depends: nats+    , tasty-quickcheck+    , transformers    other-modules:     Generators     Rec1     Rec2 -  default-language: Haskell2010- benchmark binary-tagged-bench+  default-language: Haskell2010   type:             exitcode-stdio-1.0   main-is:          Bench.hs   hs-source-dirs:   bench   ghc-options:      -Wall   build-depends:-      aeson-    , array     , base-    , base16-bytestring     , binary     , binary-instances     , binary-tagged     , bytestring-    , containers     , criterion     , deepseq-    , generics-sop-    , hashable-    , nats-    , scientific-    , semigroups-    , SHA-    , tagged     , text-    , time     , unordered-containers-    , vector--  default-language: Haskell2010

@@ -1,732 +1,157 @@-{-# 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   #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables         #-}+{-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.Binary.Tagged--- Copyright   :  (C) 2015 Oleg Grenrus+-- Copyright   :  (C) 2015-2020 Oleg Grenrus -- License     :  BSD3 -- Maintainer  :  Oleg Grenrus <oleg.grenrus@iki.fi> -- -- Structurally tag binary serialisation stream. ----- Say you have:+-- Say you have a data type ----- > data Record = Record--- >   { _recordFields :: HM.HashMap Text (Integer, ByteString)--- >   , _recordEnabled :: Bool--- >   }--- >   deriving (Eq, Show, Generic)--- >--- > instance Binary Record--- > instance HasStructuralInfo Record--- > instance HasSemanticVersion Record+-- @+-- data Record = Record+--   { _recordFields  :: HM.HashMap Text (Integer, ByteString)+--   , _recordEnabled :: Bool+--   }+--   deriving (Eq, Show, Generic) --+-- instance 'Binary.Binary' Record+-- instance 'Structured' Record+-- @+-- -- then you can serialise and deserialise @Record@ values with a structure tag by simply ----- > encodeTaggedFile "cachefile" record--- > decodeTaggedFile "cachefile" :: IO Record+-- @+-- 'structuredEncode' record :: LBS.ByteString+-- 'structuredDecode' lbs    :: Either String 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,-  Div2,-  -- * 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 qualified Crypto.Hash.SHA1        as SHA1-import           Data.Binary-import           Data.Binary.Get         (ByteOffset)-import           Data.ByteString         as BS-import qualified Data.ByteString.Base16  as Base16-import           Data.ByteString.Lazy    as LBS-import           Data.Monoid             ((<>))-import           Data.Typeable           (Typeable)-import           Generics.SOP            as SOP-import           Generics.SOP.Constraint 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.Array.IArray       as Array-import qualified Data.Array.Unboxed      as Array-import qualified Data.Fixed              as Fixed-import qualified Data.HashMap.Lazy       as HML-import qualified Data.HashSet            as HS-import           Data.Int-import qualified Data.IntMap             as IntMap-import qualified Data.IntSet             as IntSet-import qualified Data.List.NonEmpty      as NE-import qualified Data.Map                as Map-import qualified Data.Monoid             as Monoid-import qualified Data.Ratio              as Ratio-import qualified Data.Semigroup          as Semigroup-import qualified Data.Sequence           as Seq-import qualified Data.Set                as Set-import qualified Data.Text               as S-import qualified Data.Text.Lazy          as L-import qualified Data.Time               as Time-import qualified Data.Vector             as V-import qualified Data.Vector.Storable    as S-import qualified Data.Vector.Unboxed     as U-import qualified Data.Version            as Version-import qualified Numeric.Natural         as Natural--#ifdef MIN_VERSION_aeson-import qualified Data.Aeson              as Aeson-#endif---- | '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, Typeable)--- 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 Semigroup.Semigroup a => Semigroup.Semigroup (BinaryTagged v a) where-  (<>) = liftA2 (Semigroup.<>)--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 (Base16.encode hash) <> "; expected: " <> show (Base16.encode 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' = 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, Typeable)--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-                            , SListI2 (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 -> BS.ByteString-structuralInfoSha1Digest = SHA1.hashlazy . encode--{-# DEPRECATED structuralInfoSha1ByteStringDigest "Use structuralInfoSha1Digest directly" #-}-structuralInfoSha1ByteStringDigest :: StructuralInfo -> BS.ByteString-structuralInfoSha1ByteStringDigest = structuralInfoSha1Digest------------------------------------------------------------------------------------ Generics----------------------------------------------------------------------------------ghcStructuralInfo :: ( GHC.Generic a-                     , All2 HasStructuralInfo (GCode a)-                     , GDatatypeInfo a-                     , SListI2 (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-                                  , SListI2 xss-                                  )-                   => DatatypeInfo xss-                   -> StructuralInfo-sopStructuralInfoS di@(Newtype _ _ ci)  = NominalNewtype (datatypeName di) (sopNominalNewtype ci)-sopStructuralInfoS di@ADT {}            = StructuralInfo (datatypeName di) (sopNominalAdtPOP (hpure Proxy :: POP Proxy xss))--sopNominalNewtype :: forall x. HasStructuralInfo x => ConstructorInfo '[x] -> StructuralInfo-sopNominalNewtype _ = structuralInfo (Proxy :: Proxy x)--sopNominalAdtPOP :: (All2 HasStructuralInfo xss) => POP Proxy xss -> [[StructuralInfo]]-sopNominalAdtPOP (POP np2) = sopNominalAdt np2--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------------------------------------------------------------------------------------ | 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) = Div2 (n GHC.TypeLits.* (n + 1))-type family Div2 (n :: Nat) :: Nat where-  Div2 0 = 0-  Div2 1 = 0-  Div2 n = 1 + Div2 (n - 2)------------------------------------------------------------------------------------ Instances----------------------------------------------------------------------------------instance HasStructuralInfo Bool where structuralInfo = ghcNominalType-instance HasStructuralInfo Char where structuralInfo _ = NominalType "Char"-instance HasStructuralInfo Int where structuralInfo _ = NominalType "Int"-instance HasStructuralInfo Word where structuralInfo _ = NominalType "Word"-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"--instance HasSemanticVersion Bool-instance HasSemanticVersion Char-instance HasSemanticVersion Int-instance HasSemanticVersion Word-instance HasSemanticVersion Integer--instance HasSemanticVersion Int8-instance HasSemanticVersion Int16-instance HasSemanticVersion Int32-instance HasSemanticVersion Int64--instance HasSemanticVersion Word8-instance HasSemanticVersion Word16-instance HasSemanticVersion Word32-instance HasSemanticVersion Word64---- | /Since binary-tagged-0.1.3.0/-instance HasStructuralInfo Ordering where structuralInfo = ghcNominalType---- | /Since binary-tagged-0.1.3.0/-instance HasSemanticVersion Ordering---- | /Since binary-tagged-0.1.3.0/-instance HasStructuralInfo Float where structuralInfo _ = NominalType "Float"---- | /Since binary-tagged-0.1.3.0/-instance HasStructuralInfo Double where structuralInfo _ = NominalType "Double"---- | /Since binary-tagged-0.1.3.0/-instance HasSemanticVersion Float---- | /Since binary-tagged-0.1.3.0/-instance HasSemanticVersion Double------------------------------------------------------------------------------------ Recursive types: List, NonEmpty----------------------------------------------------------------------------------instance HasStructuralInfo a => HasStructuralInfo [a] where structuralInfo = ghcStructuralInfo1-instance HasSemanticVersion a => HasSemanticVersion [a] where-  type SemanticVersion [a] = SemanticVersion a--instance HasStructuralInfo a => HasStructuralInfo (NE.NonEmpty a) where structuralInfo = ghcStructuralInfo1-instance HasSemanticVersion a => HasSemanticVersion (NE.NonEmpty a) where-  type SemanticVersion (NE.NonEmpty a) = SemanticVersion a------------------------------------------------------------------------------------ Basic types----------------------------------------------------------------------------------instance HasStructuralInfo a => HasStructuralInfo (Maybe a)-instance HasSemanticVersion a => HasSemanticVersion (Maybe a) where-  type SemanticVersion (Maybe a) = SemanticVersion a--instance HasStructuralInfo a => HasStructuralInfo (Ratio.Ratio a) where-  structuralInfo _ = NominalNewtype "Ratio" $ structuralInfo (Proxy :: Proxy a)-instance HasSemanticVersion a => HasSemanticVersion (Ratio.Ratio a) where-  type SemanticVersion (Ratio.Ratio 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)--instance (HasSemanticVersion a-         ,HasSemanticVersion b-         ,KnownNat (SemanticVersion (a, b))) => HasSemanticVersion (a, b) where-  type SemanticVersion (a, b) = Interleave (SemanticVersion a) (SemanticVersion b)---- | /Since binary-tagged-0.1.3.0/-instance (HasSemanticVersion a-         ,HasSemanticVersion b-         ,HasSemanticVersion c-         ,KnownNat (SemanticVersion (a, b, c))) => HasSemanticVersion (a, b, c) where-  type SemanticVersion (a, b, c) = Interleave (SemanticVersion a) (SemanticVersion (b, c))---- | /Since binary-tagged-0.1.3.0/-instance (HasSemanticVersion a-         ,HasSemanticVersion b-         ,HasSemanticVersion c-         ,HasSemanticVersion d-         ,KnownNat (SemanticVersion (a, b, c, d))) => HasSemanticVersion (a, b, c, d) where-  type SemanticVersion (a, b, c, d) = Interleave (SemanticVersion a) (SemanticVersion (b, c, d))------------------------------------------------------------------------------------ Unit------------------------------------------------------------------------------------ | /Since binary-tagged-0.1.3.0/-instance HasStructuralInfo () where structuralInfo _ = NominalType "()"---- | /Since binary-tagged-0.1.3.0/-instance HasSemanticVersion ()------------------------------------------------------------------------------------ Data.Fixed------------------------------------------------------------------------------------ | /Since binary-tagged-0.1.3.0/-instance HasStructuralInfo a => HasStructuralInfo (Fixed.Fixed a) where-  structuralInfo _ = StructuralInfo "Fixed" [[ structuralInfo (Proxy :: Proxy a) ]]--instance HasStructuralInfo Fixed.E0 where structuralInfo _ = NominalType "E0"-instance HasStructuralInfo Fixed.E1 where structuralInfo _ = NominalType "E1"-instance HasStructuralInfo Fixed.E2 where structuralInfo _ = NominalType "E2"-instance HasStructuralInfo Fixed.E3 where structuralInfo _ = NominalType "E3"-instance HasStructuralInfo Fixed.E6 where structuralInfo _ = NominalType "E6"-instance HasStructuralInfo Fixed.E9 where structuralInfo _ = NominalType "E9"-instance HasStructuralInfo Fixed.E12 where structuralInfo _ = NominalType "E12"---- | /Since binary-tagged-0.1.3.0/-instance HasSemanticVersion (Fixed.Fixed a)------------------------------------------------------------------------------------ Data.Version------------------------------------------------------------------------------------ | /Since binary-tagged-0.1.3.0/-instance HasStructuralInfo Version.Version where-  structuralInfo _ = StructuralInfo "Version" [[ structuralInfo (Proxy :: Proxy [Int])-                                               , structuralInfo (Proxy :: Proxy [String])-                                              ]]--- Version has no Generic instance :(---- | /Since binary-tagged-0.1.3.0/-instance HasSemanticVersion Version.Version------------------------------------------------------------------------------------ Data.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---- | /Since binary-tagged-0.1.4.0/-instance HasStructuralInfo a => HasStructuralInfo (Monoid.Dual a)--- | /Since binary-tagged-0.1.4.0/-instance HasSemanticVersion a => HasSemanticVersion (Monoid.Dual a) where-  type SemanticVersion (Monoid.Dual a) = SemanticVersion a---- | /Since binary-tagged-0.1.4.0/-instance HasStructuralInfo a => HasStructuralInfo (Monoid.First a)--- | /Since binary-tagged-0.1.4.0/-instance HasSemanticVersion a => HasSemanticVersion (Monoid.First a) where-  type SemanticVersion (Monoid.First a) = SemanticVersion a---- | /Since binary-tagged-0.1.4.0/-instance HasStructuralInfo a => HasStructuralInfo (Monoid.Last a)--- | /Since binary-tagged-0.1.4.0/-instance HasSemanticVersion a => HasSemanticVersion (Monoid.Last a) where-  type SemanticVersion (Monoid.Last a) = SemanticVersion a---- | /Since binary-tagged-0.1.4.0/-instance HasStructuralInfo Monoid.All--- | /Since binary-tagged-0.1.4.0/-instance  HasSemanticVersion Monoid.All---- | /Since binary-tagged-0.1.4.0/-instance HasStructuralInfo Monoid.Any--- | /Since binary-tagged-0.1.4.0/-instance  HasSemanticVersion Monoid.Any------------------------------------------------------------------------------------ semigroups------------------------------------------------------------------------------------ | /Since binary-tagged-0.1.4.0/-instance HasStructuralInfo a => HasStructuralInfo (Semigroup.Min a)--- | /Since binary-tagged-0.1.4.0/-instance HasSemanticVersion a => HasSemanticVersion (Semigroup.Min a) where-  type SemanticVersion (Semigroup.Min a) = SemanticVersion a---- | /Since binary-tagged-0.1.4.0/-instance HasStructuralInfo a => HasStructuralInfo (Semigroup.Max a)--- | /Since binary-tagged-0.1.4.0/-instance HasSemanticVersion a => HasSemanticVersion (Semigroup.Max a) where-  type SemanticVersion (Semigroup.Max a) = SemanticVersion a---- | /Since binary-tagged-0.1.4.0/-instance HasStructuralInfo a => HasStructuralInfo (Semigroup.First a)--- | /Since binary-tagged-0.1.4.0/-instance HasSemanticVersion a => HasSemanticVersion (Semigroup.First a) where-  type SemanticVersion (Semigroup.First a) = SemanticVersion a---- | /Since binary-tagged-0.1.4.0/-instance HasStructuralInfo a => HasStructuralInfo (Semigroup.Last a)--- | /Since binary-tagged-0.1.4.0/-instance HasSemanticVersion a => HasSemanticVersion (Semigroup.Last a) where-  type SemanticVersion (Semigroup.Last a) = SemanticVersion a---- | /Since binary-tagged-0.1.4.0/-instance HasStructuralInfo a => HasStructuralInfo (Semigroup.WrappedMonoid a)--- | /Since binary-tagged-0.1.4.0/-instance HasSemanticVersion a => HasSemanticVersion (Semigroup.WrappedMonoid a) where-  type SemanticVersion (Semigroup.WrappedMonoid a) = SemanticVersion a---- | /Since binary-tagged-0.1.4.0/-instance HasStructuralInfo a => HasStructuralInfo (Semigroup.Option a)--- | /Since binary-tagged-0.1.4.0/-instance HasSemanticVersion a => HasSemanticVersion (Semigroup.Option a) where-  type SemanticVersion (Semigroup.Option a) = SemanticVersion a------------------------------------------------------------------------------------ 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------------------------------------------------------------------------------------ nats------------------------------------------------------------------------------------ | /Since binary-tagged-0.1.4.0/-instance HasStructuralInfo Natural.Natural where structuralInfo _ = NominalType "Numeric.Natural"--- | /Since binary-tagged-0.1.4.0/-instance HasSemanticVersion Natural.Natural------------------------------------------------------------------------------------ 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+module Data.Binary.Tagged (+    -- * Encoding and decoding+    -- | These functions operate like @binary@'s counterparts,+    -- but the serialised version has a structure hash in front.+    structuredEncode,+    structuredEncodeFile,+    structuredDecode,+    structuredDecodeOrFailIO,+    structuredDecodeFileOrFail,+    -- * Structured class+    Structured (structure),+    structureHash,+    structureBuilder,+    genericStructure,+    GStructured,+    nominalStructure,+    containerStructure,+    -- * Structure type+    Structure (..),+    TypeName,+    ConstructorName,+    TypeVersion,+    SopStructure,+    hashStructure,+    typeVersion,+    typeName,+    -- * MD5+    MD5,+    showMD5,+    md5,+    md5FromInteger,+    binaryPutMD5,+    binaryGetMD5,+) where -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)+import Data.Structured+import Data.Structured.Internal -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+import qualified Data.Binary          as Binary+import qualified Data.Binary.Get      as Binary+import qualified Data.Binary.Put      as Binary+import qualified Data.ByteString.Lazy as LBS -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+import Control.Exception (ErrorCall (..), catch, evaluate)+import Data.Tagged       (Tagged (..), untag)+import GHC.Fingerprint   (Fingerprint (..))  ---------------------------------------------------------------------------------- unordered-containers+-- Helper data ------------------------------------------------------------------------------- -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--------------------------------------------------------------------------------+data Tag a = Tag -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 Structured a => Binary.Binary (Tag a) where+    get = do+        actual <- binaryGetMD5+        if actual == expected+        then return Tag+        else fail $ concat+            [ "Non-matching structured hashes: "+            , showMD5 actual+            , "; expected: "+            , showMD5 expected+            ]+      where+        expected = untag (structureHash' :: Tagged a MD5) -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)+    put _ = binaryPutMD5 expected+      where+        expected = untag (structureHash' :: Tagged a MD5)  ---------------------------------------------------------------------------------- vector+-- Functions ------------------------------------------------------------------------------- -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+-- | Structured 'Binary.encode'.+-- Encode a value to using binary serialisation to a lazy 'LBS.ByteString'.+-- Encoding starts with 16 byte large structure hash.+structuredEncode+  :: forall a. (Binary.Binary a, Structured a)+  => a -> LBS.ByteString+structuredEncode x = Binary.encode (Tag :: Tag a, x) -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+-- | Lazily serialise a value to a file+structuredEncodeFile :: (Binary.Binary a, Structured a) => FilePath -> a -> IO ()+structuredEncodeFile f = LBS.writeFile f . structuredEncode ----------------------------------------------------------------------------------- time--------------------------------------------------------------------------------+-- | Structured 'Binary.decode'.+-- Decode a value from a lazy 'LBS.ByteString', reconstructing the original structure.+-- Throws pure exception on invalid inputs.+structuredDecode+  :: forall a. (Binary.Binary a, Structured a)+  => LBS.ByteString -> a+structuredDecode lbs = snd (Binary.decode lbs :: (Tag a, a)) -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"+structuredDecodeOrFailIO :: (Binary.Binary a, Structured a) => LBS.ByteString -> IO (Either String a)+structuredDecodeOrFailIO bs =+    catch (evaluate (structuredDecode bs) >>= return . Right) handler+  where+#if MIN_VERSION_base(4,9,0)+    handler (ErrorCallWithLocation str _) = return $ Left str+#else+    handler (ErrorCall str) = return $ Left str+#endif -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+-- | Lazily reconstruct a value previously written to a file.+structuredDecodeFileOrFail :: (Binary.Binary a, Structured a) => FilePath -> IO (Either String a)+structuredDecodeFileOrFail f = structuredDecodeOrFailIO =<< LBS.readFile f  ---------------------------------------------------------------------------------- aeson+-- MD5 extras ------------------------------------------------------------------------------- -#ifdef MIN_VERSION_aeson+binaryPutMD5 :: MD5 -> Binary.Put+binaryPutMD5 (Fingerprint a b) = do+    Binary.putWord64le a+    Binary.putWord64le b --- TODO: derive sop-instance HasStructuralInfo Aeson.Value where structuralInfo _ = NominalType "Aeson.Value"-instance HasSemanticVersion Aeson.Value-#endif+binaryGetMD5 :: Binary.Get MD5+binaryGetMD5 = do+    a <- Binary.getWord64le+    b <- Binary.getWord64le+    return (Fingerprint a b)

@@ -1,5 +1,6 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-} module Rec1 where  #if !MIN_VERSION_base(4,8,0)@@ -10,17 +11,17 @@ import Data.Binary.Instances () import Data.Binary.Tagged import Data.Monoid-import GHC.Generics-import Test.Tasty.QuickCheck+import Data.Typeable         (Typeable)+import GHC.Generics          (Generic)+import Test.QuickCheck       (Arbitrary (..))  import Generators  data Rec = Rec (Sum Int) (Product Int)-  deriving (Eq, Show, Generic)+  deriving (Eq, Show, Generic, Typeable)  instance Binary Rec-instance HasStructuralInfo Rec-instance HasSemanticVersion Rec+instance Structured Rec  instance Arbitrary Rec where   arbitrary = Rec <$> arbitrarySum <*> arbitraryProduct

@@ -1,5 +1,6 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-} module Rec2 where  #if !MIN_VERSION_base(4,8,0)@@ -10,17 +11,17 @@ import Data.Binary.Instances () import Data.Binary.Tagged import Data.Monoid-import GHC.Generics-import Test.Tasty.QuickCheck+import Data.Typeable         (Typeable)+import GHC.Generics          (Generic)+import Test.QuickCheck       (Arbitrary (..))  import Generators  data Rec = Rec (Product Int) (Sum Int)-  deriving (Eq, Show, Generic)+  deriving (Eq, Show, Generic, Typeable)  instance Binary Rec-instance HasStructuralInfo Rec-instance HasSemanticVersion Rec+instance Structured Rec  instance Arbitrary Rec where   arbitrary = Rec <$> arbitraryProduct <*> arbitrarySum

@@ -1,21 +1,28 @@ {-# LANGUAGE DataKinds           #-}-{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE KindSignatures      #-} {-# 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.HUnit       (testCase, (@?=))-import           Test.Tasty.QuickCheck+import Data.Binary               (Binary, decode, encode)+import Data.Coerce               (coerce)+import Data.Either               (isLeft)+import Data.Functor.Identity     (Identity (..))+import Data.Monoid               (Product (..), Sum (..))+import Data.Proxy                (Proxy (..))+import Data.Singletons.Bool      (SBoolI, reflectBool)+import Data.Typeable             (Typeable)+import GHC.Generics              (Generic)+import Test.QuickCheck+       (Arbitrary (..), Property, counterexample, ioProperty, property, (===))+import Test.QuickCheck.Instances ()+import Test.Tasty                (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit          (testCase, (@?=))+import Test.Tasty.QuickCheck     (testProperty) -import qualified Data.ByteString.Base16 as Base16-import qualified Data.ByteString.Char8  as BS8+import Data.Binary.Tagged  import qualified Rec1 import qualified Rec2@@ -25,42 +32,28 @@   [ roundtrips   , wrongRoundtrips   , failedRoundtrips-  , testProperty "Interleave" interleaveProp   , testCase "An example hash" $ do-    let hash = structuralInfoSha1Digest-             $ structuralInfo (Proxy :: Proxy [Either (Maybe Char) (Sum Int)])--    Base16.encode hash @?= BS8.pack "acff3d40f6f06f87b4da8d3d3eb5682251867cc5"+    let hash = structureHash (Proxy :: Proxy [Either (Maybe Char) (Sum Int)])+    hash @?= md5FromInteger 0xbfc698fe96db703b44e5925381902ef2   ] --- | We actually check that this compiles.-interleaveProp :: Property-interleaveProp = property $ once $ lhs === rhs-  where lhs :: Proxy 7-        lhs = Proxy-        rhs :: Proxy (Interleave 2 1)-        rhs = Proxy--instance Arbitrary a => Arbitrary (BinaryTagged v a) where-  arbitrary = fmap BinaryTagged arbitrary- proxyRec1 :: Proxy Rec1.Rec proxyRec1 = Proxy -proxyRec1Ver0 :: Proxy (BinaryTagged 0 Rec1.Rec)+proxyRec2 :: Proxy Rec2.Rec+proxyRec2 = Proxy++proxyRec1Ver0 :: Proxy (VerTagged 'False Rec1.Rec) proxyRec1Ver0 = Proxy -proxyRec1Ver1 :: Proxy (BinaryTagged 1 Rec1.Rec)+proxyRec1Ver1 :: Proxy (VerTagged 'True Rec1.Rec) proxyRec1Ver1 = Proxy -proxyRec2 :: Proxy Rec2.Rec-proxyRec2 = Proxy--proxyRec2Ver0 :: Proxy (BinaryTagged 0 Rec2.Rec)+proxyRec2Ver0 :: Proxy (VerTagged 'False Rec2.Rec) proxyRec2Ver0 = Proxy -proxyRec2Ver1 :: Proxy (BinaryTagged 1 Rec2.Rec)-proxyRec2Ver1 = Proxy+-- proxyRec2Ver1 :: Proxy (VerTagged 'True Rec2.Rec)+-- proxyRec2Ver1 = Proxy  eqRec1Rec2 :: Rec1.Rec -> Rec2.Rec -> Bool eqRec1Rec2 (Rec1.Rec (Sum a) (Product b)) (Rec2.Rec (Product a') (Sum b')) =@@ -69,11 +62,7 @@ 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@@ -88,18 +77,45 @@   , 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)+roundtrip :: (Eq a, Show a, Arbitrary a, Binary a, Structured a) => Proxy a -> a -> Property+roundtrip _ x = x === structuredDecode (structuredEncode x) -wrongRoundtrip :: (Arbitrary a, Binary a, Binary b) => (a -> b -> Bool) -> a -> Property+wrongRoundtrip :: (Arbitrary a, Binary a, Binary b, Structured a, Structured 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)+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'+failedRoundtrip :: forall a b. (Arbitrary a, Binary a, Binary b, Structured a, Structured b, Show b) => Proxy a -> Proxy b -> a -> Property+failedRoundtrip _ _ x = ioProperty $ do+    x' <- structuredDecodeOrFailIO (structuredEncode x) :: IO (Either String b)+    return (isLeftProperty x')++-------------------------------------------------------------------------------+-- VerTagged+-------------------------------------------------------------------------------++newtype VerTagged (v :: Bool) a = VT a deriving (Eq, Show, Generic, Typeable)++instance Binary a => Binary (VerTagged v a)++instance (SBoolI v, Typeable v, Structured a) => Structured (VerTagged v a) where+    structure = set typeVersion (fromBool $ reflectBool (Proxy :: Proxy v)) . genericStructure++fromBool :: Integral a => Bool -> a+fromBool True  = 1+fromBool False = 0++instance Arbitrary a => Arbitrary (VerTagged v a) where+    arbitrary     = fmap VT arbitrary+    shrink (VT x) = fmap VT (shrink x)++-------------------------------------------------------------------------------+-- Lens+-------------------------------------------------------------------------------++over :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t+over = coerce++set :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t+set l b = over l (const b)