generic-override-aeson 0.3.0.0 → 0.4.0.0

raw patch · 5 files changed

+253/−78 lines, 5 filesdep ~generic-overridePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: generic-override

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• generic-override-aeson.cabal +9/−5
• src/Data/Override/Aeson.hs +16/−35
• src/Data/Override/Aeson/Options/Internal.hs +99/−0
• test/Test.hs +120/−38

@@ -1,5 +1,14 @@ # Changelog for generic-override-aeson +## 0.4.0.0++* Add `WithAesonOptions` support+* Bumping dependency bounds to support generic-override 0.4+* Because this version of generic-override no longer uses `Overridden` under+    the hood, this solves a problem where `omitNothingFields` had no effect+    due to aeson's incoherent `Maybe` instance not being solved. The new+    encoding solves this problem and `omitNothingFields` works as expected.+ ## 0.3.0.0  * Bumping dependency bounds to support generic-override 0.3

@@ -1,6 +1,6 @@ cabal-version:      1.12 name:               generic-override-aeson-version:            0.3.0.0+version:            0.4.0.0 license:            BSD3 license-file:       LICENSE copyright:          2020 Estatico Studios LLC@@ -25,14 +25,18 @@     location: https://github.com/estatico/generic-override  library-    exposed-modules:  Data.Override.Aeson+    exposed-modules:+        Data.Override.Aeson+        Data.Override.Aeson.Options.Internal+     hs-source-dirs:   src     other-modules:    Paths_generic_override_aeson     default-language: Haskell2010+    ghc-options:      -Wall     build-depends:         aeson >=1.4 && <3,         base >=4.7 && <5,-        generic-override >=0.3.0.0 && <0.4+        generic-override >=0.4.0.0 && <0.5  test-suite generic-override-aeson-test     type:             exitcode-stdio-1.0@@ -43,11 +47,11 @@         Paths_generic_override_aeson      default-language: Haskell2010-    ghc-options:      -threaded -rtsopts -with-rtsopts=-N+    ghc-options:      -Wall -threaded -rtsopts -with-rtsopts=-N     build-depends:         aeson >=1.4 && <3,         base >=4.7 && <5,-        generic-override >=0.3.0.0 && <0.4,+        generic-override >=0.4.0.0 && <0.5,         generic-override-aeson -any,         hspec >=2.7.1 && <2.8,         text >=1.2.3.1 && <1.3

@@ -1,46 +1,27 @@--- | This module contains only orphan instances. It is only needed to--- be imported where you are overriding instances for aeson generic derivation.--{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}+-- | The public, stable @generic-override-aeson@ API.+-- Provides orphan instances for 'Override' as well as customization+-- for aeson's 'Options' when using @DerivingVia@. {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-module Data.Override.Aeson where+module Data.Override.Aeson+  ( WithAesonOptions(..)+  , AesonOption(..)+  ) where -import Data.Coerce (Coercible, coerce)-import Data.Override.Internal (Override, Overridden(Overridden), Using)+import Data.Aeson+import Data.Override (Override(..))+import Data.Override.Aeson.Options.Internal (AesonOption(..), WithAesonOptions(..)) import GHC.Generics (Generic, Rep)-import qualified Data.Aeson as Aeson  instance   ( Generic (Override a xs)-  , Aeson.GToJSON Aeson.Zero (Rep (Override a xs))-  , Aeson.GToEncoding Aeson.Zero (Rep (Override a xs))-  ) => Aeson.ToJSON (Override a xs)--instance-  ( Coercible a (Using ms a xs)-  , Aeson.ToJSON (Using ms a xs)-  ) => Aeson.ToJSON (Overridden ms a xs)-  where-  toJSON = Aeson.toJSON @(Using ms a xs) . coerce-  toEncoding = Aeson.toEncoding @(Using ms a xs) . coerce+  , GToJSON Zero (Rep (Override a xs))+  , GToEncoding Zero (Rep (Override a xs))+  ) => ToJSON (Override a xs)  instance   ( Generic (Override a xs)-  , Aeson.GFromJSON Aeson.Zero (Rep (Override a xs))-  ) => Aeson.FromJSON (Override a xs)--instance-  ( Coercible a (Using ms a xs)-  , Aeson.FromJSON (Using ms a xs)-  ) => Aeson.FromJSON (Overridden ms a xs)-  where-  parseJSON = coerce . Aeson.parseJSON @(Using ms a xs)+  , GFromJSON Zero (Rep (Override a xs))+  ) => FromJSON (Override a xs)

