diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Oleg Grenrus +Copyright (c) 2015-2020, Oleg Grenrus All rights reserved. diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -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). diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -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 ] ] diff --git a/binary-tagged.cabal b/binary-tagged.cabal --- a/binary-tagged.cabal +++ b/binary-tagged.cabal @@ -1,19 +1,57 @@ -cabal-version: >= 1.10 -name: binary-tagged -version: 0.1.5.2 - -synopsis: Tagged binary serialisation. -category: Data -description: Check - -homepage: https://github.com/phadej/binary-tagged#readme -bug-reports: https://github.com/phadej/binary-tagged/issues -author: Oleg Grenrus -maintainer: Oleg Grenrus -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 +maintainer: Oleg Grenrus +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 diff --git a/src/Data/Binary/Tagged.hs b/src/Data/Binary/Tagged.hs --- a/src/Data/Binary/Tagged.hs +++ b/src/Data/Binary/Tagged.hs @@ -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 -- -- 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) diff --git a/test/Rec1.hs b/test/Rec1.hs --- a/test/Rec1.hs +++ b/test/Rec1.hs @@ -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 diff --git a/test/Rec2.hs b/test/Rec2.hs --- a/test/Rec2.hs +++ b/test/Rec2.hs @@ -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 diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -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)