packages feed

binary-tagged 0.1.5.2 → 0.3.1

raw patch · 9 files changed

Files

CHANGELOG.md view
@@ -1,3 +1,13 @@+- 0.3.1 (2021-10-10)+    - Support `aeson-2.0.0.0`++- 0.3 (2020-05-16)+    - Major rewrite: use `structured`.++- 0.2 (2019-05-14)+    - use cryptohash-sha1,+      types of structuralInfoSha1Digest and structuralInfoSha1Digest are changed.+    - Use binary-instances in tests - 0.1.5.2 (2019-05-10)     - generics-sop-0.5 - 0.1.5.1 (2018-09-24)
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2015, Oleg Grenrus+Copyright (c) 2015-2020, Oleg Grenrus  All rights reserved.
− README.md 
@@ -1,34 +0,0 @@-# binary-tagged--[![Build Status](https://travis-ci.org/phadej/binary-tagged.svg?branch=master)](https://travis-ci.org/phadej/binary-tagged)-[![Hackage](https://img.shields.io/hackage/v/binary-tagged.svg)](http://hackage.haskell.org/package/binary-tagged)-[![Stackage LTS 2](http://stackage.org/package/binary-tagged/badge/lts-2)](http://stackage.org/lts-2/package/binary-tagged)-[![Stackage LTS 3](http://stackage.org/package/binary-tagged/badge/lts-3)](http://stackage.org/lts-3/package/binary-tagged)-[![Stackage Nightly](http://stackage.org/package/binary-tagged/badge/nightly)](http://stackage.org/nightly/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).
bench/Bench.hs view
@@ -1,57 +1,62 @@-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-} module Main (main) where -import Control.DeepSeq-import Data.ByteString.Lazy as LBS-import Data.Binary.Orphans+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       ]   ]
binary-tagged.cabal view
@@ -1,19 +1,57 @@-cabal-version:  >= 1.10-name:           binary-tagged-version:        0.1.5.2--synopsis:       Tagged binary serialisation.-category:       Data-description:    Check <https://github.com/phadej/binary-tagged#readme README on Github>--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-build-type:     Simple+cabal-version:      2.2+name:               binary-tagged+version:            0.3.1+synopsis:           Tagged binary serialisation.+category:           Data+description:+  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 'Structured' Record+  @+  .+  then you can serialise and deserialise @Record@ values with a structure tag by simply+  .+  @+  '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.+  .+  @+  benchmarking encode/Binary+  time                 352.8 μs   (349.5 μs .. 355.9 μs)+  .+  benchmarking encode/Tagged+  time                 350.8 μs   (349.0 μs .. 353.1 μs)+  .+  benchmarking decode/Binary+  time                 346.8 μs   (344.7 μs .. 349.9 μs)+  .+  benchmarking decode/Tagged+  time                 353.8 μs   (352.0 μs .. 355.8 μs)+  @ +bug-reports:        https://github.com/phadej/binary-tagged/issues+author:             Oleg Grenrus <oleg.grenrus@iki.fi>+maintainer:         Oleg Grenrus <oleg.grenrus@iki.fi>+license:            BSD-3-Clause+license-file:       LICENSE+build-type:         Simple tested-with:   GHC ==7.8.4    || ==7.10.3@@ -21,121 +59,79 @@    || ==8.2.2    || ==8.4.4    || ==8.6.5+   || ==8.8.4+   || ==8.10.4+   || ==9.0.1 -extra-source-files:-    CHANGELOG.md-    README.md+extra-source-files: CHANGELOG.md  source-repository head-  type: git+  type:     git   location: https://github.com/phadej/binary-tagged+  subdir:   binary-tagged  library-  hs-source-dirs:-      src-  ghc-options: -Wall+  hs-source-dirs:   src+  ghc-options:      -Wall +  -- we build on top of structured+  build-depends:    structured >=0.1.1 && <0.1.2+   -- Libraries bundled with GHC   build-depends:-      base                     >=4.7.0.2  && <4.13-    , array                    >=0.5.0.0  && <0.6-    , binary                   >=0.7.1.0  && <0.10-    , bytestring               >=0.10.4.0 && <0.11-    , containers               >=0.5.5.1  && <0.7-    , text                     >=1.2.3.0  && <1.3-    , time                     >=1.4.2    && <1.9+    , array       ^>=0.5.0.0+    , base        >=4.7.0.2  && <4.16+    , binary      >=0.7.1.0  && <0.10+    , bytestring  ^>=0.10.4.0 || ^>=0.11+    , containers  >=0.5.5.1  && <0.7    -- other dependencies   build-depends:-      aeson                    >=0.8     && <1.5-    , base16-bytestring        >=0.1.1.6 && <0.2-    , generics-sop             >=0.3.2.0 && <0.6-    , hashable                 >=1.2     && <1.4-    , scientific               >=0.3     && <0.4-    , SHA                      >=1.6     && <1.7-    , tagged                   >=0.7     && <0.9-    , unordered-containers     >=0.2     && <0.3-    , vector                   >=0.10    && <0.13+    , base16-bytestring  ^>=0.1.1.6 || ^>=1.0.0.0+    , tagged             ^>=0.8.6 -  exposed-modules:-      Data.Binary.Tagged+  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-  type: exitcode-stdio-1.0-  main-is: Tests.hs-  hs-source-dirs:-      test-  ghc-options: -Wall+  default-language: Haskell2010+  type:             exitcode-stdio-1.0+  main-is:          Tests.hs+  hs-source-dirs:   test+  ghc-options:      -Wall   build-depends:-      base-    , aeson-    , array-    , base16-bytestring+    , base     , binary-    , bytestring-    , containers-    , generics-sop-    , hashable-    , scientific-    , SHA-    , tagged-    , text-    , time-    , unordered-containers-    , vector+    , binary-instances      ^>=1     , binary-tagged-    , binary-orphans-    , bifunctors+    , bytestring+    , QuickCheck            ^>=2.14     , quickcheck-instances+    , singleton-bool        ^>=0.1.5+    , tagged     , tasty+    , tasty-hunit     , tasty-quickcheck-  if !impl(ghc >= 8.0)-    build-depends:-      semigroups-  if !impl(ghc >= 7.10)-    build-depends:-      nats+    , transformers+   other-modules:-      Generators-      Rec1-      Rec2-  default-language: Haskell2010+    Generators+    Rec1+    Rec2  benchmark binary-tagged-bench-  type: exitcode-stdio-1.0-  main-is: Bench.hs-  hs-source-dirs:-      bench-  ghc-options: -Wall+  default-language: Haskell2010+  type:             exitcode-stdio-1.0+  main-is:          Bench.hs+  hs-source-dirs:   bench+  ghc-options:      -Wall   build-depends:-      base-    , aeson-    , array-    , base16-bytestring+    , base     , binary+    , binary-instances+    , binary-tagged     , bytestring-    , containers-    , generics-sop-    , hashable-    , nats-    , scientific-    , SHA-    , semigroups-    , tagged+    , criterion+    , deepseq     , text-    , time     , unordered-containers-    , vector-    , binary-tagged-    , binary-orphans-    , deepseq-    , criterion-  default-language: Haskell2010
src/Data/Binary/Tagged.hs view
@@ -1,731 +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 CPP                 #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}--- We need this for Interleave-{-# LANGUAGE UndecidableInstances #-}+{-# 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           Data.Binary-import           Data.Binary.Get (ByteOffset)-import           Data.ByteString as BS-import           Data.ByteString.Lazy as LBS-import qualified Data.ByteString.Base16.Lazy as Base16-import           Data.Digest.Pure.SHA-import           Data.Monoid ((<>))-import           Data.Proxy-import           Generics.SOP as SOP-import           Generics.SOP.GGP as SOP-import           Generics.SOP.Constraint 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           Data.Int-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 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)--- 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' = 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-                            , 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 -> Digest SHA1State-structuralInfoSha1Digest = sha1 . encode--structuralInfoSha1ByteStringDigest :: StructuralInfo -> LBS.ByteString-structuralInfoSha1ByteStringDigest = bytestringDigest . 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)
test/Rec1.hs view
@@ -1,25 +1,27 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-} module Rec1 where  #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif -import Data.Binary.Orphans+import Data.Binary+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
test/Rec2.hs view
@@ -1,25 +1,27 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-} module Rec2 where  #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif -import Data.Binary.Orphans+import Data.Binary+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
test/Tests.hs view
@@ -1,18 +1,29 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds           #-}+{-# 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.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 Data.Binary.Tagged+ import qualified Rec1 import qualified Rec2 @@ -21,37 +32,28 @@   [ roundtrips   , wrongRoundtrips   , failedRoundtrips-  , testProperty "Interleave" interleaveProp+  , testCase "An example hash" $ do+    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')) =@@ -60,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@@ -79,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)