@@ -0,0 +1,99 @@+-- | This is the internal generic-override-aeson API and should be considered+-- unstable and subject to change. In general, you should prefer to use the+-- public, stable API provided by "Data.Override.Aeson".+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Data.Override.Aeson.Options.Internal where++import Data.Aeson+import Data.Coerce (coerce)+import Data.Proxy (Proxy(..))+import GHC.Generics (Generic, Rep)+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)++import qualified Data.Aeson as Aeson++-- | Use with @DerivingVia@ to override Aeson @Options@ with a type-level+-- list of 'AesonOption'.+newtype WithAesonOptions (a :: *) (options :: [AesonOption]) = WithAesonOptions a++instance+  ( ApplyAesonOptions options+  , Generic a+  , Aeson.GToJSON Aeson.Zero (Rep a)+  , Aeson.GToEncoding Aeson.Zero (Rep a)+  ) => ToJSON (WithAesonOptions a options)+  where+  toJSON = coerce $ genericToJSON @a $ applyAesonOptions (Proxy @options) defaultOptions+  toEncoding = coerce $ genericToEncoding @a $ applyAesonOptions (Proxy @options) defaultOptions++instance+  ( ApplyAesonOptions options+  , Generic a+  , Aeson.GFromJSON Aeson.Zero (Rep a)+  ) => FromJSON (WithAesonOptions a options)+  where+  parseJSON = coerce $ genericParseJSON @a $ applyAesonOptions (Proxy @options) defaultOptions++-- | Provides a type-level subset of fields from 'Options'+data AesonOption =+    AllNullaryToStringTag Bool -- ^ Equivalient to @'allNullaryToStringTag' = b@+  | OmitNothingFields -- ^ Equivalient to @'omitNothingFields' = True@+  | SumEncodingTaggedObject Symbol Symbol -- ^ Equivalient to @'sumEncoding' = 'TaggedObject' k v@+  | SumEncodingUntaggedValue -- ^ Equivalient to @'sumEncoding' = 'UntaggedValue'@+  | SumEncodingObjectWithSingleField -- ^ Equivalient to @'sumEncoding' = 'ObjectWithSingleField'@+  | SumEncodingTwoElemArray -- ^ Equivalient to @'sumEncoding' = 'TwoElemArray'@+  | UnwrapUnaryRecords -- ^ Equivalient to @'unwrapUnaryRecords' = True@+  | TagSingleConstructors -- ^ Equivalient to @'tagSingleConstructors' = True@++-- | Updates 'Options' given a type-level list of 'AesonOption'.+class ApplyAesonOptions (options :: [AesonOption]) where+  applyAesonOptions :: Proxy options -> Options -> Options++instance ApplyAesonOptions '[] where+  applyAesonOptions _ = id++instance+  ( ApplyAesonOption option+  , ApplyAesonOptions options+  ) => ApplyAesonOptions (option ': options)+  where+  applyAesonOptions _ =+    applyAesonOption (Proxy @option) . (applyAesonOptions (Proxy @options))++-- | Updates 'Options' given a single type-level 'AesonOption'.+class ApplyAesonOption (option :: AesonOption) where+  applyAesonOption :: Proxy option -> Options -> Options++instance ApplyAesonOption ('AllNullaryToStringTag 'True) where+  applyAesonOption _ o = o { allNullaryToStringTag = True }++instance ApplyAesonOption ('AllNullaryToStringTag 'False) where+  applyAesonOption _ o = o { allNullaryToStringTag = False }++instance ApplyAesonOption 'OmitNothingFields where+  applyAesonOption _ o = o { omitNothingFields = True }++instance (KnownSymbol k, KnownSymbol v) => ApplyAesonOption ('SumEncodingTaggedObject k v) where+  applyAesonOption _ o = o { sumEncoding = TaggedObject (symbolVal (Proxy @k)) (symbolVal (Proxy @v)) }++instance ApplyAesonOption 'SumEncodingUntaggedValue where+  applyAesonOption _ o = o { sumEncoding = UntaggedValue }++instance ApplyAesonOption 'SumEncodingObjectWithSingleField where+  applyAesonOption _ o = o { sumEncoding = ObjectWithSingleField }++instance ApplyAesonOption 'SumEncodingTwoElemArray where+  applyAesonOption _ o = o { sumEncoding = TwoElemArray }++instance ApplyAesonOption 'UnwrapUnaryRecords where+  applyAesonOption _ o = o { unwrapUnaryRecords = True }++instance ApplyAesonOption 'TagSingleConstructors where+  applyAesonOption _ o = o { tagSingleConstructors = True }

