diff --git a/registry-aeson.cabal b/registry-aeson.cabal --- a/registry-aeson.cabal +++ b/registry-aeson.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: registry-aeson -version: 0.2.2.0 +version: 0.2.3.0 synopsis: Aeson encoders / decoders description: This library provides encoders / decoders which can be easily customized for the Aeson format. category: Data @@ -27,40 +27,25 @@ Data.Registry.Aeson.TH.Decoder Data.Registry.Aeson.TH.Encoder Data.Registry.Aeson.TH.TH + Data.Registry.Aeson.TH.ThOptions other-modules: Paths_registry_aeson hs-source-dirs: src default-extensions: - BangPatterns DefaultSignatures - EmptyCase - ExistentialQuantification - FlexibleContexts - FlexibleInstances + DerivingStrategies FunctionalDependencies GADTs - DerivingVia - DerivingStrategies - InstanceSigs - KindSignatures LambdaCase - MultiParamTypeClasses MultiWayIf - NamedFieldPuns NoImplicitPrelude OverloadedStrings PatternSynonyms - Rank2Types - RankNTypes - ScopedTypeVariables - StandaloneDeriving + StrictData TemplateHaskell - TupleSections - TypeApplications TypeFamilies TypeFamilyDependencies - TypeOperators ghc-options: -Wall -Wcompat -Wincomplete-record-updates -fhide-source-paths -fprint-potential-instances -fno-warn-partial-type-signatures -optP-Wno-nonportable-include-path -Wincomplete-uni-patterns build-depends: aeson ==2.* @@ -74,7 +59,7 @@ , transformers >=0.5 && <2 , unordered-containers >=0.2 && <1 , vector >=0.1 && <1 - default-language: Haskell2010 + default-language: GHC2021 test-suite spec type: exitcode-stdio-1.0 @@ -87,39 +72,24 @@ Test.Data.Registry.Aeson.RecursiveSpec Test.Data.Registry.Aeson.RoundtripData Test.Data.Registry.Aeson.RoundtripSpec + Test.Data.Registry.Aeson.SimilarDataTypes Paths_registry_aeson hs-source-dirs: test default-extensions: - BangPatterns DefaultSignatures - EmptyCase - ExistentialQuantification - FlexibleContexts - FlexibleInstances + DerivingStrategies FunctionalDependencies GADTs - DerivingVia - DerivingStrategies - InstanceSigs - KindSignatures LambdaCase - MultiParamTypeClasses MultiWayIf - NamedFieldPuns NoImplicitPrelude OverloadedStrings PatternSynonyms - Rank2Types - RankNTypes - ScopedTypeVariables - StandaloneDeriving + StrictData TemplateHaskell - TupleSections - TypeApplications TypeFamilies TypeFamilyDependencies - TypeOperators ghc-options: -Wall -Wcompat -Wincomplete-record-updates -fhide-source-paths -fprint-potential-instances -fno-warn-partial-type-signatures -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans -fno-warn-missing-signatures -fno-warn-incomplete-uni-patterns -fno-warn-type-defaults -optP-Wno-nonportable-include-path build-depends: aeson ==2.* @@ -138,4 +108,4 @@ , transformers >=0.5 && <2 , unordered-containers >=0.2 && <1 , vector >=0.1 && <1 - default-language: Haskell2010 + default-language: GHC2021 diff --git a/src/Data/Registry/Aeson/Decoder.hs b/src/Data/Registry/Aeson/Decoder.hs --- a/src/Data/Registry/Aeson/Decoder.hs +++ b/src/Data/Registry/Aeson/Decoder.hs @@ -12,19 +12,21 @@ module Data.Registry.Aeson.Decoder ( module Data.Registry.Aeson.Decoder, module Data.Registry.Aeson.TH.Decoder, + module Data.Registry.Aeson.TH.ThOptions, ) where import Data.Aeson -import qualified Data.Aeson.Key as K -import qualified Data.Aeson.KeyMap as KM -import qualified Data.ByteString.Lazy as BL +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy qualified as BL import Data.List ((\\)) import Data.Registry import Data.Registry.Aeson.TH.Decoder -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Vector as Vector +import Data.Registry.Aeson.TH.ThOptions +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Vector qualified as Vector import Protolude as P hiding (Type) import Prelude (String, show) @@ -242,7 +244,7 @@ -- if there is only one constructor and tagging is not required (and nullary constructors must be tagged) [c] | not (tagSingleConstructors options) && not (isEnumeration && not (allNullaryToStringTag options)) -> - pure <$> makeToConstructorFromValue options c value + pure <$> makeToConstructorFromValue options c value _ -> do maybe (pure ()) Left $ checkSumEncoding options constructors value case sumEncoding options of @@ -268,34 +270,34 @@ -- constructor with no fields ([], [], []) | tagValue == String modifiedConstructorName -> - pure $ ToConstructor constructorName [] + pure $ ToConstructor constructorName [] -- constructor with one unnamed field ([], [], [_]) | tagValue == String modifiedConstructorName -> - case KM.lookup (K.fromText contentsFieldName) vs of - Just fieldValue -> pure $ ToConstructor constructorName [(Nothing, fieldValue)] - Nothing -> Left $ "field " <> contentsFieldName <> " not found" + case KM.lookup (K.fromText contentsFieldName) vs of + Just fieldValue -> pure $ ToConstructor constructorName [(Nothing, fieldValue)] + Nothing -> Left $ "field " <> contentsFieldName <> " not found" -- constructor with one named field ([modifiedFieldName], [fieldName], [fieldType]) | tagValue == String modifiedConstructorName -> - case KM.lookup (K.fromText modifiedFieldName) vs of - Just fieldValue -> pure $ ToConstructor constructorName [(Just (fieldName, fieldType), fieldValue)] - Nothing -> Left $ "field " <> modifiedFieldName <> " not found" + case KM.lookup (K.fromText modifiedFieldName) vs of + Just fieldValue -> pure $ ToConstructor constructorName [(Just (fieldName, fieldType), fieldValue)] + Nothing -> Left $ "field " <> modifiedFieldName <> " not found" -- constructor with at least one named field and possibly Nothing fields (_, _, _) | tagValue == String modifiedConstructorName && omitNothingFields options && any (`elem` modifiedFieldNames) (K.toText <$> KM.keys vs) -> do - let rest = KM.fromList $ filter ((/= tagFieldName) . K.toText . fst) $ KM.toList vs - makeToConstructorFromValue options c (Object rest) + let rest = KM.fromList $ filter ((/= tagFieldName) . K.toText . fst) $ KM.toList vs + makeToConstructorFromValue options c (Object rest) -- constructor with several named fields (_, _ : _, _) | tagValue == String modifiedConstructorName -> - makeToConstructorFromValue options c value + makeToConstructorFromValue options c value -- constructor with no named fields (_, _, _) | tagValue == String modifiedConstructorName && any (== contentsFieldName) (K.toText <$> KM.keys vs) -> - case KM.lookup (K.fromText contentsFieldName) vs of - Just contentsValue -> makeToConstructorFromValue options c contentsValue - _ -> Left $ "contents field not found '" <> contentsFieldName <> "'" + case KM.lookup (K.fromText contentsFieldName) vs of + Just contentsValue -> makeToConstructorFromValue options c contentsValue + _ -> Left $ "contents field not found '" <> contentsFieldName <> "'" (_, _, _) -> Left $ "failed to instantiate constructor: " <> P.show c Nothing -> @@ -319,10 +321,10 @@ case value of Object [(tagValue, contents)] | K.toText tagValue == modifiedConstructorName -> - makeToConstructorFromValue options c contents + makeToConstructorFromValue options c contents String v | v == modifiedConstructorName -> - makeToConstructorFromValue options c value + makeToConstructorFromValue options c value _ -> Left $ "failed to instantiate constructor: " <> P.show c @@ -334,10 +336,10 @@ case value of Array [tagValue, contents] | tagValue == String modifiedConstructorName -> - makeToConstructorFromValue options c contents + makeToConstructorFromValue options c contents String v | v == modifiedConstructorName -> - makeToConstructorFromValue options c value + makeToConstructorFromValue options c value _ -> Left $ "failed to instantiate constructor: " <> P.show c @@ -355,7 +357,7 @@ Just $ "tag field '" <> tagFieldName <> "' not found" Just (String tagValue) | tagValue `elem` constructorModifiedNames -> - Nothing + Nothing Just v -> unexpectedConstructor constructorModifiedNames v _ -> Just "expected an Object for a TaggedObject sum encoding" diff --git a/src/Data/Registry/Aeson/Encoder.hs b/src/Data/Registry/Aeson/Encoder.hs --- a/src/Data/Registry/Aeson/Encoder.hs +++ b/src/Data/Registry/Aeson/Encoder.hs @@ -11,18 +11,20 @@ module Data.Registry.Aeson.Encoder ( module Data.Registry.Aeson.Encoder, module Data.Registry.Aeson.TH.Encoder, + module Data.Registry.Aeson.TH.ThOptions, ) where import Data.Aeson import Data.Aeson.Encoding.Internal -import qualified Data.Aeson.Key as K -import qualified Data.Aeson.KeyMap as KM -import qualified Data.ByteString.Lazy as BL (toStrict) +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy qualified as BL (toStrict) import Data.Functor.Contravariant import Data.Registry import Data.Registry.Aeson.TH.Encoder -import qualified Data.Vector as V +import Data.Registry.Aeson.TH.ThOptions +import Data.Vector qualified as V import Protolude hiding (Type, list) -- * ENCODER DATA TYPE @@ -201,7 +203,7 @@ case (vs, es) of ([v], [e]) | unwrapUnaryRecords options -> - (array [String constructorTag, v], list identity [string $ toS constructorTag, e]) + (array [String constructorTag, v], list identity [string $ toS constructorTag, e]) _ -> do let (vs', es') = valuesToObject fieldNames values (array [String constructorTag, vs'], list identity [string $ toS constructorTag, es']) @@ -218,7 +220,7 @@ case (vs, es) of ([v], [e]) | unwrapUnaryRecords options -> - (Object $ KM.singleton (K.fromText constructorTag) v, pairs (pair (K.fromText constructorTag) e)) + (Object $ KM.singleton (K.fromText constructorTag) v, pairs (pair (K.fromText constructorTag) e)) _ -> do let (vs', es') = valuesToObject fieldNames values (Object $ KM.singleton (K.fromText constructorTag) vs', pairs (pair (K.fromText constructorTag) es')) diff --git a/src/Data/Registry/Aeson/TH/Decoder.hs b/src/Data/Registry/Aeson/TH/Decoder.hs --- a/src/Data/Registry/Aeson/TH/Decoder.hs +++ b/src/Data/Registry/Aeson/TH/Decoder.hs @@ -1,8 +1,10 @@ {-# OPTIONS_GHC -Wno-type-defaults #-} + module Data.Registry.Aeson.TH.Decoder where import Control.Monad.Fail import Data.List (nub) +import Data.Registry.Aeson.TH.ThOptions import Data.Registry.Aeson.TH.TH import Language.Haskell.TH import Language.Haskell.TH.Syntax @@ -13,20 +15,39 @@ build a Decoder based on configuration options -} --- | Make a Decoder for a given data type --- Usage: $(makeDecoder ''MyDataType <: otherDecoders) +-- | Make an Encoder for a given data type +-- Usage: $(makeDecoder ''MyDataType <: otherEncoders) makeDecoder :: Name -> ExpQ -makeDecoder typeName = appE (varE $ mkName "fun") $ do +makeDecoder = makeDecoderWith defaultThOptions + +-- | Make an Encoder for a given data type, where all types names are qualified with their module full name +-- -- MyDataType is defined in X.Y.Z +-- import X.Y.Z qualified +-- $(makeDecoderQualified ''MyDataType <: otherEncoders) +makeDecoderQualified :: Name -> ExpQ +makeDecoderQualified = makeDecoderWith (ThOptions qualified) + +-- | Make an Encoder for a given data type, where all types names are qualified with their module name +-- -- MyDataType is defined in X.Y.Z +-- import X.Y.Z qualified as Z +-- $(makeDecoderQualifiedLast ''MyDataType <: otherEncoders) +makeDecoderQualifiedLast :: Name -> ExpQ +makeDecoderQualifiedLast = makeDecoderWith (ThOptions qualifyWithLastName) + +-- | Make a Decoder for a given data type and pass options to specify how names must be qualified +-- Usage: $(makeDecoderWith options ''MyDataType <: otherDecoders) +makeDecoderWith :: ThOptions -> Name -> ExpQ +makeDecoderWith thOptions typeName = appE (varE $ mkName "fun") $ do info <- reify typeName case info of TyConI (NewtypeD _context _name _typeVars _kind constructor _deriving) -> - makeConstructorsDecoder typeName [constructor] + makeConstructorsDecoder thOptions typeName [constructor] TyConI (DataD _context _name _typeVars _kind constructors _deriving) -> do case constructors of [] -> do qReport True "can not make an Decoder for an empty data type" fail "decoders creation failed" - _ -> makeConstructorsDecoder typeName constructors + _ -> makeConstructorsDecoder thOptions typeName constructors other -> do qReport True ("can only create decoders for an ADT, got: " <> P.show other) fail "decoders creation failed" @@ -48,33 +69,33 @@ -- -- The \case function is the only one which needs to be generated in order to match the exact shape of the -- constructors to instantiate -makeConstructorsDecoder :: Name -> [Con] -> ExpQ -makeConstructorsDecoder typeName cs = do +makeConstructorsDecoder :: ThOptions -> Name -> [Con] -> ExpQ +makeConstructorsDecoder thOptions typeName cs = do ts <- nub . join <$> for cs typesOf let decoderParameters = sigP (varP (mkName "os")) (conT $ mkName "Options") : sigP (varP (mkName "cd")) (conT $ mkName "ConstructorsDecoder") : ((\(t, n) -> sigP (varP (mkName $ "d" <> P.show n)) (appT (conT $ mkName "Decoder") (pure t))) <$> zip ts [0 ..]) -- makeToConstructors os [Constructor "T1" ["f1", "f2"], Constructor "T2" []] v let paramP = varP (mkName "v") constructorDefs <- for cs $ \c -> do - cName <- dropQualified <$> nameOf c - fields <- fmap (litE . StringL . P.show . dropQualified) <$> fieldsOf c - fieldTypes <- fmap (litE . StringL . P.show . getSimpleTypeName) <$> typesOf c + cName <- makeName thOptions <$> nameOf c + fields <- fmap (litE . StringL . P.show . makeName thOptions) <$> fieldsOf c + fieldTypes <- fmap (litE . StringL . P.show . getSimpleTypeName thOptions) <$> typesOf c varE (mkName "makeConstructorDef") `appE` (litE . StringL $ P.show cName) `appE` listE fields `appE` listE fieldTypes - let matchClauses = makeMatchClause typeName ts <$> cs + let matchClauses = makeMatchClause thOptions typeName ts <$> cs let matchFunction = lamCaseE (matchClauses <> [makeErrorClause typeName]) let resolveFunction = varE (mkName "decodeFromDefinitions") `appE` varE (mkName "os") `appE` varE (mkName "cd") `appE` listE (pure <$> constructorDefs) `appE` varE (mkName "v") `appE` matchFunction lamE decoderParameters (appE (conE (mkName "Decoder")) (lamE [paramP] resolveFunction)) -- | Decode the nth constructor of a data type -- ToConstructor "T1" [v1, v2]-> T1 <$> d1 v1 <*> d2 v2 ... -makeMatchClause :: Name -> [Type] -> Con -> MatchQ -makeMatchClause typeName allTypes c = do +makeMatchClause :: ThOptions -> Name -> [Type] -> Con -> MatchQ +makeMatchClause thOptions typeName allTypes c = do ts <- typesOf c constructorTypes <- fmap snd <$> indexConstructorTypes allTypes ts - cName <- dropQualified <$> nameOf c + cName <- makeName thOptions <$> nameOf c let fieldsP = listP $ (\i -> varP $ mkName ("v" <> P.show i)) <$> constructorTypes match (conP (mkName "ToConstructor") [litP (StringL . P.show $ cName), fieldsP]) - (normalB (applyDecoder typeName cName constructorTypes)) + (normalB (applyDecoder thOptions typeName cName constructorTypes)) [] -- | Return an error the json value cannot be decoded with a constructor name and some values @@ -86,14 +107,15 @@ match (varP $ mkName "_1") (normalB (appE (conE $ mkName "Left") errorMessage)) [] -- ConstructorName <$> decodeFieldValue d1 o1 <*> decodeFieldValue d2 o2 ... -applyDecoder :: Name -> Name -> [Int] -> ExpQ -applyDecoder _typeName cName [] = appE (varE $ mkName "pure") (conE cName) -applyDecoder typeName cName (n : ns) = do +applyDecoder :: ThOptions -> Name -> Name -> [Int] -> ExpQ +applyDecoder _thOptions _typeName cName [] = appE (varE $ mkName "pure") (conE cName) +applyDecoder thOptions typeName cName (n : ns) = do let cons = appE (varE $ mkName "pure") (conE cName) foldr (\i r -> appE (appE (varE (mkName "ap")) r) $ decodeAt i) (appE (appE (varE (mkName "ap")) cons) $ decodeAt n) (reverse ns) where decodeAt i = - varE (mkName "decodeFieldValue") `appE` varE (mkName ("d" <> P.show i)) - `appE` (litE . StringL . P.show . dropQualified $ typeName) - `appE` (litE . StringL . P.show . dropQualified $ cName) + varE (mkName "decodeFieldValue") + `appE` varE (mkName ("d" <> P.show i)) + `appE` (litE . StringL . P.show . makeName thOptions $ typeName) + `appE` (litE . StringL . P.show . makeName thOptions $ cName) `appE` varE (mkName ("v" <> P.show i)) diff --git a/src/Data/Registry/Aeson/TH/Encoder.hs b/src/Data/Registry/Aeson/TH/Encoder.hs --- a/src/Data/Registry/Aeson/TH/Encoder.hs +++ b/src/Data/Registry/Aeson/TH/Encoder.hs @@ -4,6 +4,7 @@ import Control.Monad.Fail import Data.List (nub) +import Data.Registry.Aeson.TH.ThOptions import Data.Registry.Aeson.TH.TH import Language.Haskell.TH import Language.Haskell.TH.Syntax @@ -15,32 +16,52 @@ -} -- | Make an Encoder for a given data type --- Usage: $(makeEncoder ''MyDataType) <: otherEncoders +-- Usage: $(makeEncoder ''MyDataType <: otherEncoders) makeEncoder :: Name -> ExpQ -makeEncoder encodedType = appE (varE $ mkName "fun") $ do +makeEncoder = makeEncoderWith defaultThOptions + +-- | Make an Encoder for a given data type, where all types names are qualified with their module full name +-- Usage: +-- -- MyDataType is defined in X.Y.Z +-- import X.Y.Z qualified +-- $(makeEncoderQualified ''MyDataType <: otherEncoders) +makeEncoderQualified :: Name -> ExpQ +makeEncoderQualified = makeEncoderWith (ThOptions qualified) + +-- | Make an Encoder for a given data type, where all types names are qualified with their module name +-- -- MyDataType is defined in X.Y.Z +-- import X.Y.Z qualified as Z +-- $(makeEncoderQualifiedLast ''MyDataType <: otherEncoders) +makeEncoderQualifiedLast :: Name -> ExpQ +makeEncoderQualifiedLast = makeEncoderWith (ThOptions qualifyWithLastName) + +-- | Make an Encoder for a given data type and pass options to specify how names must be qualified +-- Usage: $(makeEncoderWith options ''MyDataType) <: otherEncoders +makeEncoderWith :: ThOptions -> Name -> ExpQ +makeEncoderWith thOptions encodedType = appE (varE $ mkName "fun") $ do info <- reify encodedType case info of TyConI (NewtypeD _context _name _typeVars _kind constructor _deriving) -> - makeConstructorsEncoder [constructor] + makeConstructorsEncoder thOptions [constructor] TyConI (DataD _context _name _typeVars _kind constructors _deriving) -> - makeConstructorsEncoder constructors + makeConstructorsEncoder thOptions constructors other -> do qReport True ("can only create encoders for an ADT, got: " <> show other) fail "encoders creation failed" --- \(o::Options) (ce::ConstructorEncoder) (e0::Encoder A0) (e1::Encoder A1) ... -> Encoder $ \a -> +-- \(o::ThOptions) (ce::ConstructorEncoder) (e0::Encoder A0) (e1::Encoder A1) ... -> Encoder $ \a -> -- case a of -- T1 a0 a1 ... -> encodeConstructor ce o (FromConstructor names types "T1" fieldNames [encode e0 a0, encode e1 a1, ...]) -- T2 a0 a4 ... -> encodeConstructor ce o (FromConstructor names types "T2" fieldNames [encode e0 a0, encode e4 a4, ...]) -makeConstructorsEncoder :: [Con] -> ExpQ -makeConstructorsEncoder cs = do +makeConstructorsEncoder :: ThOptions -> [Con] -> ExpQ +makeConstructorsEncoder thOptions cs = do -- get the types of all the fields of all the constructors ts <- nub . join <$> for cs typesOf - constructorsNames <- for cs nameOf - let options = sigP (varP (mkName "os")) (conT $ mkName "Options") + constructorsNames <- fmap (makeName thOptions) <$> for cs nameOf + let aesonOptions = sigP (varP (mkName "os")) (conT $ mkName "Options") let constructorEncoder = sigP (varP (mkName "ce")) (conT $ mkName "ConstructorEncoder") - let encoderParameters = options : constructorEncoder : ((\(t, n) -> sigP (varP (mkName $ "e" <> show n)) (appT (conT $ mkName "Encoder") (pure t))) <$> zip ts [0 ..]) - matchClauses <- for cs $ makeMatchClause constructorsNames ts + let encoderParameters = aesonOptions : constructorEncoder : ((\(t, n) -> sigP (varP (mkName $ "e" <> show n)) (appT (conT $ mkName "Encoder") (pure t))) <$> zip ts [0 ..]) + matchClauses <- for cs $ makeMatchClause thOptions constructorsNames ts lamE encoderParameters (appE (conE (mkName "Encoder")) (lamCaseE (pure <$> matchClauses))) -- | Make the match clause for a constructor given @@ -48,15 +69,15 @@ -- - the constructor name -- - the constructor index in the list of all the constructors for the encoded data type -- T1 a0 a1 ... -> encodeConstructor ce o (FromConstructor names types cName fieldNames values) -makeMatchClause :: [Name] -> [Type] -> Con -> MatchQ -makeMatchClause constructorNames allTypes c = do +makeMatchClause :: ThOptions -> [Name] -> [Type] -> Con -> MatchQ +makeMatchClause thOptions constructorNames allTypes c = do ts <- typesOf c constructorTypes <- indexConstructorTypes allTypes ts - cName <- dropQualified <$> nameOf c - let names = listE $ litE . StringL . show . dropQualified <$> constructorNames + cName <- makeName thOptions <$> nameOf c + let names = listE $ litE . StringL . show . makeName thOptions <$> constructorNames let types = listE $ litE . StringL . show <$> allTypes fields <- fieldsOf c - let fieldNames = listE $ litE . StringL . show . dropQualified <$> fields + let fieldNames = listE $ litE . StringL . show . makeName thOptions <$> fields let params = conP (mkName $ show cName) $ (\(_, n) -> varP (mkName $ "a" <> show n)) <$> constructorTypes let values = listE $ (\(_, n) -> appE (appE (varE $ mkName "encode") (varE (mkName $ "e" <> show n))) (varE (mkName $ "a" <> show n))) <$> constructorTypes let encoded = diff --git a/src/Data/Registry/Aeson/TH/TH.hs b/src/Data/Registry/Aeson/TH/TH.hs --- a/src/Data/Registry/Aeson/TH/TH.hs +++ b/src/Data/Registry/Aeson/TH/TH.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -Wno-type-defaults #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} @@ -10,7 +11,7 @@ import Control.Monad.Fail import Data.List (elemIndex) -import qualified Data.Text as T +import Data.Registry.Aeson.TH.ThOptions import Language.Haskell.TH import Language.Haskell.TH.Syntax import Protolude hiding (Type) @@ -47,18 +48,18 @@ fail "encoders / decoders creation failed" -- | Remove the module name from a qualified name -dropQualified :: Name -> Name -dropQualified name = maybe name (mkName . toS) (lastMay (T.splitOn "." (show name))) +makeName :: ThOptions -> Name -> Name +makeName options = mkName . toS . modifyTypeName options . show --- | Return the name of a given type -getSimpleTypeName :: Type -> Name -getSimpleTypeName (ForallT _ _ ty) = getSimpleTypeName ty -getSimpleTypeName (VarT name) = dropQualified name -getSimpleTypeName (ConT name) = dropQualified name -getSimpleTypeName (TupleT n) = dropQualified $ tupleTypeName n -getSimpleTypeName ArrowT = dropQualified ''(->) -getSimpleTypeName ListT = dropQualified ''[] -getSimpleTypeName (AppT t1 t2) = mkName (show (getSimpleTypeName t1) <> " " <> show (getSimpleTypeName t2)) -getSimpleTypeName (SigT t _) = getSimpleTypeName t -getSimpleTypeName (UnboxedTupleT n) = dropQualified $ unboxedTupleTypeName n -getSimpleTypeName t = panic $ "getSimpleTypeName: Unknown type: " <> show t +-- | Return the name of a given type with a modified name based on options +getSimpleTypeName :: ThOptions -> Type -> Name +getSimpleTypeName options (ForallT _ _ ty) = getSimpleTypeName options ty +getSimpleTypeName options (VarT name) = makeName options name +getSimpleTypeName options (ConT name) = makeName options name +getSimpleTypeName options (TupleT n) = makeName options $ tupleTypeName n +getSimpleTypeName options ArrowT = makeName options ''(->) +getSimpleTypeName options ListT = makeName options ''[] +getSimpleTypeName options (AppT t1 t2) = mkName (show (getSimpleTypeName options t1) <> " " <> show (getSimpleTypeName options t2)) +getSimpleTypeName options (SigT t _) = getSimpleTypeName options t +getSimpleTypeName options (UnboxedTupleT n) = makeName options $ unboxedTupleTypeName n +getSimpleTypeName _ t = panic $ "getSimpleTypeName: Unknown type: " <> show t diff --git a/src/Data/Registry/Aeson/TH/ThOptions.hs b/src/Data/Registry/Aeson/TH/ThOptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/Registry/Aeson/TH/ThOptions.hs @@ -0,0 +1,38 @@ +module Data.Registry.Aeson.TH.ThOptions where + +import Data.Text qualified as T +import Protolude + +-- | Options used to adjust the creation of encoders/decoders +newtype ThOptions = ThOptions + { modifyTypeName :: Text -> Text + } + +-- | Default options for adjusting the creation of Encoders/Decoders +defaultThOptions :: ThOptions +defaultThOptions = ThOptions dropQualifier + +-- | Drop the leading names in a qualified name + +--- dropQualifier "x.y.z" === "z" +dropQualifier :: Text -> Text +dropQualifier t = fromMaybe t . lastMay $ T.splitOn "." t + +-- | This function does not modify type names +qualified :: Text -> Text +qualified = identity + +-- | Provide a specific qualifier to produce type names + +--- qualifyAs "a" "x.y.z" === "a.z" +qualifyAs :: Text -> Text -> Text +qualifyAs qualifier t = qualifier <> "." <> dropQualifier t + +-- | Keep the last name as the qualifier + +--- qualifyWithLastName "x.y.z" === "y.z" +qualifyWithLastName :: Text -> Text +qualifyWithLastName t = + case reverse $ T.splitOn "." t of + t1 : t2 : _ -> t2 <> "." <> t1 + _ -> t diff --git a/test/Test/Data/Registry/Aeson/DataTypes.hs b/test/Test/Data/Registry/Aeson/DataTypes.hs --- a/test/Test/Data/Registry/Aeson/DataTypes.hs +++ b/test/Test/Data/Registry/Aeson/DataTypes.hs @@ -8,13 +8,16 @@ import Protolude newtype Identifier = Identifier Int - deriving (Eq, Show, Generic, ToJSON, FromJSON) + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) newtype Email = Email {_email :: Text} - deriving (Eq, Show, Generic, ToJSON, FromJSON) + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) newtype DateTime = DateTime {_datetime :: UTCTime} - deriving (Eq, Show, Generic, ToJSON, FromJSON) + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) data Person = Person {identifier :: Identifier, email :: Email} deriving (Eq, Show, Generic, ToJSON, FromJSON) diff --git a/test/Test/Data/Registry/Aeson/DecoderSpec.hs b/test/Test/Data/Registry/Aeson/DecoderSpec.hs --- a/test/Test/Data/Registry/Aeson/DecoderSpec.hs +++ b/test/Test/Data/Registry/Aeson/DecoderSpec.hs @@ -14,6 +14,7 @@ import Data.Time import Protolude import Test.Data.Registry.Aeson.DataTypes +import Test.Data.Registry.Aeson.SimilarDataTypes qualified as SimilarDataTypes import Test.Tasty.Hedgehogx hiding (either, maybe, text) test_decode = test "decode" $ do @@ -158,6 +159,11 @@ $(makeDecoder ''Delivery) <: $(makeDecoder ''Team) <: decodeListOf @Person + -- test that it is possible to generate a Decoder when there are name clashes + <: $(makeDecoderQualifiedLast ''SimilarDataTypes.Person) + <: $(makeDecoderQualifiedLast ''SimilarDataTypes.Email) + <: $(makeDecoderQualifiedLast ''SimilarDataTypes.Identifier) + <: $(makeDecoderQualifiedLast ''SimilarDataTypes.DateTime) <: $(makeDecoder ''Person) <: $(makeDecoder ''Email) <: $(makeDecoder ''Identifier) diff --git a/test/Test/Data/Registry/Aeson/EncoderSpec.hs b/test/Test/Data/Registry/Aeson/EncoderSpec.hs --- a/test/Test/Data/Registry/Aeson/EncoderSpec.hs +++ b/test/Test/Data/Registry/Aeson/EncoderSpec.hs @@ -17,6 +17,7 @@ import Data.Time import Protolude import Test.Data.Registry.Aeson.DataTypes +import Test.Data.Registry.Aeson.SimilarDataTypes qualified as SimilarDataTypes import Test.Tasty.Hedgehogx hiding (string) test_encode = test "encode" $ do @@ -61,6 +62,11 @@ encoders :: Registry _ _ encoders = $(makeEncoder ''Delivery) + -- test that it is possible to generate an Encoder when there are name clashes + <: $(makeEncoderQualifiedLast ''SimilarDataTypes.Person) + <: $(makeEncoderQualifiedLast ''SimilarDataTypes.Email) + <: $(makeEncoderQualifiedLast ''SimilarDataTypes.Identifier) + <: $(makeEncoderQualifiedLast ''SimilarDataTypes.DateTime) <: $(makeEncoder ''Person) <: $(makeEncoder ''Email) <: $(makeEncoder ''Identifier) @@ -74,6 +80,7 @@ <: $(makeEncoder ''ObjectWithSingleFieldSumEncoding) <: $(makeEncoder ''TwoElemArraySumEncoding) <: fun datetimeEncoder + <: fun utcTimeEncoder <: encodeMaybeOf @Int <: jsonEncoder @Text <: jsonEncoder @Int @@ -84,6 +91,10 @@ datetimeEncoder = fromValue $ \(DateTime dt) -> do let formatted = toS $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" dt Object [("_datetime", String formatted)] + +-- | This Encoder for DateTime reproduces the default generic one +utcTimeEncoder :: Encoder UTCTime +utcTimeEncoder = fromValue $ String . toS . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" -- | Check that the encoding performed with the registry and the one performed with a Generic instance are the same -- This helps validating the encoding algorithm based on the various Options values diff --git a/test/Test/Data/Registry/Aeson/RoundtripData.hs b/test/Test/Data/Registry/Aeson/RoundtripData.hs --- a/test/Test/Data/Registry/Aeson/RoundtripData.hs +++ b/test/Test/Data/Registry/Aeson/RoundtripData.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} @@ -10,13 +11,16 @@ import Prelude (String) data T0 = T0 - deriving (Eq, Show, Generic, FromJSON, ToJSON) + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON) newtype T1 = T1 Int - deriving (Eq, Show, Generic, FromJSON, ToJSON) + deriving stock (Eq, Show, Generic) + deriving newtype (FromJSON, ToJSON) newtype T2 = T2 {t2Int :: Int} - deriving (Eq, Show, Generic, FromJSON, ToJSON) + deriving stock (Eq, Show, Generic) + deriving newtype (FromJSON, ToJSON) data T3 = T3 Int deriving (Eq, Show, Generic, FromJSON, ToJSON) diff --git a/test/Test/Data/Registry/Aeson/SimilarDataTypes.hs b/test/Test/Data/Registry/Aeson/SimilarDataTypes.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Registry/Aeson/SimilarDataTypes.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + +-- | This modules helps testing that we can use TemplateHaskell when there are name clashes +module Test.Data.Registry.Aeson.SimilarDataTypes where + +import Data.Aeson +import Data.Time +import Protolude + +newtype Identifier = Identifier Int + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +newtype Email = Email {_email :: Text} + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +newtype DateTime = DateTime {_datetime :: UTCTime} + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +data Person = Person {identifier :: Identifier, email :: Email} + deriving (Eq, Show, Generic, ToJSON, FromJSON) + +data Team = Team {name :: Text, members :: [Person], leaderName :: Maybe Text} + deriving (Eq, Show, Generic, ToJSON, FromJSON) + +data Delivery + = NoDelivery + | ByEmail Email + | InPerson Person DateTime + deriving (Eq, Show, Generic, ToJSON, FromJSON) + +data Path + = File Int + | Directory [Path] + deriving (Eq, Show, Generic, ToJSON, FromJSON) + +-- * EXAMPLES + +email1 :: Email +email1 = Email "me@here.com" + +person1 :: Person +person1 = Person (Identifier 123) email1 + +delivery0 :: Delivery +delivery0 = NoDelivery + +delivery1 :: Delivery +delivery1 = ByEmail email1 + +delivery2 :: Delivery +delivery2 = InPerson person1 datetime1 + +datetime1 :: DateTime +datetime1 = DateTime $ UTCTime (fromGregorian 2022 4 18) 12 + +path1 :: Path +path1 = Directory [Directory [Directory [File 1], Directory [File 2]], File 3] + +-- * OPTIONS TEST + +allNullaryOptions = defaultOptions {allNullaryToStringTag = True} + +data AllNullary + = AllNullary1 + | AllNullary2 + deriving (Eq, Show, Generic) + +instance ToJSON AllNullary where + toJSON = genericToJSON allNullaryOptions + +instance FromJSON AllNullary where + parseJSON = genericParseJSON allNullaryOptions + +fieldLabelModifierOptions = defaultOptions {fieldLabelModifier = ("__" <>)} + +data FieldLabelModifier + = FieldLabelModifier1 {field1 :: Int} + | FieldLabelModifier2 {field2 :: Int} + deriving (Eq, Show, Generic) + +instance ToJSON FieldLabelModifier where + toJSON = genericToJSON fieldLabelModifierOptions + +instance FromJSON FieldLabelModifier where + parseJSON = genericParseJSON fieldLabelModifierOptions + +constructorTagModifierOptions = defaultOptions {constructorTagModifier = ("__" <>)} + +data ConstructorTagModifier + = ConstructorTagModifier1 {ctField1 :: Int} + | ConstructorTagModifier2 {ctField2 :: Int} + deriving (Eq, Show, Generic) + +instance ToJSON ConstructorTagModifier where + toJSON = genericToJSON constructorTagModifierOptions + +instance FromJSON ConstructorTagModifier where + parseJSON = genericParseJSON constructorTagModifierOptions + +omitNothingFieldsOptions = defaultOptions {omitNothingFields = True} + +data OmitNothingFields + = OmitNothingFields1 {onField1 :: Maybe Int, onField2 :: Int} + | OmitNothingFields2 {onField3 :: Int} + deriving (Eq, Show, Generic) + +instance ToJSON OmitNothingFields where + toJSON = genericToJSON omitNothingFieldsOptions + +instance FromJSON OmitNothingFields where + parseJSON = genericParseJSON omitNothingFieldsOptions + +unwrapUnaryRecordsOptions = defaultOptions {unwrapUnaryRecords = True} + +newtype UnwrapUnaryRecords = UnwrapUnaryRecords1 {uuField1 :: Int} + deriving (Eq, Show, Generic) + +instance ToJSON UnwrapUnaryRecords where + toJSON = genericToJSON unwrapUnaryRecordsOptions + +instance FromJSON UnwrapUnaryRecords where + parseJSON = genericParseJSON unwrapUnaryRecordsOptions + +tagSingleConstructorsOptions = defaultOptions {tagSingleConstructors = True} + +newtype TagSingleConstructors = TagSingleConstructors1 {tsField1 :: Int} + deriving (Eq, Show, Generic) + +instance ToJSON TagSingleConstructors where + toJSON = genericToJSON tagSingleConstructorsOptions + +instance FromJSON TagSingleConstructors where + parseJSON = genericParseJSON tagSingleConstructorsOptions + +untaggedValueOptions = defaultOptions {sumEncoding = UntaggedValue} + +data UntaggedValueSumEncoding + = UntaggedValueSumEncoding1 {uvField1 :: Int} + | UntaggedValueSumEncoding2 {uvField2 :: Int} + deriving (Eq, Show, Generic) + +instance ToJSON UntaggedValueSumEncoding where + toJSON = genericToJSON untaggedValueOptions + +instance FromJSON UntaggedValueSumEncoding where + parseJSON = genericParseJSON untaggedValueOptions + +objectWithSingleFieldSumEncodingOptions = defaultOptions {sumEncoding = ObjectWithSingleField} + +data ObjectWithSingleFieldSumEncoding + = ObjectWithSingleFieldSumEncoding1 {owsfField1 :: Int} + | ObjectWithSingleFieldSumEncoding2 {owsfField2 :: Int} + deriving (Eq, Show, Generic) + +instance ToJSON ObjectWithSingleFieldSumEncoding where + toJSON = genericToJSON objectWithSingleFieldSumEncodingOptions + +instance FromJSON ObjectWithSingleFieldSumEncoding where + parseJSON = genericParseJSON objectWithSingleFieldSumEncodingOptions + +twoElemArraySumEncodingOptions = defaultOptions {sumEncoding = TwoElemArray} + +data TwoElemArraySumEncoding + = TwoElemArraySumEncoding1 {teaField1 :: Int} + | TwoElemArraySumEncoding2 {teaField2 :: Int} + deriving (Eq, Show, Generic) + +instance ToJSON TwoElemArraySumEncoding where + toJSON = genericToJSON twoElemArraySumEncodingOptions + +instance FromJSON TwoElemArraySumEncoding where + parseJSON = genericParseJSON twoElemArraySumEncodingOptions