diff --git a/morpheus-graphql-code-gen.cabal b/morpheus-graphql-code-gen.cabal --- a/morpheus-graphql-code-gen.cabal +++ b/morpheus-graphql-code-gen.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.0. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: morpheus-graphql-code-gen -version: 0.27.3 +version: 0.28.0 synopsis: Morpheus GraphQL CLI description: code generator for Morpheus GraphQL category: web, graphql, cli @@ -41,12 +41,12 @@ ghc-options: -Wall build-depends: base >=4.7.0 && <5.0.0 - , bytestring >=0.10.4 && <0.12.0 - , containers >=0.4.2.1 && <0.7.0 + , bytestring >=0.10.4 && <0.15.0 + , containers >=0.4.2.1 && <=0.7 , file-embed >=0.0.10 && <1.0.0 - , morpheus-graphql-code-gen-utils >=0.27.0 && <0.28.0 - , morpheus-graphql-core >=0.27.0 && <0.28.0 - , morpheus-graphql-server >=0.27.0 && <0.28.0 + , morpheus-graphql-code-gen-utils >=0.28.0 && <0.29.0 + , morpheus-graphql-core >=0.28.0 && <0.29.0 + , morpheus-graphql-server >=0.28.0 && <0.29.0 , prettyprinter >=1.7.0 && <2.0.0 , relude >=0.3.0 && <2.0.0 , template-haskell >=2.0.0 && <3.0.0 @@ -68,16 +68,16 @@ build-depends: Glob >=0.7.0 && <1.0.0 , base >=4.7.0 && <5.0.0 - , bytestring >=0.10.4 && <0.12.0 - , containers >=0.4.2.1 && <0.7.0 + , bytestring >=0.10.4 && <0.15.0 + , containers >=0.4.2.1 && <=0.7 , file-embed >=0.0.10 && <1.0.0 - , filepath >=1.1.0 && <1.5.0 - , morpheus-graphql-client - , morpheus-graphql-code-gen - , morpheus-graphql-code-gen-utils - , morpheus-graphql-core >=0.27.0 && <0.28.0 - , morpheus-graphql-server >=0.27.0 && <0.28.0 - , optparse-applicative >=0.12.0 && <0.18.0 + , filepath >=1.1.0 && <=1.5.2.0 + , morpheus-graphql-client >=0.28.0 && <0.29.0 + , morpheus-graphql-code-gen >=0.28.0 && <0.29.0 + , morpheus-graphql-code-gen-utils >=0.28.0 && <0.29.0 + , morpheus-graphql-core >=0.28.0 && <0.29.0 + , morpheus-graphql-server >=0.28.0 && <0.29.0 + , optparse-applicative >=0.12.0 && <0.20.0 , prettyprinter >=1.7.0 && <2.0.0 , relude >=0.3.0 && <2.0.0 , template-haskell >=2.0.0 && <3.0.0 diff --git a/src/Data/Morpheus/CodeGen/Server/Internal/AST.hs b/src/Data/Morpheus/CodeGen/Server/Internal/AST.hs --- a/src/Data/Morpheus/CodeGen/Server/Internal/AST.hs +++ b/src/Data/Morpheus/CodeGen/Server/Internal/AST.hs @@ -39,7 +39,7 @@ (.<>), ) import Data.Morpheus.CodeGen.TH (PrintDec (..), PrintExp (..), ToName (..), apply, m', m_, printTypeSynonym) -import Data.Morpheus.Server.Types (SCALAR, TYPE, TypeGuard, enumDirective, fieldDirective, typeDirective) +import Data.Morpheus.Server.Types (DIRECTIVE, SCALAR, TYPE, TypeGuard, enumDirective, fieldDirective, typeDirective) import Data.Morpheus.Types.Internal.AST ( CONST, DirectiveLocation (..), @@ -51,11 +51,13 @@ Value, unpackName, ) -import Data.Text.Prettyprint.Doc (concatWith, indent, line) import Language.Haskell.TH.Lib (appE, varE) import Prettyprinter ( Pretty (..), align, + concatWith, + indent, + line, pretty, (<+>), ) @@ -65,15 +67,18 @@ data Kind = Scalar | Type + | Directive deriving (Show, Eq) instance Pretty Kind where pretty Type = "TYPE" pretty Scalar = "SCALAR" + pretty Directive = "DIRECTIVE" instance ToName Kind where toName Scalar = ''SCALAR toName Type = ''TYPE + toName Directive = ''DIRECTIVE data ServerDirectiveUsage = TypeDirectiveUsage TypeValue diff --git a/src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs b/src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs --- a/src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs +++ b/src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs @@ -96,7 +96,7 @@ ) import Relude hiding (ByteString, get) -parseServerTypeDefinitions :: CodeGenMonad m => CodeGenConfig -> ByteString -> m ([ServerDeclaration], Flags) +parseServerTypeDefinitions :: (CodeGenMonad m) => CodeGenConfig -> ByteString -> m ([ServerDeclaration], Flags) parseServerTypeDefinitions ctx txt = case parseDefinitions txt of Failure errors -> fail (renderGQLErrors errors) @@ -108,7 +108,7 @@ <> [FlagExternal (unpackName $ getFullName $ typeClassTarget v) | GQLTypeInstance Scalar v <- xs] toTHDefinitions :: - CodeGenMonad m => + (CodeGenMonad m) => Bool -> [RawTypeDefinition] -> m ([ServerDeclaration], Flags) @@ -118,7 +118,7 @@ where typeDefinitions = [td | RawTypeDefinition td <- defs] directiveDefinitions = [td | RawDirectiveDefinition td <- defs] - generateTypes :: CodeGenMonad m => RawTypeDefinition -> m ([ServerDeclaration], Flags) + generateTypes :: (CodeGenMonad m) => RawTypeDefinition -> m ([ServerDeclaration], Flags) generateTypes (RawTypeDefinition typeDef) = runCodeGenT (genTypeDefinition typeDef) @@ -130,40 +130,13 @@ currentKind = Just (kindOf typeDef), hasNamespace = namespace } - generateTypes (RawDirectiveDefinition DirectiveDefinition {..}) = + generateTypes (RawDirectiveDefinition dirDef) = runCodeGenT - ( do - fields <- traverse renderDataField (argument <$> toList directiveDefinitionArgs) - let typename = coerce directiveDefinitionName - namespaceDirs <- getNamespaceDirs (unpackName typename) - let cgTypeName = fromTypeName typename - pure - [ DataType - CodeGenType - { cgTypeName, - cgConstructors = [CodeGenConstructor (fromTypeName typename) fields], - cgDerivations = [SHOW, GENERIC] - }, - GQLDirectiveInstance - TypeClassInstance - { typeClassName = ''GQLDirective, - typeClassContext = [], - typeClassTarget = cgTypeName, - assoc = [(''DIRECTIVE_LOCATIONS, AssociatedLocations directiveDefinitionLocations)], - typeClassMethods = [] - }, - gqlTypeToInstance - GQLTypeDefinition - { gqlTarget = cgTypeName, - gqlKind = Type, - gqlTypeDirectiveUses = namespaceDirs - } - ] - ) + (genDirectiveDefinition dirDef) ServerCodeGenContext { toArgsTypeName = coerce, typeDefinitions, - currentTypeName = Just (coerce directiveDefinitionName), + currentTypeName = Just (coerce directiveDefinitionName dirDef), directiveDefinitions, currentKind = Nothing, hasNamespace = namespace @@ -176,8 +149,37 @@ mkPossibleTypesName :: TypeName -> TypeName mkPossibleTypesName = ("PossibleTypes" <>) +genDirectiveDefinition :: (CodeGenM m) => DirectiveDefinition CONST -> m [ServerDeclaration] +genDirectiveDefinition DirectiveDefinition {..} = do + fields <- traverse (renderDataField . argument) (toList directiveDefinitionArgs) + let typename = coerce directiveDefinitionName + namespaceDirs <- getNamespaceDirs (unpackName typename) + let cgTypeName = fromTypeName typename + pure + [ DataType + CodeGenType + { cgTypeName, + cgConstructors = [CodeGenConstructor (fromTypeName typename) fields], + cgDerivations = [SHOW, GENERIC] + }, + GQLDirectiveInstance + TypeClassInstance + { typeClassName = ''GQLDirective, + typeClassContext = [], + typeClassTarget = cgTypeName, + assoc = [(''DIRECTIVE_LOCATIONS, AssociatedLocations directiveDefinitionLocations)], + typeClassMethods = [] + }, + gqlTypeToInstance + GQLTypeDefinition + { gqlTarget = cgTypeName, + gqlKind = Directive, + gqlTypeDirectiveUses = namespaceDirs + } + ] + genTypeDefinition :: - CodeGenM m => + (CodeGenM m) => TypeDefinition ANY CONST -> m [ServerDeclaration] genTypeDefinition @@ -233,7 +235,7 @@ argTName = camelCaseTypeName [fieldName] "Args" mkObjectField :: - CodeGenM m => + (CodeGenM m) => FieldDefinition OUT CONST -> m CodeGenField mkObjectField @@ -261,7 +263,7 @@ .. } -mkFieldArguments :: CodeGenM m => FieldName -> (FieldName -> TypeName) -> [ArgumentDefinition s] -> m [FIELD_TYPE_WRAPPER] +mkFieldArguments :: (CodeGenM m) => FieldName -> (FieldName -> TypeName) -> [ArgumentDefinition s] -> m [FIELD_TYPE_WRAPPER] mkFieldArguments _ _ [] = pure [] mkFieldArguments _ @@ -295,7 +297,7 @@ ] } -genInterfaceUnion :: CodeGenM m => TypeName -> m [ServerDeclaration] +genInterfaceUnion :: (CodeGenM m) => TypeName -> m [ServerDeclaration] genInterfaceUnion interfaceName = asks typeDefinitions >>= mkInterface . map typeName . mapMaybe (isPossibleInterfaceType interfaceName) where @@ -323,12 +325,12 @@ mkGuardWithPossibleType = InterfaceType . InterfaceDefinition interfaceName (mkInterfaceName interfaceName) tName = mkPossibleTypesName interfaceName -mkConsEnum :: CodeGenM m => DataEnumValue CONST -> m CodeGenConstructor +mkConsEnum :: (CodeGenM m) => DataEnumValue CONST -> m CodeGenConstructor mkConsEnum DataEnumValue {enumName} = do constructorName <- getEnumName enumName pure CodeGenConstructor {constructorName, constructorFields = []} -renderDataField :: CodeGenM m => FieldDefinition c CONST -> m CodeGenField +renderDataField :: (CodeGenM m) => FieldDefinition c CONST -> m CodeGenField renderDataField FieldDefinition {fieldType = TypeRef {typeConName, typeWrappers}, fieldName = fName} = do fieldName <- getFieldName fName let wrappers = [GQL_WRAPPER typeWrappers] @@ -336,7 +338,7 @@ let fieldIsNullable = isNullable typeWrappers pure CodeGenField {..} -genTypeContent :: CodeGenM m => TypeName -> TypeContent TRUE ANY CONST -> m BuildPlan +genTypeContent :: (CodeGenM m) => TypeName -> TypeContent TRUE ANY CONST -> m BuildPlan genTypeContent _ DataScalar {} = pure (ConsIN []) genTypeContent _ (DataEnum tags) = ConsIN <$> traverse mkConsEnum tags genTypeContent typeName (DataInputObject fields) = @@ -364,7 +366,7 @@ where unionCon UnionMember {memberName} = mkUnionFieldDefinition typeName memberName -mkUnionFieldDefinition :: CodeGenM m => TypeName -> TypeName -> m CodeGenConstructor +mkUnionFieldDefinition :: (CodeGenM m) => TypeName -> TypeName -> m CodeGenConstructor mkUnionFieldDefinition typeName memberName = do fieldType <- getFieldTypeName memberName pure $ @@ -382,10 +384,10 @@ where constructorName = CodeGenTypeName [coerce typeName] [] memberName -genArgumentTypes :: CodeGenM m => FieldsDefinition OUT CONST -> m [ServerDeclaration] +genArgumentTypes :: (CodeGenM m) => FieldsDefinition OUT CONST -> m [ServerDeclaration] genArgumentTypes = fmap concat . traverse genArgumentType . toList -genArgumentType :: CodeGenM m => FieldDefinition OUT CONST -> m [ServerDeclaration] +genArgumentType :: (CodeGenM m) => FieldDefinition OUT CONST -> m [ServerDeclaration] genArgumentType FieldDefinition { fieldName, diff --git a/src/Data/Morpheus/CodeGen/Server/Interpreting/Utils.hs b/src/Data/Morpheus/CodeGen/Server/Interpreting/Utils.hs --- a/src/Data/Morpheus/CodeGen/Server/Interpreting/Utils.hs +++ b/src/Data/Morpheus/CodeGen/Server/Interpreting/Utils.hs @@ -60,14 +60,14 @@ ( Dec (..), Info (..), Q, - TyVarBndr, reify, ) +import qualified Language.Haskell.TH as TH import Relude hiding (ByteString, get) class (MonadReader ServerCodeGenContext m, Monad m, MonadFail m, CodeGenMonad m, MonadState Flags m) => CodeGenM m -instance CodeGenMonad m => CodeGenM (CodeGenT ServerCodeGenContext m) +instance (CodeGenMonad m) => CodeGenM (CodeGenT ServerCodeGenContext m) data ServerCodeGenContext = ServerCodeGenContext { toArgsTypeName :: FieldName -> TypeName, @@ -78,17 +78,17 @@ hasNamespace :: Bool } -checkTypeExistence :: CodeGenM m => TypeName -> m () +checkTypeExistence :: (CodeGenM m) => TypeName -> m () checkTypeExistence name = do exists <- isJust <$> lookupType name if exists then pure () else requireExternal (unpackName name) -getFieldTypeName :: CodeGenM m => TypeName -> m TypeName +getFieldTypeName :: (CodeGenM m) => TypeName -> m TypeName getFieldTypeName name = checkTypeExistence name $> packName (toHaskellTypeName name) -getFieldName :: CodeGenM m => FieldName -> m FieldName +getFieldName :: (CodeGenM m) => FieldName -> m FieldName getFieldName fieldName = do ServerCodeGenContext {hasNamespace, currentTypeName} <- ask pure $ @@ -96,7 +96,7 @@ then maybe fieldName (`camelCaseFieldName` fieldName) currentTypeName else fieldName -getEnumName :: MonadReader ServerCodeGenContext m => TypeName -> m CodeGenTypeName +getEnumName :: (MonadReader ServerCodeGenContext m) => TypeName -> m CodeGenTypeName getEnumName enumName = do ServerCodeGenContext {hasNamespace, currentTypeName} <- ask pure $ @@ -108,7 +108,7 @@ isParametrizedType :: TypeName -> m Bool printWarnings :: [GQLError] -> m () -instance CodeGenMonad m => CodeGenMonad (CodeGenT ctx m) where +instance (CodeGenMonad m) => CodeGenMonad (CodeGenT ctx m) where isParametrizedType = lift . isParametrizedType printWarnings = lift . printWarnings @@ -122,10 +122,12 @@ -- Utils: is Parametrized type -#if MIN_VERSION_template_haskell(2,17,0) -getTypeVariables :: Dec -> [TyVarBndr ()] +#if MIN_VERSION_template_haskell(2,21,0) +getTypeVariables :: Dec -> [TH.TyVarBndr TH.BndrVis] +#elif MIN_VERSION_template_haskell(2,17,0) +getTypeVariables :: Dec -> [TH.TyVarBndr ()] #else -getTypeVariables :: Dec -> [TyVarBndr] +getTypeVariables :: Dec -> [TH.TyVarBndr] #endif getTypeVariables (DataD _ _ args _ _ _) = args getTypeVariables (NewtypeD _ _ args _ _ _) = args @@ -136,7 +138,7 @@ isParametrizedHaskellType (TyConI x) = not $ null $ getTypeVariables x isParametrizedHaskellType _ = False -isParametrizedResolverType :: CodeGenM m => TypeName -> [TypeDefinition ANY s] -> m Bool +isParametrizedResolverType :: (CodeGenM m) => TypeName -> [TypeDefinition ANY s] -> m Bool isParametrizedResolverType "__TypeKind" _ = pure False isParametrizedResolverType "Boolean" _ = pure False isParametrizedResolverType "String" _ = pure False @@ -146,19 +148,19 @@ Just x -> pure (isResolverType x) Nothing -> isParametrizedType name -isParamResolverType :: CodeGenM m => TypeName -> m Bool +isParamResolverType :: (CodeGenM m) => TypeName -> m Bool isParamResolverType typeConName = isParametrizedResolverType typeConName =<< asks typeDefinitions -notFoundError :: MonadFail m => String -> String -> m a +notFoundError :: (MonadFail m) => String -> String -> m a notFoundError name at = fail $ "can't found " <> name <> "at " <> at <> "!" -lookupType :: CodeGenM m => TypeName -> m (Maybe (TypeDefinition ANY CONST)) +lookupType :: (CodeGenM m) => TypeName -> m (Maybe (TypeDefinition ANY CONST)) lookupType name = do types <- asks typeDefinitions pure $ find (\t -> typeName t == name) types -lookupFieldType :: CodeGenM m => TypeName -> FieldName -> m TypeRef +lookupFieldType :: (CodeGenM m) => TypeName -> FieldName -> m TypeRef lookupFieldType name fieldName = do TypeDefinition {typeContent} <- lookupType name >>= maybe (notFoundError (show name) "type definitions") pure case typeContent of @@ -171,5 +173,5 @@ isSubscription (KIND_OBJECT (Just OPERATION_SUBSCRIPTION)) = True isSubscription _ = False -inType :: MonadReader ServerCodeGenContext m => Maybe TypeName -> m a -> m a +inType :: (MonadReader ServerCodeGenContext m) => Maybe TypeName -> m a -> m a inType name = local (\x -> x {currentTypeName = name, currentKind = Nothing})