@@ -1,5 +1,6 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-}@@ -13,17 +14,18 @@ {-# LANGUAGE TypeOperators #-} module Main where -import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON), Result(Success), fromJSON)+import Data.Aeson (FromJSON(parseJSON), Result(Success), ToJSON(toJSON), Value, fromJSON) import Data.Aeson.QQ.Simple (aesonQQ)-import Data.Override (Override(Override), As, With)-import Data.Override.Aeson ()+import Data.Override (Override(Override), As, At, With)+import Data.Override.Aeson (AesonOption(..), WithAesonOptions(..)) import Data.Text (Text) import GHC.Generics (Generic) import LispCaseAeson (LispCase(LispCase))-import qualified Data.Text as Text import Test.Hspec import Text.Read (readMaybe) +import qualified Data.Text as Text+ main :: IO () main = hspec do   describe "Override ToJSON machinery" do@@ -34,6 +36,8 @@     it "Rec5" testRec5     it "Rec6" testRec6     it "Rec7" testRec6+    it "Sum1" testSum1+    it "Options1" testOptions1  newtype Uptext = Uptext { unUptext :: Text } @@ -44,7 +48,6 @@  instance (Show a) => ToJSON (Shown a) where   toJSON = toJSON . show . unShown- instance (Read a) => FromJSON (Shown a) where   parseJSON v = do     s <- parseJSON v@@ -80,8 +83,8 @@  testRec1 :: IO () testRec1 = do-  let r = Rec1 { foo = 12, bar = "hi", baz = "bye" }-  toJSON r `shouldBe` [aesonQQ|+  toJSON Rec1 { foo = 12, bar = "hi", baz = "bye" }+    `shouldBe` [aesonQQ|     {       "foo": "12",       "bar": "hi",@@ -103,8 +106,8 @@  testRec2 :: IO () testRec2 = do-  let r = Rec2 { foo = 12, bar = "hi", baz = "bye" }-  toJSON r `shouldBe` [aesonQQ|+  toJSON Rec2 { foo = 12, bar = "hi", baz = "bye" }+    `shouldBe` [aesonQQ|     {       "foo": 12,       "bar": "HI",@@ -127,8 +130,8 @@  testRec3 :: IO () testRec3 = do-  let r = Rec3 { foo = 12, bar = "hi", baz = "bye" }-  toJSON r `shouldBe` [aesonQQ|+  toJSON Rec3 { foo = 12, bar = "hi", baz = "bye" }+    `shouldBe` [aesonQQ|     {       "foo": "12",       "bar": ["h", "i"],@@ -151,8 +154,8 @@  testRec4 :: IO () testRec4 = do-  let r = Rec4 { foo = "go", bar = "hi", baz = "bye" }-  toJSON r `shouldBe` [aesonQQ|+  toJSON Rec4 { foo = "go", bar = "hi", baz = "bye" }+    `shouldBe` [aesonQQ|     {       "foo": ["g", "o"],       "bar": ["h", "i"],@@ -175,14 +178,14 @@  testRec5 :: IO () testRec5 = do-  let r = Rec5 { fooBar = 1, baz = "hi", quuxSpamEggs = "bye" }-  toJSON r `shouldBe` [aesonQQ|-    {-      "foo-bar": "1",-      "baz": "HI",-      "quux-spam-eggs": ["b", "y", "e"]-    }-  |]+  toJSON Rec5 { fooBar = 1, baz = "hi", quuxSpamEggs = "bye" }+    `shouldBe` [aesonQQ|+      {+        "foo-bar": "1",+        "baz": "HI",+        "quux-spam-eggs": ["b", "y", "e"]+      }+    |]  -- Test 'Override' for both 'ToJSON' and 'FromJSON'. data Rec6 = Rec6@@ -198,16 +201,14 @@  testRec6 :: IO () testRec6 = do-  let r = Rec6 { foo = 1, bar = "hi", baz = "bye" }-  let j = [aesonQQ|-    {-      "foo": "1",-      "bar": ["h", "i"],-      "baz": "bye"-    }-  |]-  toJSON r `shouldBe` j-  fromJSON j `shouldBe` Success r+  Rec6 { foo = 1, bar = "hi", baz = "bye" }+    `shouldRoundtripAs` [aesonQQ|+      {+        "foo": "1",+        "bar": ["h", "i"],+        "baz": "bye"+      }+    |]  -- Test 'Override' for both 'ToJSON' and 'FromJSON'. data Rec7 = Rec7@@ -223,13 +224,94 @@  testRec7 :: IO () testRec7 = do-  let r = Rec7 { foo = 1, bar = "hi", baz = "bye" }-  let j = [aesonQQ|+  Rec7 { foo = 1, bar = "hi", baz = "bye" }+    `shouldRoundtripAs` [aesonQQ|+      {+        "foo": "1",+        "bar": ["h", "i"],+        "baz": "bye"+      }+    |]++newtype Reverse a = Reverse [a]++instance (ToJSON a) => ToJSON (Reverse a) where+  toJSON (Reverse xs) = toJSON $ reverse xs++instance (FromJSON a) => FromJSON (Reverse a) where+  parseJSON = fmap (Reverse . reverse) . parseJSON++newtype Not = Not Bool++instance ToJSON Not where+  toJSON (Not b) = toJSON $ not b++instance FromJSON Not where+  parseJSON = fmap (Not . not) . parseJSON++data Sum1 a =+    Sum1List [a]+  | Sum1Trip a Char Bool+  | Sum1Null+  deriving stock (Show, Eq, Generic)+  deriving (ToJSON, FromJSON)+    via Override (Sum1 a)+          '[ At "Sum1List" 0 (Reverse a)+           , At "Sum1Trip" 2 Not+           ]++testSum1 :: IO ()+testSum1 = do+  Sum1List ['a', 'b'] `shouldRoundtripAs` [aesonQQ|     {-      "foo": "1",-      "bar": ["h", "i"],-      "baz": "bye"+      "tag": "Sum1List",+      "contents": "ba"     }   |]-  toJSON r `shouldBe` j-  fromJSON j `shouldBe` Success r+  Sum1Trip 'a' 'b' True `shouldRoundtripAs` [aesonQQ|+    {+      "tag": "Sum1Trip",+      "contents": ["a", "b", false]+    }+  |]+  Sum1Null @Char `shouldRoundtripAs` [aesonQQ|+    {+      "tag": "Sum1Null"+    }+  |]+++data Options1 =+    Options1A { foo :: Maybe Int, bar :: String }+  | Options1B Options1BBody+  | Options1C+    deriving stock (Eq, Show, Generic)+    deriving (FromJSON, ToJSON)+      via Override Options1+            '[ "foo" `As` Maybe (Shown Int)+             ] `WithAesonOptions`+            '[ 'OmitNothingFields+             , 'SumEncodingTaggedObject "type" "data"+             ]++data Options1BBody = Options1BBody { baz :: Int }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)++testOptions1 :: IO ()+testOptions1 = do+  Options1A { foo = Nothing, bar = "boo" }+    `shouldRoundtripAs` [aesonQQ| { "type": "Options1A", "bar": "boo" } |]+  Options1A { foo = Just 1, bar = "boo" }+    `shouldRoundtripAs` [aesonQQ| { "type": "Options1A", "foo": "1", "bar": "boo" } |]+  Options1B Options1BBody { baz = 2 }+    `shouldRoundtripAs` [aesonQQ| { "type": "Options1B", "data": { "baz": 2 } } |]+  Options1C+    `shouldRoundtripAs` [aesonQQ| { "type": "Options1C" } |]++shouldRoundtripAs+  :: (ToJSON a, FromJSON a, Eq a, Show a, HasCallStack)+  => a -> Value -> IO ()+shouldRoundtripAs x j = do+  toJSON x `shouldBe` j+  fromJSON j `shouldBe` Success x