From 1e72b6101ad9bc00dec3e8211ff755103ba1934f Mon Sep 17 00:00:00 2001 From: ners Date: Thu, 26 Feb 2026 07:52:24 +0100 Subject: [PATCH] code-gen: avoid generating duplicate types - derive Eq for AST types - nub the list of generated types before printing them If a schema contains an interface with a field with multiple params, then the Args type for that field is generated for the interface, as well as each of the types that implement it. If the interface is implemented correctly, these types will all be the same. --- .../src/Data/Morpheus/CodeGen/Internal/AST.hs | 23 +++++++++++-------- .../Morpheus/CodeGen/Server/Internal/AST.hs | 12 +++++----- .../CodeGen/Server/Interpreting/Transform.hs | 5 +++- 3 files changed, 23 insertions(+), 17 deletions(-) diff --git a/morpheus-graphql-code-gen-utils/src/Data/Morpheus/CodeGen/Internal/AST.hs b/morpheus-graphql-code-gen-utils/src/Data/Morpheus/CodeGen/Internal/AST.hs index 6c0444c23..934aab095 100644 --- a/morpheus-graphql-code-gen-utils/src/Data/Morpheus/CodeGen/Internal/AST.hs +++ b/morpheus-graphql-code-gen-utils/src/Data/Morpheus/CodeGen/Internal/AST.hs @@ -62,7 +62,7 @@ data DerivingClass = SHOW | GENERIC | CLASS_EQ - deriving (Show) + deriving (Eq, Show) instance Pretty DerivingClass where pretty SHOW = "Show" @@ -77,7 +77,7 @@ data TypeValue | TypeValueList [TypeValue] | TypedValueMaybe (Maybe TypeValue) | PrintableTypeValue PrintableValue - deriving (Show) + deriving (Eq, Show) renderField :: (FieldName, TypeValue) -> Doc n renderField (fName, fValue) = pretty (unpackName fName :: Text) <+> "=" <+> pretty fValue @@ -101,7 +101,7 @@ data CodeGenType = CodeGenType cgConstructors :: [CodeGenConstructor], cgDerivations :: [DerivingClass] } - deriving (Show) + deriving (Eq, Show) isNewType :: CodeGenType -> Bool isNewType CodeGenType {cgConstructors = [CodeGenConstructor {constructorFields = [_]}]} = True @@ -128,7 +128,7 @@ data CodeGenConstructor = CodeGenConstructor { constructorName :: CodeGenTypeName, constructorFields :: [CodeGenField] } - deriving (Show) + deriving (Eq, Show) instance Printer CodeGenConstructor where print CodeGenConstructor {constructorFields = [CodeGenField {fieldName = "_", ..}], ..} = @@ -147,7 +147,7 @@ data CodeGenField = CodeGenField wrappers :: [FIELD_TYPE_WRAPPER], fieldIsNullable :: Bool } - deriving (Show) + deriving (Eq, Show) instance Printer CodeGenField where print CodeGenField {..} = infix' (print fieldName) "::" (foldr renderWrapper (print fieldType) wrappers) @@ -159,7 +159,7 @@ data FIELD_TYPE_WRAPPER | ARG TypeName | TAGGED_ARG TH.Name FieldName TypeRef | GQL_WRAPPER TypeWrapper - deriving (Show) + deriving (Eq, Show) renderWrapper :: FIELD_TYPE_WRAPPER -> HSDoc n -> HSDoc n renderWrapper PARAMETRIZED = (.<> "m") @@ -174,7 +174,7 @@ data CodeGenTypeName = CodeGenTypeName typeParameters :: [Text], typename :: TypeName } - deriving (Show) + deriving (Eq, Show) getFullName :: CodeGenTypeName -> TypeName getFullName CodeGenTypeName {..} = camelCaseTypeName namespace typename @@ -248,7 +248,7 @@ data TypeClassInstance body = TypeClassInstance assoc :: [(TH.Name, AssociatedType)], typeClassMethods :: [(TH.Name, MethodArgument, body)] } - deriving (Show) + deriving (Eq, Show) instance (Pretty a) => Pretty (TypeClassInstance a) where pretty TypeClassInstance {..} = @@ -271,7 +271,7 @@ renderTypeableConstraints xs = tupled (map (("Typeable" <+>) . pretty) xs) <+> " data AssociatedType = AssociatedTypeName TH.Name | AssociatedLocations [DirectiveLocation] - deriving (Show) + deriving (Eq, Show) printTHName :: TH.Name -> Doc ann printTHName = ignore . print @@ -287,7 +287,7 @@ data MethodArgument = NoArgument | ProxyArgument | DestructArgument TH.Name [TH.Name] - deriving (Show) + deriving (Eq, Show) instance Pretty MethodArgument where pretty NoArgument = "" @@ -297,6 +297,9 @@ instance Pretty MethodArgument where data PrintableValue where PrintableValue :: forall a. (Show a, Lift a) => a -> PrintableValue +instance Eq PrintableValue where + a == b = show a == show b + instance Show PrintableValue where show (PrintableValue a) = show a diff --git a/morpheus-graphql-code-gen/src/Data/Morpheus/CodeGen/Server/Internal/AST.hs b/morpheus-graphql-code-gen/src/Data/Morpheus/CodeGen/Server/Internal/AST.hs index e836a0c5c..350d1ed87 100644 --- a/morpheus-graphql-code-gen/src/Data/Morpheus/CodeGen/Server/Internal/AST.hs +++ b/morpheus-graphql-code-gen/src/Data/Morpheus/CodeGen/Server/Internal/AST.hs @@ -84,7 +84,7 @@ data ServerDirectiveUsage = TypeDirectiveUsage TypeValue | FieldDirectiveUsage FieldName TypeValue | EnumDirectiveUsage TypeName TypeValue - deriving (Show) + deriving (Eq, Show) instance PrintExp ServerDirectiveUsage where printExp (TypeDirectiveUsage x) = appE (varE 'typeDirective) (printExp x) @@ -101,14 +101,14 @@ data GQLTypeDefinition = GQLTypeDefinition gqlKind :: Kind, gqlTypeDirectiveUses :: [ServerDirectiveUsage] } - deriving (Show) + deriving (Eq, Show) data InterfaceDefinition = InterfaceDefinition { aliasName :: TypeName, interfaceName :: TypeName, unionName :: TypeName } - deriving (Show) + deriving (Eq, Show) instance PrintDec InterfaceDefinition where printDec InterfaceDefinition {..} = @@ -125,7 +125,7 @@ data GQLDirectiveTypeClass = GQLDirectiveTypeClass { directiveTypeName :: CodeGenTypeName, directiveLocations :: [DirectiveLocation] } - deriving (Show) + deriving (Eq, Show) data ServerDeclaration = GQLTypeInstance Kind (TypeClassInstance ServerMethod) @@ -133,7 +133,7 @@ data ServerDeclaration | DataType CodeGenType | ScalarType {scalarTypeName :: Text} | InterfaceType InterfaceDefinition - deriving (Show) + deriving (Eq, Show) instance Pretty ServerDeclaration where pretty (InterfaceType InterfaceDefinition {..}) = @@ -157,7 +157,7 @@ newtype CodeGenConfig = CodeGenConfig {namespace :: Bool} data ServerMethod = ServerMethodDefaultValues (Map Text (Value CONST)) | ServerMethodDirectives [ServerDirectiveUsage] - deriving (Show) + deriving (Eq, Show) instance Pretty ServerMethod where pretty (ServerMethodDefaultValues x) = pretty (show x) diff --git a/morpheus-graphql-code-gen/src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs b/morpheus-graphql-code-gen/src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs index eae9639e7..78f6ea276 100755 --- a/morpheus-graphql-code-gen/src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs +++ b/morpheus-graphql-code-gen/src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs @@ -15,6 +15,7 @@ module Data.Morpheus.CodeGen.Server.Interpreting.Transform where import Data.ByteString.Lazy.Char8 (ByteString) +import Data.List (nub) import Data.Morpheus.CodeGen.Internal.AST ( AssociatedType (..), CodeGenConstructor (..), @@ -100,7 +101,9 @@ parseServerTypeDefinitions :: (CodeGenMonad m) => CodeGenConfig -> ByteString -> parseServerTypeDefinitions ctx txt = case parseDefinitions txt of Failure errors -> fail (renderGQLErrors errors) - Success {result, warnings} -> printWarnings warnings >> toTHDefinitions (namespace ctx) result + Success {result, warnings} -> do + printWarnings warnings + first nub <$> toTHDefinitions (namespace ctx) result getExternals :: [ServerDeclaration] -> Flags getExternals xs =