diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,11 @@ ## Unreleased +## 0.1.1.0 - 2025-02-05 + +- Add serialization support of `Vary` for `binary`'s `Data.Binary` and `cereal`'s `Data.Serialize`. +- Document `Data.Aeson` round-tripping behaviour (namely: only round-trippable if encodings do not overlap, the `UntaggedValue` sum encoding). + ## 0.1.0.5 - 2025-02-05 - Relax max allowed versions of DeepSeq (<1.6), Hashable (<1.6), QuickCheck (<2.16) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -313,6 +313,7 @@ but we don't want it to be visible to human readers: ```haskell top:1 +{-# OPTIONS_GHC -Wno-missing-export-lists #-} {-# OPTIONS_GHC -fdefer-type-errors #-} -- We want to show some incorrect examples! module Main where diff --git a/src/Vary.hs b/src/Vary.hs --- a/src/Vary.hs +++ b/src/Vary.hs @@ -27,6 +27,7 @@ -- $setup -- $motivating_example -- $vary_and_exceptions + -- $vary_and_serialization -- * Core type definition Vary, @@ -149,6 +150,19 @@ -- >>> catcher (throw AllocationLimitExceeded) -- *** Exception: allocation limit exceeded + +-- $vary_and_serialization +-- +-- == (De)Serializing Vary values +-- +-- `Vary` has optional dependencies to enable `aeson`'s `Data.Aeson`, `binary`'s `Data.Binary` and `cereal`'s `Data.Serealize` serialization. +-- +-- Specifically for Aeson serialization, Vary datatypes are encoded +-- as their ['UntaggedValue'](https://hackage.haskell.org/package/aeson-2.0.3.0/docs/Data-Aeson-Types.html#t:SumEncoding) encoding. +-- This means that serialization to JSON only round-trips when the encodings are disjoint; +-- on decoding, the first variant to succeed is used. +-- +-- The Binary and Serialize instances always round-trip, as their encoding contains the variant's tag index. -- | Builds a Vary from the given value. -- diff --git a/src/Vary/Core.hs b/src/Vary/Core.hs --- a/src/Vary/Core.hs +++ b/src/Vary/Core.hs @@ -30,6 +30,14 @@ import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink) # endif +# ifdef FLAG_BINARY +import Data.Binary qualified as Binary +# endif + +# ifdef FLAG_CEREAL +import Data.Serialize qualified as Cereal +# endif + -- $setup -- >>> :set -XGHC2021 -- >>> :set -XDataKinds @@ -231,6 +239,10 @@ deriving instance (Aeson.FromJSON a) => Aeson.FromJSON (Vary '[a]) +-- | This instance round-trips iff there is no overlap between the encodings of the element types. +-- +-- For example, a `Vary '[Int, String] is round-trippable +-- but a `Vary '[String, Char]` is not. instance (Aeson.FromJSON a, Aeson.FromJSON (Vary (b : bs))) => Aeson.FromJSON (Vary (a : b : bs)) where {-# INLINE parseJSON #-} parseJSON val = (pushHead <$> Aeson.parseJSON val) <|> (pushTail <$> Aeson.parseJSON val) @@ -239,6 +251,10 @@ deriving instance (Aeson.ToJSON a) => Aeson.ToJSON (Vary '[a]) +-- | This instance round-trips iff there is no overlap between the encodings of the element types. +-- +-- For example, a `Vary '[Int, String] is round-trippable +-- but a `Vary '[String, Char]` is not. instance (Aeson.ToJSON a, Aeson.ToJSON (Vary (b : bs))) => Aeson.ToJSON (Vary (a : b : bs)) where {-# INLINE toJSON #-} toJSON vary = @@ -291,4 +307,79 @@ where hashWithSalt salt vary@(Vary tag _inner) = fromIntegral tag `hashWithSalt` badHashWithSalt salt vary hash vary@(Vary tag _inner) = badHashWithSalt (fromIntegral tag) vary +#endif + +#ifdef FLAG_BINARY +class BinaryHelper a where + binaryPutVariant :: a -> Binary.Put + binaryGetVariant :: Word -> Binary.Get a + +instance BinaryHelper (Vary '[]) where + {-# INLINE binaryPutVariant #-} + binaryPutVariant emptyVary = case from emptyVary of {} + + {-# INLINE binaryGetVariant #-} + binaryGetVariant = emptyVaryError "binaryGetVariant" undefined + +instance + ( Binary.Binary a + , BinaryHelper (Vary as) + ) => + BinaryHelper (Vary (a : as)) + where + {-# INLINE binaryPutVariant #-} + binaryPutVariant vary = case pop vary of + Right val -> Binary.put val + Left val -> binaryPutVariant val + + {-# INLINE binaryGetVariant #-} + binaryGetVariant 0 = pushHead <$> Binary.get @a + binaryGetVariant n = pushTail <$> binaryGetVariant @(Vary as) (n - 1) + +instance (BinaryHelper (Vary as)) => Binary.Binary (Vary as) where + {-# INLINE put #-} + put vary@(Vary n _) = do + Binary.put n + binaryPutVariant vary + {-# INLINE get #-} + get = do + tag <- Binary.get + binaryGetVariant tag +#endif + +#ifdef FLAG_CEREAL +class SerializeHelper a where + cerealPutVariant :: a -> Cereal.Put + cerealGetVariant :: Word -> Cereal.Get a + +instance SerializeHelper (Vary '[]) where + {-# INLINE cerealPutVariant #-} + cerealPutVariant emptyVary = case from emptyVary of {} + {-# INLINE cerealGetVariant #-} + cerealGetVariant = emptyVaryError "cerealGetVariant" undefined + +instance + ( Cereal.Serialize a + , SerializeHelper (Vary as) + ) => + SerializeHelper (Vary (a : as)) + where + {-# INLINE cerealPutVariant #-} + cerealPutVariant vary = case pop vary of + Right val -> Cereal.put val + Left val -> cerealPutVariant val + + {-# INLINE cerealGetVariant #-} + cerealGetVariant 0 = pushHead <$> Cereal.get @a + cerealGetVariant n = pushTail <$> cerealGetVariant @(Vary as) (n - 1) + +instance (SerializeHelper (Vary as)) => Cereal.Serialize (Vary as) where + {-# INLINE put #-} + put vary@(Vary n _) = do + Cereal.putWord64le (fromIntegral n) + cerealPutVariant vary + {-# INLINE get #-} + get = do + tag <- Cereal.getWord64le + cerealGetVariant (fromIntegral tag) #endif diff --git a/src/Vary/VEither.hs b/src/Vary/VEither.hs --- a/src/Vary/VEither.hs +++ b/src/Vary/VEither.hs @@ -62,6 +62,14 @@ import Test.QuickCheck # endif +# ifdef FLAG_CEREAL +import Data.Serialize qualified as Cereal +# endif + +# ifdef FLAG_BINARY +import Data.Binary qualified as Binary +# endif + -- $setup -- -- This module is intended to be used qualified: @@ -353,4 +361,12 @@ #ifdef FLAG_QUICKCHECK deriving instance (Arbitrary (Vary (a : errs))) => Test.QuickCheck.Arbitrary (VEither errs a) +#endif + +#ifdef FLAG_CEREAL +deriving instance (Cereal.Serialize (Vary (a : errs))) => Cereal.Serialize (VEither errs a) +#endif + +#ifdef FLAG_BINARY +deriving instance (Binary.Binary (Vary (a : errs))) => Binary.Binary (VEither errs a) #endif diff --git a/test/README.lhs b/test/README.lhs --- a/test/README.lhs +++ b/test/README.lhs @@ -313,6 +313,7 @@ but we don't want it to be visible to human readers: ```haskell top:1 +{-# OPTIONS_GHC -Wno-missing-export-lists #-} {-# OPTIONS_GHC -fdefer-type-errors #-} -- We want to show some incorrect examples! module Main where diff --git a/test/doctest/doctests.hs b/test/doctest/doctests.hs --- a/test/doctest/doctests.hs +++ b/test/doctest/doctests.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Main where import Test.DocTest (mainFromCabal) diff --git a/test/spec/spec.hs b/test/spec/spec.hs --- a/test/spec/spec.hs +++ b/test/spec/spec.hs @@ -1,3 +1,40 @@ -module Main where +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main (main) where + +import Test.Hspec +import Test.Hspec.QuickCheck + +import Data.Aeson qualified as Aeson +import Data.Binary qualified as Binary +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.Serialize qualified as Cereal + +import Vary (Vary) + +type TestVariant = Vary '[Int, String, Maybe [Bool]] + main :: IO () -main = putStrLn "(No separate unit tests yet)" +main = hspec $ do + describe "Serialization with aeson" $ do + prop "encodes properly" $ \(v :: TestVariant) -> do + Aeson.encode v `shouldSatisfy` (not . LBS.null) + prop "encode - decode roundtrips" $ \(v :: TestVariant) -> do + -- NOTE: `TestVariant` is chosen so the JSON encodings do not overlap. + -- Without that, this property would not hold + Aeson.eitherDecode (Aeson.encode v) `shouldBe` Right v + + describe "Serialization with binary" $ do + prop "encodes properly" $ \(v :: TestVariant) -> do + Binary.encode v `shouldSatisfy` (not . LBS.null) + prop "encode - decode roundtrips" $ \(v :: TestVariant) -> do + Binary.decode (Binary.encode v) `shouldBe` v + + describe "Serialization with cereal" $ do + prop "encodes properly" $ \(v :: TestVariant) -> do + Cereal.encode v `shouldSatisfy` (not . BS.null) + prop "encode - decode roundtrips" $ \(v :: TestVariant) -> do + Cereal.decode (Cereal.encode v) `shouldBe` Right v diff --git a/vary.cabal b/vary.cabal --- a/vary.cabal +++ b/vary.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: vary -version: 0.1.0.5 +version: 0.1.1.0 synopsis: Vary: Friendly and fast polymorphic variants (open unions/coproducts/extensible sums) description: Vary: Friendly and fast Variant types for Haskell . @@ -40,6 +40,16 @@ manual: True default: True +flag binary + description: When enabled implements the @Binary@ typeclass from the binary library. When disabled, does not depend on the binary library. + manual: True + default: True + +flag cereal + description: When enabled implements the @Serialize@ typeclass from the cereal library. When disabled, does not depend on the cereal library. + manual: True + default: True + flag hashable description: When enabled implements the @Hashable@ typeclass from the hashable library. When disabled, does not depend on the @hashable@ library. manual: True @@ -72,6 +82,14 @@ cpp-options: -DFLAG_AESON build-depends: aeson >=2.0.0 && <2.3 + if flag(binary) + cpp-options: -DFLAG_BINARY + build-depends: + binary >=0.8.0.0 && <0.9.0.0 + if flag(cereal) + cpp-options: -DFLAG_CEREAL + build-depends: + cereal >=0.5.0.0 && <0.6.0.0 if flag(quickcheck) cpp-options: -DFLAG_QUICKCHECK build-depends: @@ -99,6 +117,14 @@ cpp-options: -DFLAG_AESON build-depends: aeson >=2.0.0 && <2.3 + if flag(binary) + cpp-options: -DFLAG_BINARY + build-depends: + binary >=0.8.0.0 && <0.9.0.0 + if flag(cereal) + cpp-options: -DFLAG_CEREAL + build-depends: + cereal >=0.5.0.0 && <0.6.0.0 if flag(quickcheck) cpp-options: -DFLAG_QUICKCHECK build-depends: @@ -128,6 +154,14 @@ cpp-options: -DFLAG_AESON build-depends: aeson >=2.0.0 && <2.3 + if flag(binary) + cpp-options: -DFLAG_BINARY + build-depends: + binary >=0.8.0.0 && <0.9.0.0 + if flag(cereal) + cpp-options: -DFLAG_CEREAL + build-depends: + cereal >=0.5.0.0 && <0.6.0.0 if flag(quickcheck) cpp-options: -DFLAG_QUICKCHECK build-depends: @@ -142,8 +176,14 @@ test/spec ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + QuickCheck >=2.12 && <2.15 + , aeson >=2.0.0 && <2.3 + , base >=4.7 && <5 + , binary + , bytestring + , cereal , deepseq >=1.4.0 && <1.6 + , hspec , vary default-language: Haskell2010 if flag(hashable) @@ -154,6 +194,14 @@ cpp-options: -DFLAG_AESON build-depends: aeson >=2.0.0 && <2.3 + if flag(binary) + cpp-options: -DFLAG_BINARY + build-depends: + binary >=0.8.0.0 && <0.9.0.0 + if flag(cereal) + cpp-options: -DFLAG_CEREAL + build-depends: + cereal >=0.5.0.0 && <0.6.0.0 if flag(quickcheck) cpp-options: -DFLAG_QUICKCHECK build-depends: