From 051ffc10e27d3983f0bd4e7f997add38b958a588 Mon Sep 17 00:00:00 2001 From: Giorgio Marinelli Date: Fri, 24 Apr 2026 13:57:49 +0200 Subject: [PATCH 1/6] Add untagged and generics derivations --- .github/workflows/haskell-ci.yml | 10 +- cabal.haskell-ci | 9 +- example/DerivingViaInstances.hs | 19 +- example/GenericInstances.hs | 44 +- fourmolu.yaml | 88 ++++ src/Deriving/TaggedJson.hs | 693 ++++++++++++++++++++++--------- tagged-json.cabal | 2 +- test/Main.hs | 121 +++++- test/TestTaggedJson.hs | 40 +- 9 files changed, 760 insertions(+), 266 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index e957050..909dd81 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,9 +8,9 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.19.20260209 +# version: 0.19.20260331 # -# REGENDATA ("0.19.20260209",["github","--config=cabal.haskell-ci","tagged-json.cabal"]) +# REGENDATA ("0.19.20260331",["github","--config=cabal.haskell-ci","tagged-json.cabal"]) # name: Haskell-CI on: @@ -37,9 +37,9 @@ jobs: strategy: matrix: include: - - compiler: ghc-9.12.2 + - compiler: ghc-9.12.4 compilerKind: ghc - compilerVersion: 9.12.2 + compilerVersion: 9.12.4 setup-method: ghcup allow-failure: false - compiler: ghc-9.10.3 @@ -183,8 +183,6 @@ jobs: echo "packages: ${PKGDIR_tagged_json}" >> cabal.project echo "package tagged-json" >> cabal.project echo " ghc-options: -Werror=missing-methods -Werror=missing-fields" >> cabal.project - if [ $((HCNUMVER >= 90400)) -ne 0 ] ; then echo "package tagged-json" >> cabal.project ; fi - if [ $((HCNUMVER >= 90400)) -ne 0 ] ; then echo " ghc-options: -Werror=unused-packages" >> cabal.project ; fi echo "package tagged-json" >> cabal.project echo " ghc-options: -Werror=incomplete-patterns -Werror=incomplete-uni-patterns" >> cabal.project cat >> cabal.project < TaggedOptions exampleTaggedOptions prefix = @@ -27,14 +27,5 @@ exampleTaggedOptions prefix = where snakeCase = camelTo2 '_' -instance (KnownSymbol prefix, KnownSymbol tagKey) => HasTaggedOptions (Opts prefix ('Just tagKey)) where - taggedOptions = - (exampleTaggedOptions (symbolVal $ Proxy @prefix)) - { tagKey = Just (fromString . symbolVal $ Proxy @tagKey) - } - -instance (KnownSymbol prefix) => HasTaggedOptions (Opts prefix 'Nothing) where - taggedOptions = - (exampleTaggedOptions (symbolVal $ Proxy @prefix)) - { tagKey = Nothing - } +instance (KnownSymbol prefix) => HasTaggedOptions (Opts prefix) where + taggedOptions = exampleTaggedOptions (symbolVal $ Proxy @prefix) diff --git a/example/GenericInstances.hs b/example/GenericInstances.hs index fe5af22..3b43fc1 100644 --- a/example/GenericInstances.hs +++ b/example/GenericInstances.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} module GenericInstances (genericInstances) where @@ -11,11 +12,10 @@ import Data.List (stripPrefix) import Data.Maybe (fromJust) import Deriving.TaggedJson -options :: String -> Maybe Key -> TaggedOptions -options prefix tagKey = +options :: String -> TaggedOptions +options prefix = defaultTaggedOptions - { tagKey = tagKey - , fieldLabelModifier = snakeCase . fromJust . stripPrefix prefix + { fieldLabelModifier = snakeCase . fromJust . stripPrefix prefix , constructorTagModifier = snakeCase . fromJust . stripPrefix prefix , datatypeNameModifier = snakeCase , omitNothingFields = True @@ -29,36 +29,40 @@ data Command | Turn Turn deriving (Eq, Show, Generic) +type TaggedCommand = GTaggedJSON "command" TaggedOptions + instance ToKeyMap Command where - toSeries = genericToSeries (options "" (Just "command")) - toPairs = genericToPairs (options "" (Just "command")) + toSeries = genericToSeries @TaggedCommand (options "") + toPairs = genericToPairs @TaggedCommand (options "") instance ToJSON Command where - toJSON = genericToJSON (options "" (Just "command")) + toJSON = genericToJSON @TaggedCommand (options "") instance FromJSON Command where - parseJSON = genericParseJSON (options "" (Just "command")) + parseJSON = genericParseJSON @TaggedCommand (options "") instance ToSchema Command where - declareNamedSchema = genericDeclareNamedSchema (options "" (Just "command")) + declareNamedSchema = genericDeclareNamedSchema @TaggedCommand (options "") instance SchemaDetails Command newtype Distance = MkDistance {distance :: Maybe Int} deriving (Eq, Show, Generic) +type UntaggedDistance = GUntaggedJSON TaggedOptions + instance ToKeyMap Distance where - toSeries = genericToSeries (options "" Nothing) - toPairs = genericToPairs (options "" Nothing) + toSeries = genericToSeries @UntaggedDistance (options "") + toPairs = genericToPairs @UntaggedDistance (options "") instance ToJSON Distance where - toJSON = genericToJSON (options "" Nothing) + toJSON = genericToJSON @UntaggedDistance (options "") instance FromJSON Distance where - parseJSON = genericParseJSON (options "" Nothing) + parseJSON = genericParseJSON @UntaggedDistance (options "") instance ToSchema Distance where - declareNamedSchema = genericDeclareNamedSchema (options "" Nothing) + declareNamedSchema = genericDeclareNamedSchema @UntaggedDistance (options "") instance SchemaDetails Distance @@ -68,18 +72,20 @@ data Turn | TurnBack deriving (Eq, Show, Generic) +type TaggedTurn = GTaggedJSON "direction" TaggedOptions + instance ToKeyMap Turn where - toSeries = genericToSeries (options "Turn" (Just "direction")) - toPairs = genericToPairs (options "Turn" (Just "direction")) + toSeries = genericToSeries @TaggedTurn (options "Turn") + toPairs = genericToPairs @TaggedTurn (options "Turn") instance ToJSON Turn where - toJSON = genericToJSON (options "Turn" (Just "direction")) + toJSON = genericToJSON @TaggedTurn (options "Turn") instance FromJSON Turn where - parseJSON = genericParseJSON (options "Turn" (Just "direction")) + parseJSON = genericParseJSON @TaggedTurn (options "Turn") instance ToSchema Turn where - declareNamedSchema = genericDeclareNamedSchema (options "Turn" (Just "direction")) + declareNamedSchema = genericDeclareNamedSchema @TaggedTurn (options "Turn") instance SchemaDetails Turn diff --git a/fourmolu.yaml b/fourmolu.yaml index 47e652d..f820abb 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -1 +1,89 @@ +# Number of spaces per indentation step indentation: 2 + +# Max line length for automatic line breaking +column-limit: none + +# Styling of arrows in type signatures (choices: trailing, leading, or leading-args) +function-arrows: trailing + +# How to place commas in multi-line lists, records, etc. (choices: leading or trailing) +comma-style: leading + +# Styling of import/export lists (choices: leading, trailing, or diff-friendly) +import-export-style: diff-friendly + +# Rules for grouping import declarations +import-grouping: legacy + +# Whether to full-indent or half-indent 'where' bindings past the preceding body +indent-wheres: false + +# Whether to leave a space before an opening record brace +record-brace-space: true + +# Number of spaces between top-level declarations +newlines-between-decls: 1 + +# How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) +haddock-style: multi-line + +# How to print module docstring +haddock-style-module: null + +# Where to put docstring comments in function signatures (choices: auto, leading, or trailing) +haddock-location-signature: auto + +# Styling of let blocks (choices: auto, inline, newline, or mixed) +let-style: auto + +# How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) +in-style: right-align + +# Styling of if-statements (choices: indented or hanging) +if-style: indented + +# Whether to put parentheses around a single constraint (choices: auto, always, or never) +single-constraint-parens: always + +# Whether to put parentheses around a single deriving class (choices: auto, always, or never) +single-deriving-parens: always + +# Whether to sort constraints +sort-constraints: false + +# Whether to sort derived classes +sort-derived-classes: false + +# Whether to sort deriving clauses +sort-deriving-clauses: false + +# Whether to place section operators (those that are infixr 0, such as $) in trailing position, continuing the expression indented below +trailing-section-operators: true + +# Output Unicode syntax (choices: detect, always, or never) +unicode: never + +# Give the programmer more choice on where to insert blank lines +respectful: true + +# Fixity information for operators +fixities: [] + +# Module reexports Fourmolu should know about +reexports: + - module Prelude exports "base" Control.Applicative + - module Prelude exports "base" Control.Monad + - module Prelude exports "base" Data.Bool + - module Prelude exports "base" Data.Eq + - module Prelude exports "base" Data.Function + - module Prelude exports "base" Data.Functor + - module Prelude exports "base" Data.List + - module Prelude exports "base" Data.Ord + - module Prelude exports "base" GHC.Base + - module Prelude exports "base" GHC.Num + - module Prelude exports "base" GHC.Real + - module Prelude exports "optics-core" Optics.Operators + +# Modules defined by the current Cabal package for import grouping +local-modules: [] diff --git a/src/Deriving/TaggedJson.hs b/src/Deriving/TaggedJson.hs index e7e8475..cabce14 100644 --- a/src/Deriving/TaggedJson.hs +++ b/src/Deriving/TaggedJson.hs @@ -1,8 +1,12 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} module Deriving.TaggedJson ( GTaggedJSON (..), - ToKeyMap (toSeries, toPairs), + GUntaggedJSON (..), + GTaggedJSON1 (..), + GUntaggedJSON1 (..), + ToKeyMap (toPairs, toSeries), SchemaDetails (..), HasTaggedOptions (..), TaggedOptions (..), @@ -10,9 +14,14 @@ module Deriving.TaggedJson ( genericParseJSON, genericToJSON, genericToEncoding, - genericToSeries, genericToPairs, + genericToSeries, genericDeclareNamedSchema, + genericLiftToPairs, + genericLiftToSeries, + genericLiftToJSON, + genericLiftToEncoding, + genericLiftDeclareNamedSchema, -- re-export some Data.Aeson.Key definitions Key, Key.fromString, @@ -22,8 +31,8 @@ where import Control.Applicative import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap -import Data.Aeson.Types hiding (genericParseJSON, genericToEncoding, genericToJSON) -import Data.HashMap.Strict.InsOrd qualified as HMSI +import Data.Aeson.Types hiding (genericLiftToEncoding, genericLiftToJSON, genericParseJSON, genericToEncoding, genericToJSON) +import Data.Coerce import Data.Kind import Data.List (intercalate) import Data.Maybe @@ -37,12 +46,21 @@ import GHC.Generics import GHC.TypeLits import Optics hiding (to) +-- This is due to a breaking change introduced in insert-ordered-containers-0.3.0 +-- More info are available here: +-- https://github.com/biocad/openapi3/pull/119 +-- https://github.com/erikd/insert-ordered-containers/pull/8 +-- +#if !MIN_VERSION_openapi3(3,2,5) +import Data.HashMap.Strict.InsOrd qualified as HMSI +#else +import Data.HashMap.Strict.InsOrd.Compat qualified as HMSI +#endif + -- * Serialization options data TaggedOptions = TaggedOptions - { tagKey :: Maybe Key - -- ^ no tag is needed for product types - , fieldLabelModifier :: String -> String + { fieldLabelModifier :: String -> String , constructorTagModifier :: String -> String , datatypeNameModifier :: String -> String , omitNothingFields :: Bool @@ -54,8 +72,7 @@ data TaggedOptions = TaggedOptions defaultTaggedOptions :: TaggedOptions defaultTaggedOptions = TaggedOptions - { tagKey = Nothing - , fieldLabelModifier = id + { fieldLabelModifier = id , constructorTagModifier = id , datatypeNameModifier = id , omitNothingFields = False @@ -65,22 +82,23 @@ defaultTaggedOptions = class HasTaggedOptions a where taggedOptions :: TaggedOptions -{- | Newtype used for deriving the following classes: - - - `ToJSON`, `FromJSON`, `ToSchema`, `ToKeyMap` +-- * Newtypes -Deriving these classes results in a flat tagged representation -of the data type. - -The parameter `prefix` is the prefix that is stripped from the record names -and constructor names while serializing and deserializing. +{- | Newtype for deriving 'ToJSON', 'FromJSON', 'ToSchema', 'ToKeyMap' +with a tagged (discriminated) representation. +-} +newtype GTaggedJSON (key :: Symbol) opts a = GTaggedJSON {unwrap :: a} -All record names are converted to snake_case before serialization. +-- | Like 'GTaggedJSON' but uses 'Generic1' instead of 'Generic'. +newtype GTaggedJSON1 (key :: Symbol) opts f a = GTaggedJSON1 {unwrap :: f a} -For usage examples, see the tests. -@ +{- | Newtype for deriving 'ToJSON', 'FromJSON', 'ToSchema', 'ToKeyMap' +without a tag field. -} -newtype GTaggedJSON opts a = GTaggedJSON {unGTaggedJSON :: a} +newtype GUntaggedJSON opts a = GUntaggedJSON {unwrap :: a} + +-- | Like 'GUntaggedJSON' but uses 'Generic1' instead of 'Generic'. +newtype GUntaggedJSON1 opts f a = GUntaggedJSON1 {unwrap :: f a} -- * ToJSON deriving @@ -96,169 +114,342 @@ to the map, which would not always be possible with Aeson.Value. `ToKeyMap` Can be automatically derived via `GTaggedJSON`. -} class ToKeyMap a where - toSeries :: a -> Series toPairs :: a -> [Pair] + toSeries :: a -> Series + +-- GTaggedJSON instances -instance (ToKeyMap (GTaggedJSON opts a)) => ToJSON (GTaggedJSON opts a) where +instance (style ~ GTaggedJSON key opts, HasTaggedOptions opts, Generic a, GSerializeRecords style Pair (Rep a), GSerializeRecords style Series (Rep a)) => ToKeyMap (GTaggedJSON key opts a) where + toPairs = genericToPairs @style (taggedOptions @opts) . (.unwrap) + toSeries = genericToSeries @style (taggedOptions @opts) . (.unwrap) + +instance (ToKeyMap (GTaggedJSON key opts a)) => ToJSON (GTaggedJSON key opts a) where toJSON = object . toPairs toEncoding = pairs . toSeries -genericToJSON :: (GSerializeRecords Pair (Rep a), Generic a) => TaggedOptions -> a -> Value -genericToJSON opts = object . genericToPairs opts +-- GUntaggedJSON instances + +instance (style ~ GUntaggedJSON opts, HasTaggedOptions opts, Generic a, GSerializeRecords style Pair (Rep a), GSerializeRecords style Series (Rep a)) => ToKeyMap (GUntaggedJSON opts a) where + toPairs = genericToPairs @style (taggedOptions @opts) . (.unwrap) + toSeries = genericToSeries @style (taggedOptions @opts) . (.unwrap) + +instance (ToKeyMap (GUntaggedJSON opts a)) => ToJSON (GUntaggedJSON opts a) where + toJSON = object . toPairs + toEncoding = pairs . toSeries + +-- GTaggedJSON1 instances + +instance (style ~ GTaggedJSON1 key opts f, HasTaggedOptions opts, Generic1 f, ToJSON a, GSerializeRecords style Pair (Rep1 f), GSerializeRecords style Series (Rep1 f)) => ToKeyMap (GTaggedJSON1 key opts f a) where + toPairs = genericLiftToPairs @style (taggedOptions @opts) . (.unwrap) + toSeries = genericLiftToSeries @style (taggedOptions @opts) . (.unwrap) + +instance (ToKeyMap (GTaggedJSON1 key opts f a)) => ToJSON (GTaggedJSON1 key opts f a) where + toJSON = object . toPairs + toEncoding = pairs . toSeries + +-- GUntaggedJSON1 instances + +instance (ToKeyMap (GUntaggedJSON1 opts f a)) => ToJSON (GUntaggedJSON1 opts f a) where + toJSON = object . toPairs + toEncoding = pairs . toSeries + +instance (style ~ GUntaggedJSON1 opts f, HasTaggedOptions opts, Generic1 f, ToJSON a, GSerializeRecords style Pair (Rep1 f), GSerializeRecords style Series (Rep1 f)) => ToKeyMap (GUntaggedJSON1 opts f a) where + toPairs = genericLiftToPairs @style (taggedOptions @opts) . (.unwrap) + toSeries = genericLiftToSeries @style (taggedOptions @opts) . (.unwrap) + +genericToPairs :: forall style a. (GSerializeRecords style Pair (Rep a), Generic a) => TaggedOptions -> a -> [Pair] +genericToPairs opts = gSerializeRecords @style @Pair opts . from @a @GTaggedJSONParam + +genericToSeries :: forall style a. (GSerializeRecords style Series (Rep a), Generic a) => TaggedOptions -> a -> Series +genericToSeries opts = gSerializeRecords @style @Series opts . from @a @GTaggedJSONParam + +genericToJSON :: forall style a. (GSerializeRecords style Pair (Rep a), Generic a) => TaggedOptions -> a -> Value +genericToJSON opts = object . genericToPairs @style @a opts + +genericToEncoding :: forall style a. (GSerializeRecords style Series (Rep a), Generic a) => TaggedOptions -> a -> Encoding +genericToEncoding opts = pairs . genericToSeries @style @a opts -genericToEncoding :: (GSerializeRecords Series (Rep a), Generic a) => TaggedOptions -> a -> Encoding -genericToEncoding opts = pairs . genericToSeries opts +genericLiftToPairs :: forall style f a. (GSerializeRecords style Pair (Rep1 f), Generic1 f, ToJSON a) => TaggedOptions -> f a -> [Pair] +genericLiftToPairs opts = gSerializeRecords @style @Pair opts . from1 -instance (Generic a, GSerializeRecords Pair (Rep a), GSerializeRecords Series (Rep a), HasTaggedOptions opts) => ToKeyMap (GTaggedJSON opts a) where - toSeries = genericToSeries (taggedOptions @opts) . (.unGTaggedJSON) - toPairs = genericToPairs (taggedOptions @opts) . (.unGTaggedJSON) +genericLiftToSeries :: forall style f a. (GSerializeRecords style Series (Rep1 f), Generic1 f, ToJSON a) => TaggedOptions -> f a -> Series +genericLiftToSeries opts = gSerializeRecords @style @Series opts . from1 -genericToSeries :: (GSerializeRecords Series (Rep a), Generic a) => TaggedOptions -> a -> Series -genericToSeries opts = gSerializeRecords @Series opts . from +genericLiftToJSON :: forall style f a. (GSerializeRecords style Pair (Rep1 f), Generic1 f, ToJSON a) => TaggedOptions -> f a -> Value +genericLiftToJSON opts = object . genericLiftToPairs @style @f @a opts -genericToPairs :: (GSerializeRecords Pair (Rep a), Generic a) => TaggedOptions -> a -> [Pair] -genericToPairs opts = gSerializeRecords @Pair opts . from +genericLiftToEncoding :: forall style f a. (GSerializeRecords style Series (Rep1 f), Generic1 f, ToJSON a) => TaggedOptions -> f a -> Encoding +genericLiftToEncoding opts = pairs . genericLiftToSeries @style @f @a opts -{- | Class responsible for serializing the Generic type into a key-value map -that is then used to build the final object by `ToJSON`. +{- | Class responsible for serializing the Generic/Generic1 type into a key-value +map used to build the final object by `ToJSON`. + +The method-level `ToJSON a` constraint is consumed by the `Par1` and +`Rec1 Maybe` leaf instances (Generic1 only). It is satisfied but unused +for the `Generic` path, where the phantom type is instantiated to +`GTaggedJSONParam`. -} -class GSerializeRecords serialization (f :: Type -> Type) where - gSerializeRecords :: TaggedOptions -> f a -> SerializationType serialization +class GSerializeRecords style serialization (f :: Type -> Type) where + gSerializeRecords :: (ToJSON a) => TaggedOptions -> f a -> SerializationType serialization -- | Sum type, with tags -instance (GSerializeRecords s a) => GSerializeRecords s (D1 m a) where - gSerializeRecords opts (M1 c) = gSerializeRecords @s opts c +instance (GSerializeRecords style s a) => GSerializeRecords style s (D1 m a) where + gSerializeRecords opts (M1 c) = gSerializeRecords @style @s opts c --- | Sum type constructor -instance (Monoid (SerializationType s), SerializationKind s, Constructor m, GSerializeRecords s a) => GSerializeRecords s (C1 m a) where - gSerializeRecords opts c = tagged <> gSerializeRecords @s opts (unM1 c) - where - tagged :: SerializationType s - tagged = case opts.tagKey of - Nothing -> mempty - Just key -> mkPair @s key (T.pack $ constructorName @m opts) +-- | Sum type constructor - GTaggedJSON variant: emits the discriminator field. +instance (style ~ GTaggedJSON key opts, Monoid (SerializationType s), SerializationKind s, Constructor m, GSerializeRecords style s a, KnownSymbol key) => GSerializeRecords (GTaggedJSON key opts) s (C1 m a) where + gSerializeRecords opts c = mkTagPair @key @s @m opts <> gSerializeRecords @style @s opts (unM1 c) + +-- | Sum type constructor - GTaggedJSON1 variant: emits the discriminator field. +instance (style ~ GTaggedJSON1 key opts f, Monoid (SerializationType s), SerializationKind s, Constructor m, GSerializeRecords style s a, KnownSymbol key) => GSerializeRecords (GTaggedJSON1 key opts f) s (C1 m a) where + gSerializeRecords opts c = mkTagPair @key @s @m opts <> gSerializeRecords @style @s opts (unM1 c) + +-- | Sum type constructor - GUntaggedJSON variant: no discriminator field. +instance (style ~ GUntaggedJSON opts, GSerializeRecords style s a) => GSerializeRecords (GUntaggedJSON opts) s (C1 m a) where + gSerializeRecords opts c = gSerializeRecords @style @s opts (unM1 c) -instance (GSerializeRecords s a, GSerializeRecords s b) => GSerializeRecords s (a :+: b) where +-- | Sum type constructor - GUntaggedJSON1 variant: no discriminator field. +instance (style ~ GUntaggedJSON1 opts f, GSerializeRecords style s a) => GSerializeRecords (GUntaggedJSON1 opts f) s (C1 m a) where + gSerializeRecords opts c = gSerializeRecords @style @s opts (unM1 c) + +instance (style ~ GTaggedJSON key opts, GSerializeRecords style s a, GSerializeRecords style s b) => GSerializeRecords (GTaggedJSON key opts) s (a :+: b) where + gSerializeRecords opts = \case + L1 x -> gSerializeRecords @style @s opts x + R1 x -> gSerializeRecords @style @s opts x + +instance (style ~ GTaggedJSON1 key opts f, GSerializeRecords style s a, GSerializeRecords style s b) => GSerializeRecords (GTaggedJSON1 key opts f) s (a :+: b) where gSerializeRecords opts = \case - L1 x -> gSerializeRecords @s opts x - R1 x -> gSerializeRecords @s opts x + L1 x -> gSerializeRecords @style @s opts x + R1 x -> gSerializeRecords @style @s opts x + +instance (Monoid (SerializationType s), GSerializeRecords style s a, GSerializeRecords style s b) => GSerializeRecords style s (a :*: b) where + gSerializeRecords opts (a :*: b) = gSerializeRecords @style @s opts a <> gSerializeRecords @style @s opts b -instance (Semigroup (SerializationType s), GSerializeRecords s a, GSerializeRecords s b) => GSerializeRecords s (a :*: b) where - gSerializeRecords opts (a :*: b) = gSerializeRecords @s opts a <> gSerializeRecords @s opts b +instance (Monoid (SerializationType s)) => GSerializeRecords style s U1 where + gSerializeRecords _options U1 = mempty -instance (Monoid (SerializationType s)) => GSerializeRecords s U1 where - gSerializeRecords _opts U1 = mempty +-- Rec0 (concrete field) instances -- -instance (SerializationKind s, ToKeyMap a) => GSerializeRecords s (S1 ('MetaSel 'Nothing u s' d) (Rec0 a)) where - gSerializeRecords _opts (M1 (K1 x)) = mkPairs @s x +instance (SerializationKind s, ToKeyMap a) => GSerializeRecords style s (S1 ('MetaSel 'Nothing u s' d) (Rec0 a)) where + gSerializeRecords _options (M1 (K1 x)) = mkPairs @s x -instance (SerializationKind s, KnownSymbol selectorName, ToJSON a) => GSerializeRecords s (S1 ('MetaSel ('Just selectorName) u s' d) (Rec0 a)) where +instance (SerializationKind s, KnownSymbol selectorName, ToJSON a) => GSerializeRecords style s (S1 ('MetaSel ('Just selectorName) u s' d) (Rec0 a)) where gSerializeRecords opts selector = mkPair @s selectorKey selectorVal where selectorKey :: Key - selectorKey = Key.fromString . opts.fieldLabelModifier $ symbolVal (Proxy @selectorName) + selectorKey = fieldKey @selectorName opts selectorVal :: a selectorVal = unK1 (unM1 selector) -instance {-# OVERLAPPING #-} (SerializationKind s, KnownSymbol selectorName, ToJSON a, Monoid (SerializationType s)) => GSerializeRecords s (S1 ('MetaSel ('Just selectorName) u s' d) (Rec0 (Maybe a))) where +instance {-# OVERLAPPING #-} (SerializationKind s, KnownSymbol selectorName, ToJSON a, Monoid (SerializationType s)) => GSerializeRecords style s (S1 ('MetaSel ('Just selectorName) u s' d) (Rec0 (Maybe a))) where gSerializeRecords opts selector = if opts.omitNothingFields && isNothing selectorVal then mempty else mkPair @s selectorKey selectorVal where selectorKey :: Key - selectorKey = Key.fromString . opts.fieldLabelModifier $ symbolVal (Proxy @selectorName) + selectorKey = fieldKey @selectorName opts selectorVal :: Maybe a selectorVal = unK1 (unM1 selector) +{- | For `Par1` instances (Generic1 only). + +NB: selector-less Par1 (i.e. 'newtype T a = T a') is not supported, +as it's hazy what this means in a tagged/untagged context. The whole point of +having `Generic1` is to support unary wrappers around polymorphic payloads. +Use a named field ('newtype W a = W { inner :: a }') instead. +-} +type Generic1WithoutSelectorErrorMessage = + 'Text "TaggedJSON: Generic1 instances require a selector field to differentiate contents." + +instance (TypeError Generic1WithoutSelectorErrorMessage) => GSerializeRecords style s (S1 ('MetaSel Nothing u s' d) Par1) where + gSerializeRecords :: TaggedOptions -> S1 ('MetaSel Nothing u s' d) Par1 a -> SerializationType s + gSerializeRecords _options = generic1NoSelectorError + +instance (SerializationKind s, KnownSymbol selectorName) => GSerializeRecords style s (S1 ('MetaSel ('Just selectorName) u s' d) Par1) where + gSerializeRecords :: forall a. (ToJSON a) => TaggedOptions -> S1 ('MetaSel ('Just selectorName) u s' d) Par1 a -> SerializationType s + gSerializeRecords opts selector = mkPair @s selectorKey selectorVal + where + selectorKey :: Key + selectorKey = fieldKey @selectorName opts + selectorVal :: a + selectorVal = unPar1 (unM1 selector) + +{- | 'Rec1 Maybe' is handled specifically so that 'omitNothingFields' applies to +fields of type 'Maybe a' (the type parameter). +-} +instance {-# OVERLAPPING #-} (SerializationKind s, KnownSymbol selectorName, Monoid (SerializationType s)) => GSerializeRecords style s (S1 ('MetaSel ('Just selectorName) u s' d) (Rec1 Maybe)) where + gSerializeRecords :: forall a. (ToJSON a) => TaggedOptions -> S1 ('MetaSel ('Just selectorName) u s' d) (Rec1 Maybe) a -> SerializationType s + gSerializeRecords opts selector = + if opts.omitNothingFields && isNothing selectorVal + then mempty + else mkPair @s selectorKey selectorVal + where + selectorKey :: Key + selectorKey = fieldKey @selectorName opts + selectorVal :: Maybe a + selectorVal = unRec1 (unM1 selector) + -- * FromJSON deriving {- | Automatic deriving of `FromJSON` via `GTaggedJSON`. `FromJSON` must be present for all sum constructor arguments. -} -instance (Generic a, HasTaggedOptions opts, GParseRecords (Rep a)) => FromJSON (GTaggedJSON opts a) where - parseJSON = fmap GTaggedJSON . genericParseJSON (taggedOptions @opts) - -genericParseJSON :: (Generic a, GParseRecords (Rep a)) => TaggedOptions -> Value -> Parser a -genericParseJSON opts = withObject "Object" $ \obj -> +genericParseJSON :: forall style a. (Generic a, GParseRecords style (Rep a)) => TaggedOptions -> Value -> Parser a +genericParseJSON opts = withObject "Object" $ \jsonObject -> to <$> do - let context = ParsingContext opts Nothing obj - case gParseRecords context of - Just a -> a - Nothing -> error "unreachable" -- TODO: error in a different way? + let context = ParsingContext {expectedTagValue = Nothing, jsonObject} + case gParseRecords @style @(Rep a) @GTaggedJSONParam opts context of + Just parser -> parser + Nothing -> error "unreachable" + +instance (Generic a, HasTaggedOptions opts, GParseRecords (GTaggedJSON key opts) (Rep a)) => FromJSON (GTaggedJSON key opts a) where + parseJSON = coerce (genericParseJSON @(GTaggedJSON key opts) (taggedOptions @opts) :: Value -> Parser a) + +instance (Generic a, HasTaggedOptions opts, GParseRecords (GUntaggedJSON opts) (Rep a)) => FromJSON (GUntaggedJSON opts a) where + parseJSON = coerce (genericParseJSON @(GUntaggedJSON opts) (taggedOptions @opts) :: Value -> Parser a) -- | Values that must be passed along when traversing the generic tree data ParsingContext = ParsingContext - { opts :: TaggedOptions - , expectedTagValue :: Maybe String - , obj :: Object + { expectedTagValue :: Maybe String + , jsonObject :: Object } --- | Generically parse JSON -class GParseRecords (f :: Type -> Type) where - gParseRecords :: ParsingContext -> Maybe (Parser (f a)) +-- | Generically parse JSON. +class GParseRecords style (f :: Type -> Type) where + gParseRecords :: (FromJSON a) => TaggedOptions -> ParsingContext -> Maybe (Parser (f a)) + +unsafeTaggedParser :: forall style (key :: Symbol) (f :: Type -> Type) a. (GParseRecords style f, KnownSymbol key, FromJSON a, GetConstructorNames f) => TaggedOptions -> ParsingContext -> Parser (f a) +unsafeTaggedParser opts context = do + let tagKey = mkTagKey @key + tagVal <- context.jsonObject .:? tagKey + case gParseRecords @style @f opts (context {expectedTagValue = tagVal}) of + Just parser -> parser + Nothing -> + fail $ + "encountered tag " + <> show (Key.toString tagKey) + <> " with value " + <> show' tagVal + <> "; expected one of: " + <> intercalate ", " (show . opts.constructorTagModifier <$> getConstructorNames @f) + where + -- TODO: Improve error message + show' :: Maybe String -> String + show' = \case Nothing -> "Nothing"; Just k -> show k + +-- | Sum type, with tags - GTaggedJSON variant +instance (style ~ GTaggedJSON key opts, GParseRecords style a, GetConstructorNames a, KnownSymbol key) => GParseRecords (GTaggedJSON key opts) (D1 m a) where + gParseRecords opts context = Just . fmap M1 $ unsafeTaggedParser @style @key @a opts context + +-- | Sum type, with tags - GTaggedJSON1 variant +instance (style ~ GTaggedJSON1 key opts f, GParseRecords style a, GetConstructorNames a, KnownSymbol key) => GParseRecords (GTaggedJSON1 key opts f) (D1 m a) where + gParseRecords opts context = Just . fmap M1 $ unsafeTaggedParser @style @key @a opts context + +unsafeUntaggedParser :: forall style (f :: Type -> Type) a. (GParseRecords style f, FromJSON a) => TaggedOptions -> ParsingContext -> Parser (f a) +unsafeUntaggedParser opts context = case gParseRecords @style @f opts context of + Just parser -> parser + Nothing -> error "unreachable" + +-- | Untagged variant - passes through without looking up a tag field (GUntaggedJSON) +instance (style ~ GUntaggedJSON opts, GParseRecords style a) => GParseRecords (GUntaggedJSON opts) (D1 m a) where + gParseRecords opts context = Just . fmap M1 $ unsafeUntaggedParser @style @a opts context + +-- | Untagged variant - passes through without looking up a tag field (GUntaggedJSON1) +instance (style ~ GUntaggedJSON1 opts f, GParseRecords style a) => GParseRecords (GUntaggedJSON1 opts f) (D1 m a) where + gParseRecords opts context = Just . fmap M1 $ unsafeUntaggedParser @style @a opts context + +-- | Sum type constructor - GTaggedJSON variant +instance (style ~ GTaggedJSON key opts, Constructor m, GParseRecords style a) => GParseRecords (GTaggedJSON key opts) (C1 m a) where + gParseRecords opts context = + if context.expectedTagValue == Just (constructorName @m opts) + then fmap M1 <$> gParseRecords @style @a opts context + else Nothing --- | Sum type, with tags -instance (GParseRecords a, GetConstructorNames a) => GParseRecords (D1 m a) where - gParseRecords ctx = Just $ do - tagVal <- case ctx.opts.tagKey of - Nothing -> pure Nothing - Just k -> ctx.obj .:? k - case gParseRecords @a ctx{expectedTagValue = tagVal} of - Just a -> M1 <$> a - Nothing -> - fail $ - "encountered tag " - <> show' (T.unpack . Key.toText <$> ctx.opts.tagKey) - <> " with value " - <> show' tagVal - <> "; expected one of: " - <> intercalate ", " (show . ctx.opts.constructorTagModifier <$> getConstructorNames @a) - where - -- TODO: Improve error message - show' :: Maybe String -> String - show' = \case Nothing -> "Nothing"; Just k -> show k - --- | Sum type constructor -instance (Constructor m, GParseRecords a) => GParseRecords (C1 m a) where - gParseRecords ctx = - if ctx.expectedTagValue == Just (constructorName @m ctx.opts) || isNothing ctx.opts.tagKey - then fmap M1 <$> gParseRecords @a ctx +-- | Sum type constructor - GTaggedJSON1 variant +instance (style ~ GTaggedJSON1 key opts f, Constructor m, GParseRecords style a) => GParseRecords (GTaggedJSON1 key opts f) (C1 m a) where + gParseRecords opts context = + if context.expectedTagValue == Just (constructorName @m opts) + then fmap M1 <$> gParseRecords @style @a opts context else Nothing -instance (GParseRecords a, GParseRecords b) => GParseRecords (a :+: b) where - gParseRecords ctx = - (fmap L1 <$> gParseRecords @a ctx) <|> (fmap R1 <$> gParseRecords @b ctx) +-- | Sum type constructor - GUntaggedJSON variant: always matches +instance (style ~ GUntaggedJSON opts, GParseRecords style a) => GParseRecords (GUntaggedJSON opts) (C1 m a) where + gParseRecords opts context = fmap M1 <$> gParseRecords @style @a opts context + +-- | Sum type constructor - GUntaggedJSON1 variant: always matches +instance (style ~ GUntaggedJSON1 opts f, GParseRecords style a) => GParseRecords (GUntaggedJSON1 opts f) (C1 m a) where + gParseRecords opts context = fmap M1 <$> gParseRecords @style @a opts context + +instance (style ~ GTaggedJSON key opts, GParseRecords style a, GParseRecords style b) => GParseRecords (GTaggedJSON key opts) (a :+: b) where + gParseRecords opts context = + (fmap L1 <$> gParseRecords @style @a opts context) <|> (fmap R1 <$> gParseRecords @style @b opts context) -instance (GParseRecords a, GParseRecords b) => GParseRecords (a :*: b) where - gParseRecords ctx = do - x <- gParseRecords ctx - y <- gParseRecords ctx +instance (style ~ GTaggedJSON1 key opts f, GParseRecords style a, GParseRecords style b) => GParseRecords (GTaggedJSON1 key opts f) (a :+: b) where + gParseRecords opts context = + (fmap L1 <$> gParseRecords @style @a opts context) <|> (fmap R1 <$> gParseRecords @style @b opts context) + +instance (GParseRecords style a, GParseRecords style b) => GParseRecords style (a :*: b) where + gParseRecords opts context = do + x <- gParseRecords @style opts context + y <- gParseRecords @style opts context pure $ (:*:) <$> x <*> y -instance GParseRecords U1 where - gParseRecords _ = pure $ pure U1 +instance GParseRecords style U1 where + gParseRecords _options _context = pure $ pure U1 + +-- Rec0 (concrete field) instances -- -instance (FromJSON a) => GParseRecords (S1 ('MetaSel 'Nothing u s' d) (Rec0 a)) where - gParseRecords ctx = Just $ M1 . K1 <$> parseJSON @a (Object ctx.obj) +instance (FromJSON a) => GParseRecords style (S1 ('MetaSel 'Nothing u s' d) (Rec0 a)) where + gParseRecords _options context = Just $ M1 . K1 <$> parseJSON (Object context.jsonObject) -instance {-# OVERLAPPING #-} (KnownSymbol selectorName, FromJSON a) => GParseRecords (S1 ('MetaSel ('Just selectorName) u s' d) (Rec0 (Maybe a))) where - gParseRecords ctx = Just $ M1 . K1 <$> ctx.obj .:? selectorKey +instance {-# OVERLAPPING #-} (KnownSymbol selectorName, FromJSON a) => GParseRecords style (S1 ('MetaSel ('Just selectorName) u s' d) (Rec0 (Maybe a))) where + gParseRecords opts context = Just $ M1 . K1 <$> context.jsonObject .:? selectorKey where - selectorKey :: Key - selectorKey = Key.fromString . ctx.opts.fieldLabelModifier $ symbolVal (Proxy @selectorName) + selectorKey = fieldKey @selectorName opts -instance (KnownSymbol selectorName, FromJSON a) => GParseRecords (S1 ('MetaSel ('Just selectorName) u s' d) (Rec0 a)) where - gParseRecords ctx = Just $ M1 . K1 <$> handleMissingKey (ctx.obj .: selectorKey) +instance (KnownSymbol selectorName, FromJSON a) => GParseRecords style (S1 ('MetaSel ('Just selectorName) u s' d) (Rec0 a)) where + gParseRecords opts context = Just $ M1 . K1 <$> applyOmittedField selectorKey context.jsonObject (context.jsonObject .: selectorKey) where - selectorKey :: Key - selectorKey = Key.fromString . ctx.opts.fieldLabelModifier $ symbolVal (Proxy @selectorName) + selectorKey = fieldKey @selectorName opts + +instance (TypeError Generic1WithoutSelectorErrorMessage) => GParseRecords style (S1 ('MetaSel 'Nothing u s' d) Par1) where + gParseRecords = generic1NoSelectorError + +instance (KnownSymbol selectorName) => GParseRecords style (S1 ('MetaSel ('Just selectorName) u s' d) Par1) where + gParseRecords :: forall a. (FromJSON a) => TaggedOptions -> ParsingContext -> Maybe (Parser (S1 ('MetaSel ('Just selectorName) u s' d) Par1 a)) + gParseRecords opts context = Just $ M1 . Par1 <$> applyOmittedField @a selectorKey context.jsonObject (context.jsonObject .: selectorKey) + where + selectorKey = fieldKey @selectorName opts + +-- 'Rec1 Maybe' is handled specifically for optional fields ('Maybe a'). +instance {-# OVERLAPPING #-} (KnownSymbol selectorName) => GParseRecords style (S1 ('MetaSel ('Just selectorName) u s' d) (Rec1 Maybe)) where + gParseRecords opts context = Just $ M1 . Rec1 <$> context.jsonObject .:? selectorKey + where + selectorKey = fieldKey @selectorName opts + +-- * FromJSON deriving for GTaggedJSON1 and GUntaggedJSON1 (Generic1 path) + +genericParseJSON1 :: forall style (f :: Type -> Type) a. (Generic1 f, FromJSON a, GParseRecords style (Rep1 f)) => TaggedOptions -> Value -> Parser (f a) +genericParseJSON1 opts = withObject "Object" $ \jsonObject -> + to1 <$> do + let context = ParsingContext {expectedTagValue = Nothing, jsonObject} + case gParseRecords @style @(Rep1 f) opts context of + Just parser -> parser + Nothing -> error "unreachable" + +genericTaggedParseJSON1 :: forall key opts f a. (Generic1 f, FromJSON a, GParseRecords (GTaggedJSON1 key opts f) (Rep1 f)) => TaggedOptions -> Value -> Parser (GTaggedJSON1 key opts f a) +genericTaggedParseJSON1 opts = fmap GTaggedJSON1 . genericParseJSON1 @(GTaggedJSON1 key opts f) opts - handleMissingKey :: Parser a -> Parser a - handleMissingKey p = case omittedField of - Just def | not (selectorKey `KeyMap.member` ctx.obj) -> pure def - _otherwise -> p +genericUntaggedParseJSON1 :: forall opts f a. (Generic1 f, FromJSON a, GParseRecords (GUntaggedJSON1 opts f) (Rep1 f)) => TaggedOptions -> Value -> Parser (GUntaggedJSON1 opts f a) +genericUntaggedParseJSON1 opts = fmap GUntaggedJSON1 . genericParseJSON1 @(GUntaggedJSON1 opts f) opts + +instance (Generic1 f, FromJSON a, HasTaggedOptions opts, GParseRecords (GTaggedJSON1 key opts f) (Rep1 f)) => FromJSON (GTaggedJSON1 key opts f a) where + parseJSON = genericTaggedParseJSON1 (taggedOptions @opts) + +instance (Generic1 f, FromJSON a, HasTaggedOptions opts, GParseRecords (GUntaggedJSON1 opts f) (Rep1 f)) => FromJSON (GUntaggedJSON1 opts f a) where + parseJSON = genericUntaggedParseJSON1 (taggedOptions @opts) -- * ToSchema deriving @@ -287,114 +478,218 @@ class SchemaDetails a where `ToSchema` must be present for all sum constructor arguments. -} -instance (Typeable (GTaggedJSON opts a), HasTaggedOptions opts, Generic a, SchemaDetails a, ToJSON a, GetDataName (Rep a), GToSchema (Rep a)) => ToSchema (GTaggedJSON opts a) where - declareNamedSchema _ = genericDeclareNamedSchema (taggedOptions @opts) (Proxy @a) - -genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a), GetDataName (Rep a), ToJSON a, SchemaDetails a) => TaggedOptions -> Proxy a -> Declare (OpenApi.Definitions Schema) OpenApi.NamedSchema -genericDeclareNamedSchema opts _ = do +genericDeclareNamedSchema :: forall style a. (GToSchema style (Rep a), GetDataName (Rep a), ToJSON a, SchemaDetails a) => TaggedOptions -> Proxy a -> Declare (OpenApi.Definitions Schema) OpenApi.NamedSchema +genericDeclareNamedSchema opts _proxy = do let name = fromMaybe (T.pack . opts.datatypeNameModifier $ getDataName @(Rep a)) (schemaName @a) - schema <- genSchema @(Rep a) $ opts & #tagDescription .~ schemaTagDescription @a + schema <- genSchema @style @(Rep a) (Proxy @GTaggedJSONParam) $ opts & #tagDescription .~ schemaTagDescription @a pure . OpenApi.NamedSchema (Just name) . schemaCustomize @a $ schema - & #type - ?~ OpenApiObject - & #title - ?~ name - & #description - .~ schemaDescription @a - & #example - .~ fmap toJSON (schemaExample @a) - & #default - .~ fmap toJSON (schemaDefault @a) - -class GToSchema (f :: Type -> Type) where - genSchema :: TaggedOptions -> Declare (OpenApi.Definitions Schema) Schema + & #type ?~ OpenApiObject + & #title ?~ name + & #description .~ schemaDescription @a + & #example .~ fmap toJSON (schemaExample @a) + & #default .~ fmap toJSON (schemaDefault @a) + +instance (style ~ GTaggedJSON key opts, Typeable (style a), HasTaggedOptions opts, SchemaDetails a, ToJSON a, GetDataName (Rep a), GToSchema style (Rep a)) => ToSchema (GTaggedJSON key opts a) where + declareNamedSchema _ = genericDeclareNamedSchema @style (taggedOptions @opts) (Proxy @a) + +instance (style ~ GUntaggedJSON opts, Typeable (style a), HasTaggedOptions opts, SchemaDetails a, ToJSON a, GetDataName (Rep a), GToSchema style (Rep a)) => ToSchema (GUntaggedJSON opts a) where + declareNamedSchema _ = genericDeclareNamedSchema @style (taggedOptions @opts) (Proxy @a) + +{- | Generically derive a JSON `Schema`. + +The `Proxy a` argument and `ToSchema a` method constraint are consumed by +the `Par1` and `Rec1 Maybe` leaf instances (Generic1 only). For the +`Generic` path the proxy is `Proxy @GTaggedJSONParam`, which is never +inspected because `Rep a` never contains `Par1` or `Rec1` leaves. +-} +class GToSchema style (f :: Type -> Type) where + genSchema :: (ToSchema a) => Proxy a -> TaggedOptions -> Declare (OpenApi.Definitions Schema) Schema -- | Sum type, with tags -instance (GToSchema a) => GToSchema (D1 m a) where - genSchema = genSchema @a +instance (GToSchema style a) => GToSchema style (D1 m a) where + genSchema = genSchema @style @a constructorName :: forall (m :: Meta). (Constructor m) => TaggedOptions -> String constructorName opts = opts.constructorTagModifier $ conName (metaInfo @m) constructorSchema :: forall (m :: Meta). (Constructor m) => TaggedOptions -> Key -> Schema -> Schema -constructorSchema opts tagKey schema' = +constructorSchema opts key schema' = schema' - & #type - ?~ OpenApiObject - & #title - ?~ constName + & #type ?~ OpenApiObject + & #title ?~ constName & over #required (tagKeyStr :) & over #properties (HMSI.union $ HMSI.singleton tagKeyStr tagSchema) where tagKeyStr :: Text - tagKeyStr = Key.toText tagKey + tagKeyStr = Key.toText key constName :: Text constName = T.pack $ constructorName @m opts tagSchema :: OpenApi.Referenced Schema tagSchema = OpenApi.Inline $ mempty - & #type - ?~ OpenApiString - & #enum - ?~ [String constName] - & #description - .~ opts.tagDescription constName - -instance {-# OVERLAPPING #-} (Constructor m, GToSchema a) => GToSchema (D1 _m (C1 m a)) where - genSchema opts = do - childSchema <- genSchema @a opts - pure $ case opts.tagKey of - Nothing -> childSchema - Just key -> constructorSchema @m opts key childSchema - --- | Sum type constructor -instance (m ~ 'MetaCons n f s, Constructor m, GToSchema a) => GToSchema (C1 m a) where - genSchema opts = do - childSchema <- genSchema @a opts - pure $ case opts.tagKey of - Nothing -> mempty - Just key -> mempty & #oneOf ?~ [OpenApi.Inline $ constructorSchema @m opts key childSchema] - -instance (GToSchema a, GToSchema b) => GToSchema (a :+: b) where - genSchema opts = do - schemaL <- genSchema @a opts - schemaR <- genSchema @b opts + & #type ?~ OpenApiString + & #enum ?~ [String constName] + & #description .~ opts.tagDescription constName + +-- | Single-constructor GTaggedJSON variant: adds tag info to the schema. +instance {-# OVERLAPPING #-} (style ~ GTaggedJSON key opts, Constructor m, GToSchema style a, KnownSymbol key) => GToSchema (GTaggedJSON key opts) (D1 _m (C1 m a)) where + genSchema proxy opts = do + childSchema <- genSchema @style @a proxy opts + pure $ constructorSchema @m opts (mkTagKey @key) childSchema + +-- | Single-constructor GTaggedJSON1 variant: adds tag info to the schema. +instance {-# OVERLAPPING #-} (style ~ GTaggedJSON1 key opts f, Constructor m, GToSchema style a, KnownSymbol key) => GToSchema (GTaggedJSON1 key opts f) (D1 _m (C1 m a)) where + genSchema proxy opts = do + childSchema <- genSchema @style @a proxy opts + pure $ constructorSchema @m opts (mkTagKey @key) childSchema + +-- | Single-constructor GUntaggedJSON variant: returns child schema as-is. +instance {-# OVERLAPPING #-} (style ~ GUntaggedJSON opts, GToSchema style a) => GToSchema (GUntaggedJSON opts) (D1 _m (C1 m a)) where + genSchema = genSchema @style @a + +-- | Single-constructor GUntaggedJSON1 variant: returns child schema as-is. +instance {-# OVERLAPPING #-} (style ~ GUntaggedJSON1 opts f, GToSchema style a) => GToSchema (GUntaggedJSON1 opts f) (D1 _m (C1 m a)) where + genSchema = genSchema @style @a + +-- | Multi-constructor GTaggedJSON variant. +instance (style ~ GTaggedJSON key opts, m ~ 'MetaCons n f s, Constructor m, GToSchema style a, KnownSymbol key) => GToSchema (GTaggedJSON key opts) (C1 m a) where + genSchema proxy opts = do + childSchema <- genSchema @style @a proxy opts + pure $ mempty & #oneOf ?~ [OpenApi.Inline $ constructorSchema @m opts (mkTagKey @key) childSchema] + +-- | Multi-constructor GTaggedJSON1 variant. +instance (style ~ GTaggedJSON1 key opts f, m ~ 'MetaCons n fixity s, Constructor m, GToSchema style a, KnownSymbol key) => GToSchema (GTaggedJSON1 key opts f) (C1 m a) where + genSchema proxy opts = do + childSchema <- genSchema @style @a proxy opts + pure $ mempty & #oneOf ?~ [OpenApi.Inline $ constructorSchema @m opts (mkTagKey @key) childSchema] + +instance (style ~ GTaggedJSON key opts, GToSchema style a, GToSchema style b) => GToSchema (GTaggedJSON key opts) (a :+: b) where + genSchema proxy opts = do + schemaL <- genSchema @style @a proxy opts + schemaR <- genSchema @style @b proxy opts pure $ mempty & #oneOf ?~ fromMaybe [] (schemaL ^. #oneOf <> schemaR ^. #oneOf) -instance (GToSchema a, GToSchema b) => GToSchema (a :*: b) where - genSchema opts = do - schemaA <- genSchema @a opts - schemaB <- genSchema @b opts +instance (style ~ GTaggedJSON1 key opts f, GToSchema style a, GToSchema style b) => GToSchema (GTaggedJSON1 key opts f) (a :+: b) where + genSchema proxy opts = do + schemaL <- genSchema @style @a proxy opts + schemaR <- genSchema @style @b proxy opts + pure $ mempty & #oneOf ?~ fromMaybe [] (schemaL ^. #oneOf <> schemaR ^. #oneOf) + +instance (GToSchema style a, GToSchema style b) => GToSchema style (a :*: b) where + genSchema proxy opts = do + schemaA <- genSchema @style @a proxy opts + schemaB <- genSchema @style @b proxy opts pure $ schemaA <> schemaB -instance GToSchema U1 where - genSchema _ = pure mempty +instance GToSchema style U1 where + genSchema _ _ = pure mempty -instance (ToSchema a) => GToSchema (S1 ('MetaSel 'Nothing u s' d) (Rec0 a)) where - genSchema _ = OpenApi.declareSchema (Proxy @a) +-- Rec0 (concrete field) instances -- -instance {-# OVERLAPPABLE #-} (KnownSymbol selectorName, ToSchema a) => GToSchema (S1 ('MetaSel ('Just selectorName) u s' d) (Rec0 a)) where - genSchema opts = do +instance (ToSchema a) => GToSchema style (S1 ('MetaSel 'Nothing u s' d) (Rec0 a)) where + genSchema _ _ = OpenApi.declareSchema (Proxy @a) + +instance {-# OVERLAPPABLE #-} (KnownSymbol selectorName, ToSchema a) => GToSchema style (S1 ('MetaSel ('Just selectorName) u s' d) (Rec0 a)) where + genSchema _ opts = do value <- OpenApi.declareSchemaRef (Proxy @a) let schema = OpenApi.toSchema (Proxy @a) fields = [selectorKey | isNothing (schema ^. #default)] pure $ mempty & #properties .~ HMSI.singleton selectorKey value & #required .~ fields where - selectorKey :: Text - selectorKey = T.pack . opts.fieldLabelModifier $ symbolVal (Proxy @selectorName) + selectorKey = Key.toText $ fieldKey @selectorName opts -instance {-# OVERLAPPING #-} (KnownSymbol selectorName, ToSchema a) => GToSchema (S1 ('MetaSel ('Just selectorName) u s' d) (Rec0 (Maybe a))) where - genSchema opts = do +instance {-# OVERLAPPING #-} (KnownSymbol selectorName, ToSchema a) => GToSchema style (S1 ('MetaSel ('Just selectorName) u s' d) (Rec0 (Maybe a))) where + genSchema _ opts = do value <- OpenApi.declareSchemaRef (Proxy @a) pure $ mempty & #properties .~ HMSI.singleton selectorKey value where - selectorKey :: Text - selectorKey = T.pack . opts.fieldLabelModifier $ symbolVal (Proxy @selectorName) + selectorKey = Key.toText $ fieldKey @selectorName opts + +instance (TypeError Generic1WithoutSelectorErrorMessage) => GToSchema style (S1 ('MetaSel 'Nothing u s' d) Par1) where + genSchema _ _ = generic1NoSelectorError + +instance (KnownSymbol selectorName) => GToSchema style (S1 ('MetaSel ('Just selectorName) u s' d) Par1) where + genSchema proxy opts = do + value <- OpenApi.declareSchemaRef proxy + let schema = OpenApi.toSchema proxy + fields = [selectorKey | isNothing (schema ^. #default)] + pure $ mempty & #properties .~ HMSI.singleton selectorKey value & #required .~ fields + where + selectorKey = Key.toText $ fieldKey @selectorName opts + +-- 'Rec1 Maybe' is handled specifically for optional fields ('Maybe a'). +instance {-# OVERLAPPING #-} (KnownSymbol selectorName) => GToSchema style (S1 ('MetaSel ('Just selectorName) u s' d) (Rec1 Maybe)) where + genSchema proxy opts = do + value <- OpenApi.declareSchemaRef proxy + pure $ mempty & #properties .~ HMSI.singleton selectorKey value + where + selectorKey = Key.toText $ fieldKey @selectorName opts + +-- * ToSchema deriving for GTaggedJSON1 and GUntaggedJSON1 (Generic1 path) + +genericLiftDeclareNamedSchema :: forall gstyle1 f a b. (b ~ f a, GToSchema gstyle1 (Rep1 f), GetDataName (Rep1 f), ToJSON b, ToSchema a, SchemaDetails b) => TaggedOptions -> Proxy a -> Declare (OpenApi.Definitions Schema) OpenApi.NamedSchema +genericLiftDeclareNamedSchema opts _proxy = do + let name = fromMaybe (T.pack . opts.datatypeNameModifier $ getDataName @(Rep1 f)) (schemaName @b) + schema <- genSchema @gstyle1 @(Rep1 f) (Proxy @a) $ opts & #tagDescription .~ schemaTagDescription @b + pure . OpenApi.NamedSchema (Just name) . schemaCustomize @b $ + schema + & #type ?~ OpenApiObject + & #title ?~ name + & #description .~ schemaDescription @b + & #example .~ fmap toJSON (schemaExample @b) + & #default .~ fmap toJSON (schemaDefault @b) + +instance (style ~ GTaggedJSON1 key opts f, Typeable (style a), HasTaggedOptions opts, GToSchema style (Rep1 f), GetDataName (Rep1 f), ToJSON (f a), ToSchema a, SchemaDetails (f a)) => ToSchema (GTaggedJSON1 key opts f a) where + declareNamedSchema _ = genericLiftDeclareNamedSchema @style @f (taggedOptions @opts) (Proxy @a) + +instance (style ~ GUntaggedJSON1 opts f, Typeable (style a), HasTaggedOptions opts, GToSchema style (Rep1 f), GetDataName (Rep1 f), ToJSON (f a), ToSchema a, SchemaDetails (f a)) => ToSchema (GUntaggedJSON1 opts f a) where + declareNamedSchema _ = genericLiftDeclareNamedSchema @style @f (taggedOptions @opts) (Proxy @a) -- * Internal functions, classes and instances +mkTagKey :: forall key. (KnownSymbol key) => Key +mkTagKey = Key.fromString $ symbolVal (Proxy @key) + +mkTagPair :: forall key s (m :: Meta). (KnownSymbol key, SerializationKind s, Constructor m) => TaggedOptions -> SerializationType s +mkTagPair opts = mkPair @s (mkTagKey @key) (T.pack $ constructorName @m opts) + +-- | Derive the JSON key for a named selector field given a set of options. +fieldKey :: forall selectorName. (KnownSymbol selectorName) => TaggedOptions -> Key +fieldKey opts = Key.fromString . opts.fieldLabelModifier $ symbolVal (Proxy @selectorName) + +{- | Apply a default value from 'omittedField' when the key is absent, or +run the given parser otherwise. +-} +applyOmittedField :: forall a. (FromJSON a) => Key -> Object -> Parser a -> Parser a +applyOmittedField key jsonObject parser = case omittedField @a of + Just def | not (key `KeyMap.member` jsonObject) -> pure def + _otherwise -> parser + +{- | Runtime counterpart of 'Generic1WithoutSelectorErrorMessage'. +Never actually reached because 'TypeError' halts compilation, but GHC +requires a complete instance body. +-} +generic1NoSelectorError :: a +generic1NoSelectorError = error "TaggedJSON: Generic1 instances require a selector field to differentiate contents." + +{- | Uninhabited sentinel type used as the phantom parameter of @Rep a p@ when +driving 'GSerializeRecords', 'GParseRecords', and 'GToSchema' from the +'Generic' path. Its instances are never called because @Rep a@ never +contains 'Par1' or 'Rec1' leaves. +-} +data GTaggedJSONParam + +instance ToJSON GTaggedJSONParam where + toJSON = \case {} + +instance FromJSON GTaggedJSONParam where + parseJSON _ = fail "GTaggedJSONParam: unreachable" + +instance ToSchema GTaggedJSONParam where + declareNamedSchema _ = pure $ OpenApi.NamedSchema Nothing mempty + {- | Because the `aeson` library has two ways of serializing (either `toJSON` or `toEncoding`) we have to have a way of doing both. This class helps with that. @@ -407,16 +702,16 @@ class SerializationKind a where mkPair :: (ToJSON b) => Key -> b -> SerializationType a mkPairs :: (ToKeyMap b) => b -> SerializationType a -instance SerializationKind Series where - type SerializationType Series = Series - mkPair key value = key .= value - mkPairs = toSeries - instance SerializationKind Pair where type SerializationType Pair = [Pair] mkPair key value = [key .= value] mkPairs = toPairs +instance SerializationKind Series where + type SerializationType Series = Series + mkPair key value = key .= value + mkPairs = toSeries + class GetConstructorNames (f :: Type -> Type) where getConstructorNames :: [String] diff --git a/tagged-json.cabal b/tagged-json.cabal index 9996807..30df635 100644 --- a/tagged-json.cabal +++ b/tagged-json.cabal @@ -24,7 +24,7 @@ tested-with: || ==9.6.7 || ==9.8.4 || ==9.10.3 - || ==9.12.2 + || ==9.12.4 source-repository head type: git diff --git a/test/Main.hs b/test/Main.hs index 844f330..b3ee8b1 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -29,6 +29,8 @@ allTests = , testCustomInstances , testOmitNothingFields , testOmittedField + , testDualPrefix + , testGeneric1 ] -- Define datatypes with different TaggedJSON derivations. @@ -41,7 +43,7 @@ instance SchemaDetails Unit where schemaDescription = Just "Unit type" schemaExample = Just MkUnit schemaDefault = Just MkUnit - schemaCustomize s = s{_schemaDeprecated = Just True} + schemaCustomize s = s {_schemaDeprecated = Just True} data UnitWithTag = MkUnitWithTag deriving stock (Eq, Show, Generic) @@ -190,6 +192,15 @@ instance SchemaDetails InlineSum where schemaDescription = Just "Inline Sum type" schemaExample = Just $ Inline1 10 +-- Sum type where field prefix ("field") differs from constructor prefix ("Con"). +-- Constructors ConA/ConB -> strip "Con" + snakeCase -> "a"/"b" +-- Field fieldVal -> strip "field" + snakeCase -> "val" +data DualPrefixSum + = ConA {fieldVal :: Int} + | ConB {fieldVal :: Int} + deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON) via DualPrefixTagged "field" "Con" "type" DualPrefixSum + data MaybeType = MkMaybeType { maybeLow :: Maybe Int , maybeHigh :: Maybe Int @@ -201,6 +212,82 @@ instance SchemaDetails MaybeType where schemaDescription = Just "Maybe type" schemaExample = Just $ MkMaybeType (Just 0) Nothing +-- * Polymorphic-field test types + +-- | Newtype wrapper with a named field. +newtype WrapperNamed a = WrapperNamed {wnInner :: a} + deriving stock (Eq, Show, Generic1) + deriving (ToJSON, FromJSON, ToSchema) via Untagged1 "wn" WrapperNamed a + +instance SchemaDetails (WrapperNamed a) where + schemaDescription = Just "WrapperNamed" + +-- | Product type with a type-parameter field and a concrete field. +data NamedParam a = NamedParam + { npInner :: a + , npFixed :: Int + } + deriving stock (Eq, Show, Generic1) + deriving (ToJSON, FromJSON, ToSchema) via Untagged1 "np" NamedParam a + +instance SchemaDetails (NamedParam a) where + schemaDescription = Just "NamedParam" + +{- | Sum type where all constructors carry the type parameter. +Uses empty field/constructor prefix so the snakeCase of the constructor +name becomes the tag value (e.g. SumParamA -> "sum_param_a"). +-} +data SumParam a + = SumParamA {sumParamInner :: a} + | SumParamB {sumParamInner :: a} + deriving stock (Eq, Show, Generic1) + deriving (ToJSON, FromJSON, ToSchema) via Tagged1 "" "tag" SumParam a + +instance SchemaDetails (SumParam a) where + schemaDescription = Just "SumParam" + +-- | Type with a 'Maybe a' field. +newtype WithMaybeParam a = WithMaybeParam {wmpVal :: Maybe a} + deriving stock (Eq, Show, Generic1) + deriving (ToJSON, FromJSON, ToSchema) via Untagged1 "wmp" WithMaybeParam a + +instance SchemaDetails (WithMaybeParam a) where + schemaDescription = Just "WithMaybeParam" + +-- | Generic1 tests. +testGeneric1 :: TestTree +testGeneric1 = + testGroup + "Generic1 tests" + [ testCase "WrapperNamed Int roundtrip" $ + testEncodeDecode (WrapperNamed (42 :: Int)) "{\"inner\":42}" + , testCase "WrapperNamed (Maybe Int) roundtrip" $ do + testEncodeDecode (WrapperNamed (Just (7 :: Int))) "{\"inner\":7}" + testEncodeDecode (WrapperNamed (Nothing :: Maybe Int)) "{\"inner\":null}" + , testCase "NamedParam Int roundtrip" $ + testEncodeDecode (NamedParam (5 :: Int) 99) "{\"inner\":5,\"fixed\":99}" + , testCase "SumParam Int - SumParamA roundtrip" $ + testEncodeDecode (SumParamA (123 :: Int)) "{\"tag\":\"sum_param_a\",\"sum_param_inner\":123}" + , testCase "SumParam Int - SumParamB roundtrip" $ + testEncodeDecode (SumParamB (7 :: Int)) "{\"tag\":\"sum_param_b\",\"sum_param_inner\":7}" + , testCase "WithMaybeParam Int - present" $ + testEncodeDecode (WithMaybeParam (Just (1 :: Int))) "{\"val\":1}" + , testCase "WithMaybeParam Int - absent" $ + testEncodeDecode (WithMaybeParam (Nothing :: Maybe Int)) "{\"val\":null}" + , testCase "WrapperNamed schema" $ + testToSchema @(WrapperNamed Int) + "{\"description\":\"WrapperNamed\",\"properties\":{\"inner\":{\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"}},\"required\":[\"inner\"],\"title\":\"wrapper_named\",\"type\":\"object\"}" + , testCase "NamedParam schema" $ + testToSchema @(NamedParam Int) + "{\"description\":\"NamedParam\",\"properties\":{\"fixed\":{\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"},\"inner\":{\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"}},\"required\":[\"inner\",\"fixed\"],\"title\":\"named_param\",\"type\":\"object\"}" + , testCase "SumParam schema" $ + testToSchema @(SumParam Int) + "{\"description\":\"SumParam\",\"oneOf\":[{\"properties\":{\"sum_param_inner\":{\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"},\"tag\":{\"enum\":[\"sum_param_a\"],\"type\":\"string\"}},\"required\":[\"tag\",\"sum_param_inner\"],\"title\":\"sum_param_a\",\"type\":\"object\"},{\"properties\":{\"sum_param_inner\":{\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"},\"tag\":{\"enum\":[\"sum_param_b\"],\"type\":\"string\"}},\"required\":[\"tag\",\"sum_param_inner\"],\"title\":\"sum_param_b\",\"type\":\"object\"}],\"title\":\"sum_param\",\"type\":\"object\"}" + , testCase "WithMaybeParam schema" $ + testToSchema @(WithMaybeParam Int) + "{\"description\":\"WithMaybeParam\",\"properties\":{\"val\":{\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"}},\"title\":\"with_maybe_param\",\"type\":\"object\"}" + ] + toFromJsonTests :: TestTree toFromJsonTests = testGroup @@ -304,12 +391,12 @@ toSchemaTests = data WithNameModifierOption (bool :: Bool) instance HasTaggedOptions (WithNameModifierOption 'True) where - taggedOptions = defaultTaggedOptions{Tagged.datatypeNameModifier = fmap toLower} + taggedOptions = defaultTaggedOptions {Tagged.datatypeNameModifier = fmap toLower} instance HasTaggedOptions (WithNameModifierOption 'False) where - taggedOptions = defaultTaggedOptions{Tagged.datatypeNameModifier = id} + taggedOptions = defaultTaggedOptions {Tagged.datatypeNameModifier = id} -type WithNameModifierTaggedJSON bool = GTaggedJSON (WithNameModifierOption bool) +type WithNameModifierTaggedJSON bool = GUntaggedJSON (WithNameModifierOption bool) newtype UnmodifiedSchemaName = UnmodifiedSchemaName {a :: Int} deriving stock (Eq, Show, Generic) @@ -365,8 +452,8 @@ instance FromJSON CustomData where parseJSON = withObject "CustomData" $ \o -> MkCustomData <$> (o .: "v1") <*> (o .: "v2") instance ToKeyMap CustomData where - toSeries MkCustomData{..} = "v1" .= v1 <> "v2" .= v2 - toPairs MkCustomData{..} = [("v1", toJSON v1), ("v2", toJSON v2)] + toSeries MkCustomData {..} = "v1" .= v1 <> "v2" .= v2 + toPairs MkCustomData {..} = [("v1", toJSON v1), ("v2", toJSON v2)] instance ToSchema CustomData where declareNamedSchema _ = pure $ NamedSchema (Just "CustomData") (mempty & (#description ?~ "CustomData description")) @@ -409,12 +496,12 @@ testEncodeDecode o s = do data OmitNothingOption (bool :: Bool) instance HasTaggedOptions (OmitNothingOption 'True) where - taggedOptions = defaultTaggedOptions{Tagged.omitNothingFields = True} + taggedOptions = defaultTaggedOptions {Tagged.omitNothingFields = True} instance HasTaggedOptions (OmitNothingOption 'False) where - taggedOptions = defaultTaggedOptions{Tagged.omitNothingFields = False} + taggedOptions = defaultTaggedOptions {Tagged.omitNothingFields = False} -type OmitNothingTaggedJSON onf = GTaggedJSON (OmitNothingOption onf) +type OmitNothingTaggedJSON onf = GUntaggedJSON (OmitNothingOption onf) data OmitNothingFields = OmitNothingFields { hello :: Maybe Int @@ -464,7 +551,7 @@ omittedValue :: Omitted omittedValue = MkOmitted 1 True instance FromJSON Omitted where - parseJSON = fmap (.unGTaggedJSON) . parseJSON @OmittedTaggedJSON + parseJSON = fmap (.unwrap) . parseJSON @OmittedTaggedJSON omittedField = Just omittedValue testOmittedField :: TestTree @@ -477,5 +564,19 @@ testOmittedField = encode (MkCustomOmitted 0 omittedValue) @?= "{\"mandatory\":0,\"omitted\":{\"a\":1,\"b\":true}}" ] +testDualPrefix :: TestTree +testDualPrefix = + testGroup + "DualPrefix" + [ testCase "encode ConA" $ + encode (ConA 42) @?= "{\"type\":\"a\",\"val\":42}" + , testCase "encode ConB" $ + encode (ConB 0) @?= "{\"type\":\"b\",\"val\":0}" + , testCase "decode ConA" $ + eitherDecode "{\"type\":\"a\",\"val\":42}" @?= Right (ConA 42) + , testCase "decode ConB" $ + eitherDecode "{\"type\":\"b\",\"val\":0}" @?= Right (ConB 0) + ] + main :: IO () main = defaultMain allTests diff --git a/test/TestTaggedJson.hs b/test/TestTaggedJson.hs index 016fe1b..f3f640c 100644 --- a/test/TestTaggedJson.hs +++ b/test/TestTaggedJson.hs @@ -3,6 +3,9 @@ module TestTaggedJson ( Tagged, Untagged, + Tagged1, + Untagged1, + DualPrefixTagged, ) where import Data.Aeson (camelTo2) @@ -12,9 +15,14 @@ import Data.Proxy import Deriving.TaggedJson import GHC.TypeLits -data Opts (prefix :: Symbol) (tagKey :: Maybe Symbol) -type Tagged prefix tagKey = GTaggedJSON (Opts prefix ('Just tagKey)) -type Untagged prefix = GTaggedJSON (Opts prefix 'Nothing) +snakeCase :: String -> String +snakeCase = camelTo2 '_' + +data Opts (prefix :: Symbol) +type Tagged prefix tagKey = GTaggedJSON tagKey (Opts prefix) +type Untagged prefix = GUntaggedJSON (Opts prefix) +type Tagged1 prefix tagKey = GTaggedJSON1 tagKey (Opts prefix) +type Untagged1 prefix = GUntaggedJSON1 (Opts prefix) exampleTaggedOptions :: String -> TaggedOptions exampleTaggedOptions prefix = @@ -23,17 +31,23 @@ exampleTaggedOptions prefix = , constructorTagModifier = snakeCase . fromJust . stripPrefix prefix , datatypeNameModifier = snakeCase } - where - snakeCase = camelTo2 '_' -instance (KnownSymbol prefix, KnownSymbol tagKey) => HasTaggedOptions (Opts prefix ('Just tagKey)) where - taggedOptions = - (exampleTaggedOptions (symbolVal $ Proxy @prefix)) - { tagKey = Just (fromString . symbolVal $ Proxy @tagKey) - } +instance (KnownSymbol prefix) => HasTaggedOptions (Opts prefix) where + taggedOptions = exampleTaggedOptions (symbolVal $ Proxy @prefix) -instance (KnownSymbol prefix) => HasTaggedOptions (Opts prefix 'Nothing) where +-- Options type with separate prefixes for fields and constructors. + +data DualPrefixOptions (fieldPrefix :: Symbol) (constructorPrefix :: Symbol) + +instance + (KnownSymbol fp, KnownSymbol cp) => + HasTaggedOptions (DualPrefixOptions fp cp) + where taggedOptions = - (exampleTaggedOptions (symbolVal $ Proxy @prefix)) - { tagKey = Nothing + defaultTaggedOptions + { fieldLabelModifier = snakeCase . fromJust . stripPrefix (symbolVal (Proxy @fp)) + , constructorTagModifier = snakeCase . fromJust . stripPrefix (symbolVal (Proxy @cp)) + , datatypeNameModifier = snakeCase } + +type DualPrefixTagged fp cp tag = GTaggedJSON tag (DualPrefixOptions fp cp) From e75c5315fae7a93723ed6eadf5e798d3da8883d4 Mon Sep 17 00:00:00 2001 From: Giorgio Marinelli Date: Sat, 25 Apr 2026 08:18:48 +0200 Subject: [PATCH 2/6] More clean-up --- example/DerivingViaInstances.hs | 4 +- example/GenericInstances.hs | 6 +- src/Deriving/TaggedJson.hs | 194 ++++++++++++++++---------------- test/Main.hs | 4 +- test/TestTaggedJson.hs | 10 +- 5 files changed, 106 insertions(+), 112 deletions(-) diff --git a/example/DerivingViaInstances.hs b/example/DerivingViaInstances.hs index d9cc361..d09a03c 100644 --- a/example/DerivingViaInstances.hs +++ b/example/DerivingViaInstances.hs @@ -13,8 +13,8 @@ import Deriving.TaggedJson import GHC.TypeLits data Opts (prefix :: Symbol) -type Tagged prefix tagKey = GTaggedJSON tagKey (Opts prefix) -type Untagged prefix = GUntaggedJSON (Opts prefix) +type Tagged prefix tagKey = GTagged tagKey (Opts prefix) +type Untagged prefix = GUntagged (Opts prefix) exampleTaggedOptions :: String -> TaggedOptions exampleTaggedOptions prefix = diff --git a/example/GenericInstances.hs b/example/GenericInstances.hs index 3b43fc1..4b0ba62 100644 --- a/example/GenericInstances.hs +++ b/example/GenericInstances.hs @@ -29,7 +29,7 @@ data Command | Turn Turn deriving (Eq, Show, Generic) -type TaggedCommand = GTaggedJSON "command" TaggedOptions +type TaggedCommand = GTagged "command" TaggedOptions instance ToKeyMap Command where toSeries = genericToSeries @TaggedCommand (options "") @@ -49,7 +49,7 @@ instance SchemaDetails Command newtype Distance = MkDistance {distance :: Maybe Int} deriving (Eq, Show, Generic) -type UntaggedDistance = GUntaggedJSON TaggedOptions +type UntaggedDistance = GUntagged TaggedOptions instance ToKeyMap Distance where toSeries = genericToSeries @UntaggedDistance (options "") @@ -72,7 +72,7 @@ data Turn | TurnBack deriving (Eq, Show, Generic) -type TaggedTurn = GTaggedJSON "direction" TaggedOptions +type TaggedTurn = GTagged "direction" TaggedOptions instance ToKeyMap Turn where toSeries = genericToSeries @TaggedTurn (options "Turn") diff --git a/src/Deriving/TaggedJson.hs b/src/Deriving/TaggedJson.hs index cabce14..2e13d47 100644 --- a/src/Deriving/TaggedJson.hs +++ b/src/Deriving/TaggedJson.hs @@ -2,10 +2,10 @@ {-# LANGUAGE CPP #-} module Deriving.TaggedJson ( - GTaggedJSON (..), - GUntaggedJSON (..), - GTaggedJSON1 (..), - GUntaggedJSON1 (..), + GTagged (..), + GUntagged (..), + GTagged1 (..), + GUntagged1 (..), ToKeyMap (toPairs, toSeries), SchemaDetails (..), HasTaggedOptions (..), @@ -87,18 +87,18 @@ class HasTaggedOptions a where {- | Newtype for deriving 'ToJSON', 'FromJSON', 'ToSchema', 'ToKeyMap' with a tagged (discriminated) representation. -} -newtype GTaggedJSON (key :: Symbol) opts a = GTaggedJSON {unwrap :: a} +newtype GTagged (key :: Symbol) opts a = GTagged {unwrap :: a} --- | Like 'GTaggedJSON' but uses 'Generic1' instead of 'Generic'. -newtype GTaggedJSON1 (key :: Symbol) opts f a = GTaggedJSON1 {unwrap :: f a} +-- | Like 'GTagged' but uses 'Generic1' instead of 'Generic'. +newtype GTagged1 (key :: Symbol) opts f a = GTagged1 {unwrap :: f a} {- | Newtype for deriving 'ToJSON', 'FromJSON', 'ToSchema', 'ToKeyMap' without a tag field. -} -newtype GUntaggedJSON opts a = GUntaggedJSON {unwrap :: a} +newtype GUntagged opts a = GUntagged {unwrap :: a} --- | Like 'GUntaggedJSON' but uses 'Generic1' instead of 'Generic'. -newtype GUntaggedJSON1 opts f a = GUntaggedJSON1 {unwrap :: f a} +-- | Like 'GUntagged' but uses 'Generic1' instead of 'Generic'. +newtype GUntagged1 opts f a = GUntagged1 {unwrap :: f a} -- * ToJSON deriving @@ -109,59 +109,59 @@ instead of Aeson.Value, which is a more general type. This allows us to add tags to the map, which would not always be possible with Aeson.Value. `ToKeyMap` must be present for all sum constructor arguments to derive -`ToJSON` via `GTaggedJSON`. +`ToJSON` via `GTagged`. -`ToKeyMap` Can be automatically derived via `GTaggedJSON`. +`ToKeyMap` Can be automatically derived via `GTagged`. -} class ToKeyMap a where toPairs :: a -> [Pair] toSeries :: a -> Series --- GTaggedJSON instances +-- GTagged instances -instance (style ~ GTaggedJSON key opts, HasTaggedOptions opts, Generic a, GSerializeRecords style Pair (Rep a), GSerializeRecords style Series (Rep a)) => ToKeyMap (GTaggedJSON key opts a) where +instance (style ~ GTagged key opts, HasTaggedOptions opts, Generic a, GSerializeRecords style Pair (Rep a), GSerializeRecords style Series (Rep a)) => ToKeyMap (GTagged key opts a) where toPairs = genericToPairs @style (taggedOptions @opts) . (.unwrap) toSeries = genericToSeries @style (taggedOptions @opts) . (.unwrap) -instance (ToKeyMap (GTaggedJSON key opts a)) => ToJSON (GTaggedJSON key opts a) where +instance (ToKeyMap (GTagged key opts a)) => ToJSON (GTagged key opts a) where toJSON = object . toPairs toEncoding = pairs . toSeries --- GUntaggedJSON instances +-- GUntagged instances -instance (style ~ GUntaggedJSON opts, HasTaggedOptions opts, Generic a, GSerializeRecords style Pair (Rep a), GSerializeRecords style Series (Rep a)) => ToKeyMap (GUntaggedJSON opts a) where +instance (style ~ GUntagged opts, HasTaggedOptions opts, Generic a, GSerializeRecords style Pair (Rep a), GSerializeRecords style Series (Rep a)) => ToKeyMap (GUntagged opts a) where toPairs = genericToPairs @style (taggedOptions @opts) . (.unwrap) toSeries = genericToSeries @style (taggedOptions @opts) . (.unwrap) -instance (ToKeyMap (GUntaggedJSON opts a)) => ToJSON (GUntaggedJSON opts a) where +instance (ToKeyMap (GUntagged opts a)) => ToJSON (GUntagged opts a) where toJSON = object . toPairs toEncoding = pairs . toSeries --- GTaggedJSON1 instances +-- GTagged1 instances -instance (style ~ GTaggedJSON1 key opts f, HasTaggedOptions opts, Generic1 f, ToJSON a, GSerializeRecords style Pair (Rep1 f), GSerializeRecords style Series (Rep1 f)) => ToKeyMap (GTaggedJSON1 key opts f a) where +instance (style ~ GTagged1 key opts f, HasTaggedOptions opts, Generic1 f, ToJSON a, GSerializeRecords style Pair (Rep1 f), GSerializeRecords style Series (Rep1 f)) => ToKeyMap (GTagged1 key opts f a) where toPairs = genericLiftToPairs @style (taggedOptions @opts) . (.unwrap) toSeries = genericLiftToSeries @style (taggedOptions @opts) . (.unwrap) -instance (ToKeyMap (GTaggedJSON1 key opts f a)) => ToJSON (GTaggedJSON1 key opts f a) where +instance (ToKeyMap (GTagged1 key opts f a)) => ToJSON (GTagged1 key opts f a) where toJSON = object . toPairs toEncoding = pairs . toSeries --- GUntaggedJSON1 instances +-- GUntagged1 instances -instance (ToKeyMap (GUntaggedJSON1 opts f a)) => ToJSON (GUntaggedJSON1 opts f a) where +instance (ToKeyMap (GUntagged1 opts f a)) => ToJSON (GUntagged1 opts f a) where toJSON = object . toPairs toEncoding = pairs . toSeries -instance (style ~ GUntaggedJSON1 opts f, HasTaggedOptions opts, Generic1 f, ToJSON a, GSerializeRecords style Pair (Rep1 f), GSerializeRecords style Series (Rep1 f)) => ToKeyMap (GUntaggedJSON1 opts f a) where +instance (style ~ GUntagged1 opts f, HasTaggedOptions opts, Generic1 f, ToJSON a, GSerializeRecords style Pair (Rep1 f), GSerializeRecords style Series (Rep1 f)) => ToKeyMap (GUntagged1 opts f a) where toPairs = genericLiftToPairs @style (taggedOptions @opts) . (.unwrap) toSeries = genericLiftToSeries @style (taggedOptions @opts) . (.unwrap) genericToPairs :: forall style a. (GSerializeRecords style Pair (Rep a), Generic a) => TaggedOptions -> a -> [Pair] -genericToPairs opts = gSerializeRecords @style @Pair opts . from @a @GTaggedJSONParam +genericToPairs opts = gSerializeRecords @style @Pair opts . from @a @GTaggedParam genericToSeries :: forall style a. (GSerializeRecords style Series (Rep a), Generic a) => TaggedOptions -> a -> Series -genericToSeries opts = gSerializeRecords @style @Series opts . from @a @GTaggedJSONParam +genericToSeries opts = gSerializeRecords @style @Series opts . from @a @GTaggedParam genericToJSON :: forall style a. (GSerializeRecords style Pair (Rep a), Generic a) => TaggedOptions -> a -> Value genericToJSON opts = object . genericToPairs @style @a opts @@ -187,7 +187,7 @@ map used to build the final object by `ToJSON`. The method-level `ToJSON a` constraint is consumed by the `Par1` and `Rec1 Maybe` leaf instances (Generic1 only). It is satisfied but unused for the `Generic` path, where the phantom type is instantiated to -`GTaggedJSONParam`. +`GTaggedParam`. -} class GSerializeRecords style serialization (f :: Type -> Type) where gSerializeRecords :: (ToJSON a) => TaggedOptions -> f a -> SerializationType serialization @@ -196,28 +196,28 @@ class GSerializeRecords style serialization (f :: Type -> Type) where instance (GSerializeRecords style s a) => GSerializeRecords style s (D1 m a) where gSerializeRecords opts (M1 c) = gSerializeRecords @style @s opts c --- | Sum type constructor - GTaggedJSON variant: emits the discriminator field. -instance (style ~ GTaggedJSON key opts, Monoid (SerializationType s), SerializationKind s, Constructor m, GSerializeRecords style s a, KnownSymbol key) => GSerializeRecords (GTaggedJSON key opts) s (C1 m a) where +-- | Sum type constructor - GTagged variant: emits the discriminator field. +instance (style ~ GTagged key opts, Monoid (SerializationType s), SerializationKind s, Constructor m, GSerializeRecords style s a, KnownSymbol key) => GSerializeRecords (GTagged key opts) s (C1 m a) where gSerializeRecords opts c = mkTagPair @key @s @m opts <> gSerializeRecords @style @s opts (unM1 c) --- | Sum type constructor - GTaggedJSON1 variant: emits the discriminator field. -instance (style ~ GTaggedJSON1 key opts f, Monoid (SerializationType s), SerializationKind s, Constructor m, GSerializeRecords style s a, KnownSymbol key) => GSerializeRecords (GTaggedJSON1 key opts f) s (C1 m a) where +-- | Sum type constructor - GTagged1 variant: emits the discriminator field. +instance (style ~ GTagged1 key opts f, Monoid (SerializationType s), SerializationKind s, Constructor m, GSerializeRecords style s a, KnownSymbol key) => GSerializeRecords (GTagged1 key opts f) s (C1 m a) where gSerializeRecords opts c = mkTagPair @key @s @m opts <> gSerializeRecords @style @s opts (unM1 c) --- | Sum type constructor - GUntaggedJSON variant: no discriminator field. -instance (style ~ GUntaggedJSON opts, GSerializeRecords style s a) => GSerializeRecords (GUntaggedJSON opts) s (C1 m a) where +-- | Sum type constructor - GUntagged variant: no discriminator field. +instance (style ~ GUntagged opts, GSerializeRecords style s a) => GSerializeRecords (GUntagged opts) s (C1 m a) where gSerializeRecords opts c = gSerializeRecords @style @s opts (unM1 c) --- | Sum type constructor - GUntaggedJSON1 variant: no discriminator field. -instance (style ~ GUntaggedJSON1 opts f, GSerializeRecords style s a) => GSerializeRecords (GUntaggedJSON1 opts f) s (C1 m a) where +-- | Sum type constructor - GUntagged1 variant: no discriminator field. +instance (style ~ GUntagged1 opts f, GSerializeRecords style s a) => GSerializeRecords (GUntagged1 opts f) s (C1 m a) where gSerializeRecords opts c = gSerializeRecords @style @s opts (unM1 c) -instance (style ~ GTaggedJSON key opts, GSerializeRecords style s a, GSerializeRecords style s b) => GSerializeRecords (GTaggedJSON key opts) s (a :+: b) where +instance (style ~ GTagged key opts, GSerializeRecords style s a, GSerializeRecords style s b) => GSerializeRecords (GTagged key opts) s (a :+: b) where gSerializeRecords opts = \case L1 x -> gSerializeRecords @style @s opts x R1 x -> gSerializeRecords @style @s opts x -instance (style ~ GTaggedJSON1 key opts f, GSerializeRecords style s a, GSerializeRecords style s b) => GSerializeRecords (GTaggedJSON1 key opts f) s (a :+: b) where +instance (style ~ GTagged1 key opts f, GSerializeRecords style s a, GSerializeRecords style s b) => GSerializeRecords (GTagged1 key opts f) s (a :+: b) where gSerializeRecords opts = \case L1 x -> gSerializeRecords @style @s opts x R1 x -> gSerializeRecords @style @s opts x @@ -292,7 +292,7 @@ instance {-# OVERLAPPING #-} (SerializationKind s, KnownSymbol selectorName, Mon -- * FromJSON deriving -{- | Automatic deriving of `FromJSON` via `GTaggedJSON`. +{- | Automatic deriving of `FromJSON` via `GTagged`. `FromJSON` must be present for all sum constructor arguments. -} @@ -300,15 +300,15 @@ genericParseJSON :: forall style a. (Generic a, GParseRecords style (Rep a)) => genericParseJSON opts = withObject "Object" $ \jsonObject -> to <$> do let context = ParsingContext {expectedTagValue = Nothing, jsonObject} - case gParseRecords @style @(Rep a) @GTaggedJSONParam opts context of + case gParseRecords @style @(Rep a) @GTaggedParam opts context of Just parser -> parser Nothing -> error "unreachable" -instance (Generic a, HasTaggedOptions opts, GParseRecords (GTaggedJSON key opts) (Rep a)) => FromJSON (GTaggedJSON key opts a) where - parseJSON = coerce (genericParseJSON @(GTaggedJSON key opts) (taggedOptions @opts) :: Value -> Parser a) +instance (Generic a, HasTaggedOptions opts, GParseRecords (GTagged key opts) (Rep a)) => FromJSON (GTagged key opts a) where + parseJSON = coerce (genericParseJSON @(GTagged key opts) (taggedOptions @opts) :: Value -> Parser a) -instance (Generic a, HasTaggedOptions opts, GParseRecords (GUntaggedJSON opts) (Rep a)) => FromJSON (GUntaggedJSON opts a) where - parseJSON = coerce (genericParseJSON @(GUntaggedJSON opts) (taggedOptions @opts) :: Value -> Parser a) +instance (Generic a, HasTaggedOptions opts, GParseRecords (GUntagged opts) (Rep a)) => FromJSON (GUntagged opts a) where + parseJSON = coerce (genericParseJSON @(GUntagged opts) (taggedOptions @opts) :: Value -> Parser a) -- | Values that must be passed along when traversing the generic tree data ParsingContext = ParsingContext @@ -339,12 +339,12 @@ unsafeTaggedParser opts context = do show' :: Maybe String -> String show' = \case Nothing -> "Nothing"; Just k -> show k --- | Sum type, with tags - GTaggedJSON variant -instance (style ~ GTaggedJSON key opts, GParseRecords style a, GetConstructorNames a, KnownSymbol key) => GParseRecords (GTaggedJSON key opts) (D1 m a) where +-- | Sum type, with tags - GTagged variant +instance (style ~ GTagged key opts, GParseRecords style a, GetConstructorNames a, KnownSymbol key) => GParseRecords (GTagged key opts) (D1 m a) where gParseRecords opts context = Just . fmap M1 $ unsafeTaggedParser @style @key @a opts context --- | Sum type, with tags - GTaggedJSON1 variant -instance (style ~ GTaggedJSON1 key opts f, GParseRecords style a, GetConstructorNames a, KnownSymbol key) => GParseRecords (GTaggedJSON1 key opts f) (D1 m a) where +-- | Sum type, with tags - GTagged1 variant +instance (style ~ GTagged1 key opts f, GParseRecords style a, GetConstructorNames a, KnownSymbol key) => GParseRecords (GTagged1 key opts f) (D1 m a) where gParseRecords opts context = Just . fmap M1 $ unsafeTaggedParser @style @key @a opts context unsafeUntaggedParser :: forall style (f :: Type -> Type) a. (GParseRecords style f, FromJSON a) => TaggedOptions -> ParsingContext -> Parser (f a) @@ -352,41 +352,41 @@ unsafeUntaggedParser opts context = case gParseRecords @style @f opts context of Just parser -> parser Nothing -> error "unreachable" --- | Untagged variant - passes through without looking up a tag field (GUntaggedJSON) -instance (style ~ GUntaggedJSON opts, GParseRecords style a) => GParseRecords (GUntaggedJSON opts) (D1 m a) where +-- | Untagged variant - passes through without looking up a tag field (GUntagged) +instance (style ~ GUntagged opts, GParseRecords style a) => GParseRecords (GUntagged opts) (D1 m a) where gParseRecords opts context = Just . fmap M1 $ unsafeUntaggedParser @style @a opts context --- | Untagged variant - passes through without looking up a tag field (GUntaggedJSON1) -instance (style ~ GUntaggedJSON1 opts f, GParseRecords style a) => GParseRecords (GUntaggedJSON1 opts f) (D1 m a) where +-- | Untagged variant - passes through without looking up a tag field (GUntagged1) +instance (style ~ GUntagged1 opts f, GParseRecords style a) => GParseRecords (GUntagged1 opts f) (D1 m a) where gParseRecords opts context = Just . fmap M1 $ unsafeUntaggedParser @style @a opts context --- | Sum type constructor - GTaggedJSON variant -instance (style ~ GTaggedJSON key opts, Constructor m, GParseRecords style a) => GParseRecords (GTaggedJSON key opts) (C1 m a) where +-- | Sum type constructor - GTagged variant +instance (style ~ GTagged key opts, Constructor m, GParseRecords style a) => GParseRecords (GTagged key opts) (C1 m a) where gParseRecords opts context = if context.expectedTagValue == Just (constructorName @m opts) then fmap M1 <$> gParseRecords @style @a opts context else Nothing --- | Sum type constructor - GTaggedJSON1 variant -instance (style ~ GTaggedJSON1 key opts f, Constructor m, GParseRecords style a) => GParseRecords (GTaggedJSON1 key opts f) (C1 m a) where +-- | Sum type constructor - GTagged1 variant +instance (style ~ GTagged1 key opts f, Constructor m, GParseRecords style a) => GParseRecords (GTagged1 key opts f) (C1 m a) where gParseRecords opts context = if context.expectedTagValue == Just (constructorName @m opts) then fmap M1 <$> gParseRecords @style @a opts context else Nothing --- | Sum type constructor - GUntaggedJSON variant: always matches -instance (style ~ GUntaggedJSON opts, GParseRecords style a) => GParseRecords (GUntaggedJSON opts) (C1 m a) where +-- | Sum type constructor - GUntagged variant: always matches +instance (style ~ GUntagged opts, GParseRecords style a) => GParseRecords (GUntagged opts) (C1 m a) where gParseRecords opts context = fmap M1 <$> gParseRecords @style @a opts context --- | Sum type constructor - GUntaggedJSON1 variant: always matches -instance (style ~ GUntaggedJSON1 opts f, GParseRecords style a) => GParseRecords (GUntaggedJSON1 opts f) (C1 m a) where +-- | Sum type constructor - GUntagged1 variant: always matches +instance (style ~ GUntagged1 opts f, GParseRecords style a) => GParseRecords (GUntagged1 opts f) (C1 m a) where gParseRecords opts context = fmap M1 <$> gParseRecords @style @a opts context -instance (style ~ GTaggedJSON key opts, GParseRecords style a, GParseRecords style b) => GParseRecords (GTaggedJSON key opts) (a :+: b) where +instance (style ~ GTagged key opts, GParseRecords style a, GParseRecords style b) => GParseRecords (GTagged key opts) (a :+: b) where gParseRecords opts context = (fmap L1 <$> gParseRecords @style @a opts context) <|> (fmap R1 <$> gParseRecords @style @b opts context) -instance (style ~ GTaggedJSON1 key opts f, GParseRecords style a, GParseRecords style b) => GParseRecords (GTaggedJSON1 key opts f) (a :+: b) where +instance (style ~ GTagged1 key opts f, GParseRecords style a, GParseRecords style b) => GParseRecords (GTagged1 key opts f) (a :+: b) where gParseRecords opts context = (fmap L1 <$> gParseRecords @style @a opts context) <|> (fmap R1 <$> gParseRecords @style @b opts context) @@ -429,7 +429,7 @@ instance {-# OVERLAPPING #-} (KnownSymbol selectorName) => GParseRecords style ( where selectorKey = fieldKey @selectorName opts --- * FromJSON deriving for GTaggedJSON1 and GUntaggedJSON1 (Generic1 path) +-- * FromJSON deriving for GTagged1 and GUntagged1 (Generic1 path) genericParseJSON1 :: forall style (f :: Type -> Type) a. (Generic1 f, FromJSON a, GParseRecords style (Rep1 f)) => TaggedOptions -> Value -> Parser (f a) genericParseJSON1 opts = withObject "Object" $ \jsonObject -> @@ -439,21 +439,15 @@ genericParseJSON1 opts = withObject "Object" $ \jsonObject -> Just parser -> parser Nothing -> error "unreachable" -genericTaggedParseJSON1 :: forall key opts f a. (Generic1 f, FromJSON a, GParseRecords (GTaggedJSON1 key opts f) (Rep1 f)) => TaggedOptions -> Value -> Parser (GTaggedJSON1 key opts f a) -genericTaggedParseJSON1 opts = fmap GTaggedJSON1 . genericParseJSON1 @(GTaggedJSON1 key opts f) opts +instance (Generic1 f, FromJSON a, HasTaggedOptions opts, GParseRecords (GTagged1 key opts f) (Rep1 f)) => FromJSON (GTagged1 key opts f a) where + parseJSON = coerce (genericParseJSON1 @(GTagged1 key opts f) (taggedOptions @opts) :: Value -> Parser (f a)) -genericUntaggedParseJSON1 :: forall opts f a. (Generic1 f, FromJSON a, GParseRecords (GUntaggedJSON1 opts f) (Rep1 f)) => TaggedOptions -> Value -> Parser (GUntaggedJSON1 opts f a) -genericUntaggedParseJSON1 opts = fmap GUntaggedJSON1 . genericParseJSON1 @(GUntaggedJSON1 opts f) opts - -instance (Generic1 f, FromJSON a, HasTaggedOptions opts, GParseRecords (GTaggedJSON1 key opts f) (Rep1 f)) => FromJSON (GTaggedJSON1 key opts f a) where - parseJSON = genericTaggedParseJSON1 (taggedOptions @opts) - -instance (Generic1 f, FromJSON a, HasTaggedOptions opts, GParseRecords (GUntaggedJSON1 opts f) (Rep1 f)) => FromJSON (GUntaggedJSON1 opts f a) where - parseJSON = genericUntaggedParseJSON1 (taggedOptions @opts) +instance (Generic1 f, FromJSON a, HasTaggedOptions opts, GParseRecords (GUntagged1 opts f) (Rep1 f)) => FromJSON (GUntagged1 opts f a) where + parseJSON = coerce (genericParseJSON1 @(GUntagged1 opts f) (taggedOptions @opts) :: Value -> Parser (f a)) -- * ToSchema deriving --- | Set custom properties for the `Schema` derived via `GTaggedJSON`. +-- | Set custom properties for the `Schema` derived via `GTagged`. class SchemaDetails a where schemaName :: Maybe Text schemaName = Nothing @@ -474,14 +468,14 @@ class SchemaDetails a where schemaTagDescription :: Text -> Maybe Text schemaTagDescription = const Nothing -{- | Automatic deriving of `ToSchema` via `GTaggedJSON`. +{- | Automatic deriving of `ToSchema` via `GTagged`. `ToSchema` must be present for all sum constructor arguments. -} genericDeclareNamedSchema :: forall style a. (GToSchema style (Rep a), GetDataName (Rep a), ToJSON a, SchemaDetails a) => TaggedOptions -> Proxy a -> Declare (OpenApi.Definitions Schema) OpenApi.NamedSchema genericDeclareNamedSchema opts _proxy = do let name = fromMaybe (T.pack . opts.datatypeNameModifier $ getDataName @(Rep a)) (schemaName @a) - schema <- genSchema @style @(Rep a) (Proxy @GTaggedJSONParam) $ opts & #tagDescription .~ schemaTagDescription @a + schema <- genSchema @style @(Rep a) (Proxy @GTaggedParam) $ opts & #tagDescription .~ schemaTagDescription @a pure . OpenApi.NamedSchema (Just name) . schemaCustomize @a $ schema & #type ?~ OpenApiObject @@ -490,17 +484,17 @@ genericDeclareNamedSchema opts _proxy = do & #example .~ fmap toJSON (schemaExample @a) & #default .~ fmap toJSON (schemaDefault @a) -instance (style ~ GTaggedJSON key opts, Typeable (style a), HasTaggedOptions opts, SchemaDetails a, ToJSON a, GetDataName (Rep a), GToSchema style (Rep a)) => ToSchema (GTaggedJSON key opts a) where +instance (style ~ GTagged key opts, Typeable (style a), HasTaggedOptions opts, SchemaDetails a, ToJSON a, GetDataName (Rep a), GToSchema style (Rep a)) => ToSchema (GTagged key opts a) where declareNamedSchema _ = genericDeclareNamedSchema @style (taggedOptions @opts) (Proxy @a) -instance (style ~ GUntaggedJSON opts, Typeable (style a), HasTaggedOptions opts, SchemaDetails a, ToJSON a, GetDataName (Rep a), GToSchema style (Rep a)) => ToSchema (GUntaggedJSON opts a) where +instance (style ~ GUntagged opts, Typeable (style a), HasTaggedOptions opts, SchemaDetails a, ToJSON a, GetDataName (Rep a), GToSchema style (Rep a)) => ToSchema (GUntagged opts a) where declareNamedSchema _ = genericDeclareNamedSchema @style (taggedOptions @opts) (Proxy @a) {- | Generically derive a JSON `Schema`. The `Proxy a` argument and `ToSchema a` method constraint are consumed by the `Par1` and `Rec1 Maybe` leaf instances (Generic1 only). For the -`Generic` path the proxy is `Proxy @GTaggedJSONParam`, which is never +`Generic` path the proxy is `Proxy @GTaggedParam`, which is never inspected because `Rep a` never contains `Par1` or `Rec1` leaves. -} class GToSchema style (f :: Type -> Type) where @@ -533,45 +527,45 @@ constructorSchema opts key schema' = & #enum ?~ [String constName] & #description .~ opts.tagDescription constName --- | Single-constructor GTaggedJSON variant: adds tag info to the schema. -instance {-# OVERLAPPING #-} (style ~ GTaggedJSON key opts, Constructor m, GToSchema style a, KnownSymbol key) => GToSchema (GTaggedJSON key opts) (D1 _m (C1 m a)) where +-- | Single-constructor GTagged variant: adds tag info to the schema. +instance {-# OVERLAPPING #-} (style ~ GTagged key opts, Constructor m, GToSchema style a, KnownSymbol key) => GToSchema (GTagged key opts) (D1 _m (C1 m a)) where genSchema proxy opts = do childSchema <- genSchema @style @a proxy opts pure $ constructorSchema @m opts (mkTagKey @key) childSchema --- | Single-constructor GTaggedJSON1 variant: adds tag info to the schema. -instance {-# OVERLAPPING #-} (style ~ GTaggedJSON1 key opts f, Constructor m, GToSchema style a, KnownSymbol key) => GToSchema (GTaggedJSON1 key opts f) (D1 _m (C1 m a)) where +-- | Single-constructor GTagged1 variant: adds tag info to the schema. +instance {-# OVERLAPPING #-} (style ~ GTagged1 key opts f, Constructor m, GToSchema style a, KnownSymbol key) => GToSchema (GTagged1 key opts f) (D1 _m (C1 m a)) where genSchema proxy opts = do childSchema <- genSchema @style @a proxy opts pure $ constructorSchema @m opts (mkTagKey @key) childSchema --- | Single-constructor GUntaggedJSON variant: returns child schema as-is. -instance {-# OVERLAPPING #-} (style ~ GUntaggedJSON opts, GToSchema style a) => GToSchema (GUntaggedJSON opts) (D1 _m (C1 m a)) where +-- | Single-constructor GUntagged variant: returns child schema as-is. +instance {-# OVERLAPPING #-} (style ~ GUntagged opts, GToSchema style a) => GToSchema (GUntagged opts) (D1 _m (C1 m a)) where genSchema = genSchema @style @a --- | Single-constructor GUntaggedJSON1 variant: returns child schema as-is. -instance {-# OVERLAPPING #-} (style ~ GUntaggedJSON1 opts f, GToSchema style a) => GToSchema (GUntaggedJSON1 opts f) (D1 _m (C1 m a)) where +-- | Single-constructor GUntagged1 variant: returns child schema as-is. +instance {-# OVERLAPPING #-} (style ~ GUntagged1 opts f, GToSchema style a) => GToSchema (GUntagged1 opts f) (D1 _m (C1 m a)) where genSchema = genSchema @style @a --- | Multi-constructor GTaggedJSON variant. -instance (style ~ GTaggedJSON key opts, m ~ 'MetaCons n f s, Constructor m, GToSchema style a, KnownSymbol key) => GToSchema (GTaggedJSON key opts) (C1 m a) where +-- | Multi-constructor GTagged variant. +instance (style ~ GTagged key opts, m ~ 'MetaCons n f s, Constructor m, GToSchema style a, KnownSymbol key) => GToSchema (GTagged key opts) (C1 m a) where genSchema proxy opts = do childSchema <- genSchema @style @a proxy opts pure $ mempty & #oneOf ?~ [OpenApi.Inline $ constructorSchema @m opts (mkTagKey @key) childSchema] --- | Multi-constructor GTaggedJSON1 variant. -instance (style ~ GTaggedJSON1 key opts f, m ~ 'MetaCons n fixity s, Constructor m, GToSchema style a, KnownSymbol key) => GToSchema (GTaggedJSON1 key opts f) (C1 m a) where +-- | Multi-constructor GTagged1 variant. +instance (style ~ GTagged1 key opts f, m ~ 'MetaCons n fixity s, Constructor m, GToSchema style a, KnownSymbol key) => GToSchema (GTagged1 key opts f) (C1 m a) where genSchema proxy opts = do childSchema <- genSchema @style @a proxy opts pure $ mempty & #oneOf ?~ [OpenApi.Inline $ constructorSchema @m opts (mkTagKey @key) childSchema] -instance (style ~ GTaggedJSON key opts, GToSchema style a, GToSchema style b) => GToSchema (GTaggedJSON key opts) (a :+: b) where +instance (style ~ GTagged key opts, GToSchema style a, GToSchema style b) => GToSchema (GTagged key opts) (a :+: b) where genSchema proxy opts = do schemaL <- genSchema @style @a proxy opts schemaR <- genSchema @style @b proxy opts pure $ mempty & #oneOf ?~ fromMaybe [] (schemaL ^. #oneOf <> schemaR ^. #oneOf) -instance (style ~ GTaggedJSON1 key opts f, GToSchema style a, GToSchema style b) => GToSchema (GTaggedJSON1 key opts f) (a :+: b) where +instance (style ~ GTagged1 key opts f, GToSchema style a, GToSchema style b) => GToSchema (GTagged1 key opts f) (a :+: b) where genSchema proxy opts = do schemaL <- genSchema @style @a proxy opts schemaR <- genSchema @style @b proxy opts @@ -627,7 +621,7 @@ instance {-# OVERLAPPING #-} (KnownSymbol selectorName) => GToSchema style (S1 ( where selectorKey = Key.toText $ fieldKey @selectorName opts --- * ToSchema deriving for GTaggedJSON1 and GUntaggedJSON1 (Generic1 path) +-- * ToSchema deriving for GTagged1 and GUntagged1 (Generic1 path) genericLiftDeclareNamedSchema :: forall gstyle1 f a b. (b ~ f a, GToSchema gstyle1 (Rep1 f), GetDataName (Rep1 f), ToJSON b, ToSchema a, SchemaDetails b) => TaggedOptions -> Proxy a -> Declare (OpenApi.Definitions Schema) OpenApi.NamedSchema genericLiftDeclareNamedSchema opts _proxy = do @@ -641,10 +635,10 @@ genericLiftDeclareNamedSchema opts _proxy = do & #example .~ fmap toJSON (schemaExample @b) & #default .~ fmap toJSON (schemaDefault @b) -instance (style ~ GTaggedJSON1 key opts f, Typeable (style a), HasTaggedOptions opts, GToSchema style (Rep1 f), GetDataName (Rep1 f), ToJSON (f a), ToSchema a, SchemaDetails (f a)) => ToSchema (GTaggedJSON1 key opts f a) where +instance (style ~ GTagged1 key opts f, Typeable (style a), HasTaggedOptions opts, GToSchema style (Rep1 f), GetDataName (Rep1 f), ToJSON (f a), ToSchema a, SchemaDetails (f a)) => ToSchema (GTagged1 key opts f a) where declareNamedSchema _ = genericLiftDeclareNamedSchema @style @f (taggedOptions @opts) (Proxy @a) -instance (style ~ GUntaggedJSON1 opts f, Typeable (style a), HasTaggedOptions opts, GToSchema style (Rep1 f), GetDataName (Rep1 f), ToJSON (f a), ToSchema a, SchemaDetails (f a)) => ToSchema (GUntaggedJSON1 opts f a) where +instance (style ~ GUntagged1 opts f, Typeable (style a), HasTaggedOptions opts, GToSchema style (Rep1 f), GetDataName (Rep1 f), ToJSON (f a), ToSchema a, SchemaDetails (f a)) => ToSchema (GUntagged1 opts f a) where declareNamedSchema _ = genericLiftDeclareNamedSchema @style @f (taggedOptions @opts) (Proxy @a) -- * Internal functions, classes and instances @@ -679,15 +673,15 @@ driving 'GSerializeRecords', 'GParseRecords', and 'GToSchema' from the 'Generic' path. Its instances are never called because @Rep a@ never contains 'Par1' or 'Rec1' leaves. -} -data GTaggedJSONParam +data GTaggedParam -instance ToJSON GTaggedJSONParam where +instance ToJSON GTaggedParam where toJSON = \case {} -instance FromJSON GTaggedJSONParam where - parseJSON _ = fail "GTaggedJSONParam: unreachable" +instance FromJSON GTaggedParam where + parseJSON _ = fail "GTaggedParam: unreachable" -instance ToSchema GTaggedJSONParam where +instance ToSchema GTaggedParam where declareNamedSchema _ = pure $ OpenApi.NamedSchema Nothing mempty {- | Because the `aeson` library has two ways of serializing (either diff --git a/test/Main.hs b/test/Main.hs index b3ee8b1..94038ab 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -396,7 +396,7 @@ instance HasTaggedOptions (WithNameModifierOption 'True) where instance HasTaggedOptions (WithNameModifierOption 'False) where taggedOptions = defaultTaggedOptions {Tagged.datatypeNameModifier = id} -type WithNameModifierTaggedJSON bool = GUntaggedJSON (WithNameModifierOption bool) +type WithNameModifierTaggedJSON bool = GUntagged (WithNameModifierOption bool) newtype UnmodifiedSchemaName = UnmodifiedSchemaName {a :: Int} deriving stock (Eq, Show, Generic) @@ -501,7 +501,7 @@ instance HasTaggedOptions (OmitNothingOption 'True) where instance HasTaggedOptions (OmitNothingOption 'False) where taggedOptions = defaultTaggedOptions {Tagged.omitNothingFields = False} -type OmitNothingTaggedJSON onf = GUntaggedJSON (OmitNothingOption onf) +type OmitNothingTaggedJSON onf = GUntagged (OmitNothingOption onf) data OmitNothingFields = OmitNothingFields { hello :: Maybe Int diff --git a/test/TestTaggedJson.hs b/test/TestTaggedJson.hs index f3f640c..d499ff7 100644 --- a/test/TestTaggedJson.hs +++ b/test/TestTaggedJson.hs @@ -19,10 +19,10 @@ snakeCase :: String -> String snakeCase = camelTo2 '_' data Opts (prefix :: Symbol) -type Tagged prefix tagKey = GTaggedJSON tagKey (Opts prefix) -type Untagged prefix = GUntaggedJSON (Opts prefix) -type Tagged1 prefix tagKey = GTaggedJSON1 tagKey (Opts prefix) -type Untagged1 prefix = GUntaggedJSON1 (Opts prefix) +type Tagged prefix tagKey = GTagged tagKey (Opts prefix) +type Untagged prefix = GUntagged (Opts prefix) +type Tagged1 prefix tagKey = GTagged1 tagKey (Opts prefix) +type Untagged1 prefix = GUntagged1 (Opts prefix) exampleTaggedOptions :: String -> TaggedOptions exampleTaggedOptions prefix = @@ -50,4 +50,4 @@ instance , datatypeNameModifier = snakeCase } -type DualPrefixTagged fp cp tag = GTaggedJSON tag (DualPrefixOptions fp cp) +type DualPrefixTagged fp cp tag = GTagged tag (DualPrefixOptions fp cp) From 0c5bbea59d3b6a6c9f3fe322bda2a70758729e91 Mon Sep 17 00:00:00 2001 From: Giorgio Marinelli Date: Sat, 25 Apr 2026 19:08:36 +0200 Subject: [PATCH 3/6] More clean-up --- src/Deriving/TaggedJson.hs | 63 +++++++++++++++++--------------------- 1 file changed, 28 insertions(+), 35 deletions(-) diff --git a/src/Deriving/TaggedJson.hs b/src/Deriving/TaggedJson.hs index 2e13d47..becb63c 100644 --- a/src/Deriving/TaggedJson.hs +++ b/src/Deriving/TaggedJson.hs @@ -17,10 +17,11 @@ module Deriving.TaggedJson ( genericToPairs, genericToSeries, genericDeclareNamedSchema, - genericLiftToPairs, - genericLiftToSeries, + genericLiftParseJSON, genericLiftToJSON, genericLiftToEncoding, + genericLiftToPairs, + genericLiftToSeries, genericLiftDeclareNamedSchema, -- re-export some Data.Aeson.Key definitions Key, @@ -31,7 +32,7 @@ where import Control.Applicative import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap -import Data.Aeson.Types hiding (genericLiftToEncoding, genericLiftToJSON, genericParseJSON, genericToEncoding, genericToJSON) +import Data.Aeson.Types hiding (genericLiftParseJSON, genericLiftToEncoding, genericLiftToJSON, genericParseJSON, genericToEncoding, genericToJSON) import Data.Coerce import Data.Kind import Data.List (intercalate) @@ -300,9 +301,7 @@ genericParseJSON :: forall style a. (Generic a, GParseRecords style (Rep a)) => genericParseJSON opts = withObject "Object" $ \jsonObject -> to <$> do let context = ParsingContext {expectedTagValue = Nothing, jsonObject} - case gParseRecords @style @(Rep a) @GTaggedParam opts context of - Just parser -> parser - Nothing -> error "unreachable" + gParseRecordsOrFail @style @(Rep a) @GTaggedParam opts context "unreachable" instance (Generic a, HasTaggedOptions opts, GParseRecords (GTagged key opts) (Rep a)) => FromJSON (GTagged key opts a) where parseJSON = coerce (genericParseJSON @(GTagged key opts) (taggedOptions @opts) :: Value -> Parser a) @@ -320,20 +319,21 @@ data ParsingContext = ParsingContext class GParseRecords style (f :: Type -> Type) where gParseRecords :: (FromJSON a) => TaggedOptions -> ParsingContext -> Maybe (Parser (f a)) -unsafeTaggedParser :: forall style (key :: Symbol) (f :: Type -> Type) a. (GParseRecords style f, KnownSymbol key, FromJSON a, GetConstructorNames f) => TaggedOptions -> ParsingContext -> Parser (f a) -unsafeTaggedParser opts context = do - let tagKey = mkTagKey @key +gParseRecordsOrFail :: forall style (f :: Type -> Type) a. (GParseRecords style f, FromJSON a) => TaggedOptions -> ParsingContext -> String {- error message -} -> Parser (f a) +gParseRecordsOrFail opts context message = case gParseRecords @style @f opts context of + Just parser -> parser + Nothing -> fail message + +gParseRecordsWithTag :: forall style (f :: Type -> Type) a. (GParseRecords style f, FromJSON a, GetConstructorNames f) => TaggedOptions -> ParsingContext -> Key -> Parser (f a) +gParseRecordsWithTag opts context tagKey = do tagVal <- context.jsonObject .:? tagKey - case gParseRecords @style @f opts (context {expectedTagValue = tagVal}) of - Just parser -> parser - Nothing -> - fail $ - "encountered tag " - <> show (Key.toString tagKey) - <> " with value " - <> show' tagVal - <> "; expected one of: " - <> intercalate ", " (show . opts.constructorTagModifier <$> getConstructorNames @f) + gParseRecordsOrFail @style @f opts context {expectedTagValue = tagVal} $ + "encountered tag " + <> show (Key.toString tagKey) + <> " with value " + <> show' tagVal + <> "; expected one of: " + <> intercalate ", " (show . opts.constructorTagModifier <$> getConstructorNames @f) where -- TODO: Improve error message show' :: Maybe String -> String @@ -341,24 +341,19 @@ unsafeTaggedParser opts context = do -- | Sum type, with tags - GTagged variant instance (style ~ GTagged key opts, GParseRecords style a, GetConstructorNames a, KnownSymbol key) => GParseRecords (GTagged key opts) (D1 m a) where - gParseRecords opts context = Just . fmap M1 $ unsafeTaggedParser @style @key @a opts context + gParseRecords opts context = Just . fmap M1 $ gParseRecordsWithTag @style @a opts context (mkTagKey @key) -- | Sum type, with tags - GTagged1 variant instance (style ~ GTagged1 key opts f, GParseRecords style a, GetConstructorNames a, KnownSymbol key) => GParseRecords (GTagged1 key opts f) (D1 m a) where - gParseRecords opts context = Just . fmap M1 $ unsafeTaggedParser @style @key @a opts context - -unsafeUntaggedParser :: forall style (f :: Type -> Type) a. (GParseRecords style f, FromJSON a) => TaggedOptions -> ParsingContext -> Parser (f a) -unsafeUntaggedParser opts context = case gParseRecords @style @f opts context of - Just parser -> parser - Nothing -> error "unreachable" + gParseRecords opts context = Just . fmap M1 $ gParseRecordsWithTag @style @a opts context (mkTagKey @key) -- | Untagged variant - passes through without looking up a tag field (GUntagged) instance (style ~ GUntagged opts, GParseRecords style a) => GParseRecords (GUntagged opts) (D1 m a) where - gParseRecords opts context = Just . fmap M1 $ unsafeUntaggedParser @style @a opts context + gParseRecords opts context = Just . fmap M1 $ gParseRecordsOrFail @style @a opts context "unreachable" -- | Untagged variant - passes through without looking up a tag field (GUntagged1) instance (style ~ GUntagged1 opts f, GParseRecords style a) => GParseRecords (GUntagged1 opts f) (D1 m a) where - gParseRecords opts context = Just . fmap M1 $ unsafeUntaggedParser @style @a opts context + gParseRecords opts context = Just . fmap M1 $ gParseRecordsOrFail @style @a opts context "unreachable" -- | Sum type constructor - GTagged variant instance (style ~ GTagged key opts, Constructor m, GParseRecords style a) => GParseRecords (GTagged key opts) (C1 m a) where @@ -431,19 +426,17 @@ instance {-# OVERLAPPING #-} (KnownSymbol selectorName) => GParseRecords style ( -- * FromJSON deriving for GTagged1 and GUntagged1 (Generic1 path) -genericParseJSON1 :: forall style (f :: Type -> Type) a. (Generic1 f, FromJSON a, GParseRecords style (Rep1 f)) => TaggedOptions -> Value -> Parser (f a) -genericParseJSON1 opts = withObject "Object" $ \jsonObject -> +genericLiftParseJSON :: forall style (f :: Type -> Type) a. (Generic1 f, FromJSON a, GParseRecords style (Rep1 f)) => TaggedOptions -> Value -> Parser (f a) +genericLiftParseJSON opts = withObject "Object" $ \jsonObject -> to1 <$> do let context = ParsingContext {expectedTagValue = Nothing, jsonObject} - case gParseRecords @style @(Rep1 f) opts context of - Just parser -> parser - Nothing -> error "unreachable" + gParseRecordsOrFail @style @(Rep1 f) opts context "unreachable" instance (Generic1 f, FromJSON a, HasTaggedOptions opts, GParseRecords (GTagged1 key opts f) (Rep1 f)) => FromJSON (GTagged1 key opts f a) where - parseJSON = coerce (genericParseJSON1 @(GTagged1 key opts f) (taggedOptions @opts) :: Value -> Parser (f a)) + parseJSON = coerce (genericLiftParseJSON @(GTagged1 key opts f) (taggedOptions @opts) :: Value -> Parser (f a)) instance (Generic1 f, FromJSON a, HasTaggedOptions opts, GParseRecords (GUntagged1 opts f) (Rep1 f)) => FromJSON (GUntagged1 opts f a) where - parseJSON = coerce (genericParseJSON1 @(GUntagged1 opts f) (taggedOptions @opts) :: Value -> Parser (f a)) + parseJSON = coerce (genericLiftParseJSON @(GUntagged1 opts f) (taggedOptions @opts) :: Value -> Parser (f a)) -- * ToSchema deriving From bbed1b9a382b03cdd9156426f4607be8186f87d9 Mon Sep 17 00:00:00 2001 From: Giorgio Marinelli Date: Sat, 25 Apr 2026 19:18:18 +0200 Subject: [PATCH 4/6] More clean-up --- src/Deriving/TaggedJson.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Deriving/TaggedJson.hs b/src/Deriving/TaggedJson.hs index becb63c..81d3447 100644 --- a/src/Deriving/TaggedJson.hs +++ b/src/Deriving/TaggedJson.hs @@ -327,17 +327,17 @@ gParseRecordsOrFail opts context message = case gParseRecords @style @f opts con gParseRecordsWithTag :: forall style (f :: Type -> Type) a. (GParseRecords style f, FromJSON a, GetConstructorNames f) => TaggedOptions -> ParsingContext -> Key -> Parser (f a) gParseRecordsWithTag opts context tagKey = do tagVal <- context.jsonObject .:? tagKey - gParseRecordsOrFail @style @f opts context {expectedTagValue = tagVal} $ - "encountered tag " - <> show (Key.toString tagKey) - <> " with value " - <> show' tagVal - <> "; expected one of: " - <> intercalate ", " (show . opts.constructorTagModifier <$> getConstructorNames @f) + gParseRecordsOrFail @style @f opts context {expectedTagValue = tagVal} (message tagVal) where - -- TODO: Improve error message - show' :: Maybe String -> String - show' = \case Nothing -> "Nothing"; Just k -> show k + message = \case + Nothing -> "no tag with key " <> show (Key.toString tagKey) + Just val -> + "encountered tag " + <> show (Key.toString tagKey) + <> " with value " + <> show val + <> "; expected one of: " + <> intercalate ", " (show . opts.constructorTagModifier <$> getConstructorNames @f) -- | Sum type, with tags - GTagged variant instance (style ~ GTagged key opts, GParseRecords style a, GetConstructorNames a, KnownSymbol key) => GParseRecords (GTagged key opts) (D1 m a) where From 7f54d5aacee5d34b24c971304a745c52663f08b2 Mon Sep 17 00:00:00 2001 From: Giorgio Marinelli Date: Sat, 25 Apr 2026 19:21:41 +0200 Subject: [PATCH 5/6] Revert some changes --- src/Deriving/TaggedJson.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Deriving/TaggedJson.hs b/src/Deriving/TaggedJson.hs index 81d3447..2698491 100644 --- a/src/Deriving/TaggedJson.hs +++ b/src/Deriving/TaggedJson.hs @@ -227,12 +227,12 @@ instance (Monoid (SerializationType s), GSerializeRecords style s a, GSerializeR gSerializeRecords opts (a :*: b) = gSerializeRecords @style @s opts a <> gSerializeRecords @style @s opts b instance (Monoid (SerializationType s)) => GSerializeRecords style s U1 where - gSerializeRecords _options U1 = mempty + gSerializeRecords _ U1 = mempty -- Rec0 (concrete field) instances -- instance (SerializationKind s, ToKeyMap a) => GSerializeRecords style s (S1 ('MetaSel 'Nothing u s' d) (Rec0 a)) where - gSerializeRecords _options (M1 (K1 x)) = mkPairs @s x + gSerializeRecords _ (M1 (K1 x)) = mkPairs @s x instance (SerializationKind s, KnownSymbol selectorName, ToJSON a) => GSerializeRecords style s (S1 ('MetaSel ('Just selectorName) u s' d) (Rec0 a)) where gSerializeRecords opts selector = mkPair @s selectorKey selectorVal @@ -265,7 +265,7 @@ type Generic1WithoutSelectorErrorMessage = instance (TypeError Generic1WithoutSelectorErrorMessage) => GSerializeRecords style s (S1 ('MetaSel Nothing u s' d) Par1) where gSerializeRecords :: TaggedOptions -> S1 ('MetaSel Nothing u s' d) Par1 a -> SerializationType s - gSerializeRecords _options = generic1NoSelectorError + gSerializeRecords _ = generic1NoSelectorError instance (SerializationKind s, KnownSymbol selectorName) => GSerializeRecords style s (S1 ('MetaSel ('Just selectorName) u s' d) Par1) where gSerializeRecords :: forall a. (ToJSON a) => TaggedOptions -> S1 ('MetaSel ('Just selectorName) u s' d) Par1 a -> SerializationType s @@ -392,12 +392,12 @@ instance (GParseRecords style a, GParseRecords style b) => GParseRecords style ( pure $ (:*:) <$> x <*> y instance GParseRecords style U1 where - gParseRecords _options _context = pure $ pure U1 + gParseRecords _ _ = pure $ pure U1 -- Rec0 (concrete field) instances -- instance (FromJSON a) => GParseRecords style (S1 ('MetaSel 'Nothing u s' d) (Rec0 a)) where - gParseRecords _options context = Just $ M1 . K1 <$> parseJSON (Object context.jsonObject) + gParseRecords _ context = Just $ M1 . K1 <$> parseJSON (Object context.jsonObject) instance {-# OVERLAPPING #-} (KnownSymbol selectorName, FromJSON a) => GParseRecords style (S1 ('MetaSel ('Just selectorName) u s' d) (Rec0 (Maybe a))) where gParseRecords opts context = Just $ M1 . K1 <$> context.jsonObject .:? selectorKey @@ -466,7 +466,7 @@ class SchemaDetails a where `ToSchema` must be present for all sum constructor arguments. -} genericDeclareNamedSchema :: forall style a. (GToSchema style (Rep a), GetDataName (Rep a), ToJSON a, SchemaDetails a) => TaggedOptions -> Proxy a -> Declare (OpenApi.Definitions Schema) OpenApi.NamedSchema -genericDeclareNamedSchema opts _proxy = do +genericDeclareNamedSchema opts _ = do let name = fromMaybe (T.pack . opts.datatypeNameModifier $ getDataName @(Rep a)) (schemaName @a) schema <- genSchema @style @(Rep a) (Proxy @GTaggedParam) $ opts & #tagDescription .~ schemaTagDescription @a pure . OpenApi.NamedSchema (Just name) . schemaCustomize @a $ @@ -617,7 +617,7 @@ instance {-# OVERLAPPING #-} (KnownSymbol selectorName) => GToSchema style (S1 ( -- * ToSchema deriving for GTagged1 and GUntagged1 (Generic1 path) genericLiftDeclareNamedSchema :: forall gstyle1 f a b. (b ~ f a, GToSchema gstyle1 (Rep1 f), GetDataName (Rep1 f), ToJSON b, ToSchema a, SchemaDetails b) => TaggedOptions -> Proxy a -> Declare (OpenApi.Definitions Schema) OpenApi.NamedSchema -genericLiftDeclareNamedSchema opts _proxy = do +genericLiftDeclareNamedSchema opts _ = do let name = fromMaybe (T.pack . opts.datatypeNameModifier $ getDataName @(Rep1 f)) (schemaName @b) schema <- genSchema @gstyle1 @(Rep1 f) (Proxy @a) $ opts & #tagDescription .~ schemaTagDescription @b pure . OpenApi.NamedSchema (Just name) . schemaCustomize @b $ From 11db66a72d40aa580eea990e9d2f9b327aee393f Mon Sep 17 00:00:00 2001 From: Giorgio Marinelli Date: Sat, 25 Apr 2026 19:32:54 +0200 Subject: [PATCH 6/6] Simplify fourmolu.yaml --- fourmolu.yaml | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) diff --git a/fourmolu.yaml b/fourmolu.yaml index f820abb..e43d55a 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -72,18 +72,7 @@ fixities: [] # Module reexports Fourmolu should know about reexports: - - module Prelude exports "base" Control.Applicative - - module Prelude exports "base" Control.Monad - - module Prelude exports "base" Data.Bool - - module Prelude exports "base" Data.Eq - module Prelude exports "base" Data.Function - - module Prelude exports "base" Data.Functor - - module Prelude exports "base" Data.List - - module Prelude exports "base" Data.Ord - - module Prelude exports "base" GHC.Base - - module Prelude exports "base" GHC.Num - - module Prelude exports "base" GHC.Real - - module Prelude exports "optics-core" Optics.Operators # Modules defined by the current Cabal package for import grouping -local-modules: [] +local-modules: []