registry-aeson 0.2.2.0 → 0.2.3.0

raw patch · 12 files changed

+384/−128 lines, 12 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• registry-aeson.cabal +9/−39
• src/Data/Registry/Aeson/Decoder.hs +27/−25
• src/Data/Registry/Aeson/Encoder.hs +8/−6
• src/Data/Registry/Aeson/TH/Decoder.hs +43/−21
• src/Data/Registry/Aeson/TH/Encoder.hs +37/−16
• src/Data/Registry/Aeson/TH/TH.hs +16/−15
• src/Data/Registry/Aeson/TH/ThOptions.hs +38/−0
• test/Test/Data/Registry/Aeson/DataTypes.hs +6/−3
• test/Test/Data/Registry/Aeson/DecoderSpec.hs +6/−0
• test/Test/Data/Registry/Aeson/EncoderSpec.hs +11/−0
• test/Test/Data/Registry/Aeson/RoundtripData.hs +7/−3
• test/Test/Data/Registry/Aeson/SimilarDataTypes.hs +176/−0

@@ -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

@@ -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"

@@ -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'))

@@ -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))

@@ -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 =

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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

@@ -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)

@@ -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