diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} module Main @@ -64,25 +65,21 @@ main = defaultParser >>= runApp runApp :: App -> IO () -runApp - App - { operations, - options = Options {version, root} - } - | version = putStrLn currentVersion - | otherwise = runOperation operations - where - runOperation About = - putStrLn $ "Morpheus GraphQL CLI, version " <> currentVersion - runOperation Build {source} = traverse_ (processFile root) source +runApp App {..} + | version options = putStrLn currentVersion + | otherwise = runOperation operations + where + runOperation About = + putStrLn $ "Morpheus GraphQL CLI, version " <> currentVersion + runOperation Build {source} = traverse_ (processFile options) source -processFile :: FilePath -> FilePath -> IO () -processFile root path = +processFile :: Options -> FilePath -> IO () +processFile Options {root, namespaces} path = print (path, hsPath) >> L.readFile path >>= saveDocument hsPath . fmap (printServerTypeDefinitions PrinterConfig {moduleName}) - . parseServerTypeDefinitions CodeGenConfig {namespace = False} + . parseServerTypeDefinitions CodeGenConfig {namespace = namespaces} where hsPath = processFileName path moduleName = intercalate "." $ splitDirectories $ dropExtensions $ makeRelative root hsPath @@ -111,7 +108,8 @@ data Options = Options { version :: Bool, - root :: String + root :: String, + namespaces :: Bool } deriving (Show) @@ -129,6 +127,7 @@ Options <$> switch (long "version" <> short 'v' <> help "show Version number") <*> option readOutput (long "root" <> short 'r' <> help "Root directory of the Haskell project") + <*> switch (long "namespaces" <> short 'n' <> help "namespaces type fields to avoid name conflicts") readOutput :: ReadM String readOutput = eitherReader Right diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,3 @@ # Changelog see latest changes on [Github](https://github.com/morpheusgraphql/morpheus-graphql/releases) - -## 0.18.0 - 08.11.2021 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 @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: morpheus-graphql-code-gen -version: 0.21.0 +version: 0.22.0 synopsis: Morpheus GraphQL CLI description: code generator for Morpheus GraphQL category: web, graphql, cli @@ -28,16 +28,12 @@ library exposed-modules: Data.Morpheus.CodeGen - Data.Morpheus.CodeGen.Internal.AST - Data.Morpheus.CodeGen.Internal.TH - other-modules: - Data.Morpheus.CodeGen.Internal.Name - Data.Morpheus.CodeGen.Interpreting.Transform - Data.Morpheus.CodeGen.Printing.GQLType - Data.Morpheus.CodeGen.Printing.Render - Data.Morpheus.CodeGen.Printing.Terms - Data.Morpheus.CodeGen.Printing.Type Data.Morpheus.CodeGen.Server + other-modules: + Data.Morpheus.CodeGen.Server.Internal.AST + Data.Morpheus.CodeGen.Server.Interpreting.Transform + Data.Morpheus.CodeGen.Server.Printing.Document + Data.Morpheus.CodeGen.Server.Printing.TH Paths_morpheus_graphql_code_gen hs-source-dirs: src @@ -46,7 +42,10 @@ base >=4.7.0 && <5.0.0 , bytestring >=0.10.4 && <0.12.0 , containers >=0.4.2.1 && <0.7.0 - , morpheus-graphql-core >=0.21.0 && <0.22.0 + , file-embed >=0.0.10 && <1.0.0 + , morpheus-graphql-code-gen-utils >=0.22.0 && <0.23.0 + , morpheus-graphql-core >=0.22.0 && <0.23.0 + , morpheus-graphql-server >=0.22.0 && <0.23.0 , prettyprinter >=1.7.0 && <2.0.0 , relude >=0.3.0 && <2.0.0 , template-haskell >=2.0.0 && <3.0.0 @@ -65,9 +64,12 @@ base >=4.7.0 && <5.0.0 , bytestring >=0.10.4 && <0.12.0 , containers >=0.4.2.1 && <0.7.0 + , file-embed >=0.0.10 && <1.0.0 , filepath >=1.1.0 && <1.5.0 , morpheus-graphql-code-gen - , morpheus-graphql-core >=0.21.0 && <0.22.0 + , morpheus-graphql-code-gen-utils >=0.22.0 && <0.23.0 + , morpheus-graphql-core >=0.22.0 && <0.23.0 + , morpheus-graphql-server >=0.22.0 && <0.23.0 , optparse-applicative >=0.12.0 && <0.18.0 , prettyprinter >=1.7.0 && <2.0.0 , relude >=0.3.0 && <2.0.0 diff --git a/src/Data/Morpheus/CodeGen.hs b/src/Data/Morpheus/CodeGen.hs --- a/src/Data/Morpheus/CodeGen.hs +++ b/src/Data/Morpheus/CodeGen.hs @@ -8,13 +8,13 @@ ) where -import Data.Morpheus.CodeGen.Internal.AST - ( CodeGenConfig (..), - ) -import Data.Morpheus.CodeGen.Interpreting.Transform - ( parseServerTypeDefinitions, - ) import Data.Morpheus.CodeGen.Server ( PrinterConfig (..), printServerTypeDefinitions, + ) +import Data.Morpheus.CodeGen.Server.Internal.AST + ( CodeGenConfig (..), + ) +import Data.Morpheus.CodeGen.Server.Interpreting.Transform + ( parseServerTypeDefinitions, ) diff --git a/src/Data/Morpheus/CodeGen/Internal/AST.hs b/src/Data/Morpheus/CodeGen/Internal/AST.hs deleted file mode 100644 --- a/src/Data/Morpheus/CodeGen/Internal/AST.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.CodeGen.Internal.AST - ( ModuleDefinition (..), - CodeGenConfig (..), - ServerTypeDefinition (..), - GQLTypeDefinition (..), - CONST, - TypeKind (..), - TypeName, - TypeRef (..), - TypeWrapper (..), - unpackName, - DerivingClass (..), - FIELD_TYPE_WRAPPER (..), - ServerConstructorDefinition (..), - ServerFieldDefinition (..), - Kind (..), - ServerDirectiveUsage (..), - TypeValue (..), - ) -where - -import Data.Morpheus.Types.Internal.AST - ( CONST, - Description, - DirectiveLocation (..), - FieldName, - TypeKind (..), - TypeName, - TypeRef (..), - TypeWrapper (..), - Value, - unpackName, - ) -import Prettyprinter (Doc, Pretty (..), punctuate, vsep, (<+>)) -import Relude - -data ModuleDefinition = ModuleDefinition - { moduleName :: Text, - imports :: [(Text, [Text])], - extensions :: [Text], - types :: [ServerTypeDefinition] - } - -data FIELD_TYPE_WRAPPER - = MONAD - | SUBSCRIPTION - | PARAMETRIZED - | ARG TypeName - | TAGGED_ARG FieldName TypeRef - | GQL_WRAPPER TypeWrapper - deriving (Show) - -data DerivingClass - = SHOW - | GENERIC - deriving (Show) - -data ServerFieldDefinition = ServerFieldDefinition - { fieldType :: Text, - fieldName :: FieldName, - wrappers :: [FIELD_TYPE_WRAPPER] - } - deriving (Show) - -data Kind = Scalar | Type deriving (Show) - -data TypeValue - = TypeValueObject TypeName [(FieldName, TypeValue)] - | TypeValueNumber Double - | TypeValueString Text - | TypeValueBool Bool - | TypeValueList [TypeValue] - | TypedValueMaybe (Maybe TypeValue) - deriving (Show) - -renderField :: (FieldName, TypeValue) -> Doc n -renderField (fName, fValue) = pretty (unpackName fName :: Text) <> "=" <+> pretty fValue - -instance Pretty TypeValue where - pretty (TypeValueObject name xs) = - pretty (unpackName name :: Text) - <+> "{" - <+> vsep (punctuate "," (map renderField xs)) - <+> "}" - pretty (TypeValueNumber x) = pretty x - pretty (TypeValueString x) = pretty (show x :: String) - pretty (TypeValueBool x) = pretty x - pretty (TypedValueMaybe (Just x)) = "Just" <+> pretty x - pretty (TypedValueMaybe Nothing) = "Nothing" - pretty (TypeValueList xs) = prettyList xs - -data ServerDirectiveUsage - = TypeDirectiveUsage TypeValue - | FieldDirectiveUsage FieldName TypeValue - | EnumDirectiveUsage TypeName TypeValue - deriving (Show) - -data GQLTypeDefinition = GQLTypeDefinition - { gqlKind :: Kind, - gqlTypeDescription :: Maybe Text, - gqlTypeDescriptions :: Map Text Description, - gqlTypeDirectiveUses :: [ServerDirectiveUsage], - gqlTypeDefaultValues :: Map Text (Value CONST) - } - deriving (Show) - -data ServerConstructorDefinition = ServerConstructorDefinition - { constructorName :: TypeName, - constructorFields :: [ServerFieldDefinition] - } - deriving (Show) - -data ServerTypeDefinition - = ServerTypeDefinition - { tName :: Text, - typeParameters :: [Text], - tCons :: [ServerConstructorDefinition], - tKind :: TypeKind, - derives :: [DerivingClass], - typeGQLType :: Maybe GQLTypeDefinition - } - | DirectiveTypeDefinition - { directiveConstructor :: ServerConstructorDefinition, - directiveDerives :: [DerivingClass], - directiveLocations :: [DirectiveLocation], - directiveGQLType :: GQLTypeDefinition - } - | ServerInterfaceDefinition - TypeName - TypeName - TypeName - deriving (Show) - -newtype CodeGenConfig = CodeGenConfig - { namespace :: Bool - } diff --git a/src/Data/Morpheus/CodeGen/Internal/Name.hs b/src/Data/Morpheus/CodeGen/Internal/Name.hs deleted file mode 100644 --- a/src/Data/Morpheus/CodeGen/Internal/Name.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.CodeGen.Internal.Name - ( toHaskellTypeName, - camelCaseTypeName, - toHaskellName, - camelCaseFieldName, - ) -where - -import Data.Char - ( toLower, - toUpper, - ) -import Data.Morpheus.Types.Internal.AST - ( FieldName, - TypeName, - packName, - unpackName, - ) -import qualified Data.Morpheus.Types.Internal.AST as N -import qualified Data.Text as T -import Relude hiding - ( ToString (..), - Type, - ) - -mapFstChar :: (Char -> Char) -> Text -> Text -mapFstChar f x - | T.null x = x - | otherwise = T.singleton (f $ T.head x) <> T.tail x - -capitalize :: Text -> Text -capitalize = mapFstChar toUpper - -camelCaseTypeName :: [N.Name t] -> TypeName -> TypeName -camelCaseTypeName list name = - packName $ - T.concat $ - map (capitalize . unpackName) (list <> [coerce name]) - -toHaskellTypeName :: TypeName -> Text -toHaskellTypeName "String" = "Text" -toHaskellTypeName "Boolean" = "Bool" -toHaskellTypeName "Float" = "Double" -toHaskellTypeName name = capitalize $ unpackName name -{-# INLINE toHaskellTypeName #-} - -uncapitalize :: Text -> Text -uncapitalize = mapFstChar toLower - -camelCaseFieldName :: TypeName -> FieldName -> FieldName -camelCaseFieldName nSpace name = - packName $ - uncapitalize (unpackName nSpace) - <> capitalize (unpackName name) - -toHaskellName :: FieldName -> String -toHaskellName name - | isReserved name = T.unpack (unpackName name <> "'") - | otherwise = T.unpack (uncapitalize (unpackName name)) -{-# INLINE toHaskellName #-} - --- handle reserved Names -isReserved :: FieldName -> Bool -isReserved "case" = True -isReserved "class" = True -isReserved "data" = True -isReserved "default" = True -isReserved "deriving" = True -isReserved "do" = True -isReserved "else" = True -isReserved "foreign" = True -isReserved "if" = True -isReserved "import" = True -isReserved "in" = True -isReserved "infix" = True -isReserved "infixl" = True -isReserved "infixr" = True -isReserved "instance" = True -isReserved "let" = True -isReserved "module" = True -isReserved "newtype" = True -isReserved "of" = True -isReserved "then" = True -isReserved "type" = True -isReserved "where" = True -isReserved "_" = True -isReserved _ = False -{-# INLINE isReserved #-} diff --git a/src/Data/Morpheus/CodeGen/Internal/TH.hs b/src/Data/Morpheus/CodeGen/Internal/TH.hs deleted file mode 100644 --- a/src/Data/Morpheus/CodeGen/Internal/TH.hs +++ /dev/null @@ -1,191 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.CodeGen.Internal.TH - ( _', - apply, - applyCons, - applyVars, - declareTypeRef, - funDSimple, - camelCaseFieldName, - camelCaseTypeName, - toCon, - toVar, - ToName (..), - toString, - typeInstanceDec, - v', - vars, - wrappedType, - ) -where - -import Data.Morpheus.CodeGen.Internal.Name - ( camelCaseFieldName, - camelCaseTypeName, - toHaskellName, - toHaskellTypeName, - ) -import Data.Morpheus.Types.Internal.AST - ( FieldName, - TypeName, - TypeRef (..), - TypeWrapper (..), - unpackName, - ) -import qualified Data.Text as T -import Language.Haskell.TH -import Relude hiding - ( ToString (..), - Type, - ) - -_' :: PatQ -_' = toVar (mkName "_") - -v' :: ToVar Name a => a -v' = toVar (mkName "v") - -wrappedType :: TypeWrapper -> Type -> Type -wrappedType (TypeList xs nonNull) = withNonNull nonNull . withList . wrappedType xs -wrappedType (BaseType nonNull) = withNonNull nonNull -{-# INLINE wrappedType #-} - -declareTypeRef :: (TypeName -> Type) -> TypeRef -> Type -declareTypeRef f TypeRef {typeConName, typeWrappers} = - wrappedType typeWrappers (f typeConName) -{-# INLINE declareTypeRef #-} - -withList :: Type -> Type -withList = AppT (ConT ''[]) - -withNonNull :: Bool -> Type -> Type -withNonNull True = id -withNonNull False = AppT (ConT ''Maybe) -{-# INLINE withNonNull #-} - -cons :: ToCon a b => [a] -> [b] -cons = map toCon - -vars :: ToVar a b => [a] -> [b] -vars = map toVar - -class ToName a where - toName :: a -> Name - -instance ToName String where - toName = mkName - -instance ToName Name where - toName = id - -instance ToName Text where - toName = toName . T.unpack - -instance ToName TypeName where - toName = toName . toHaskellTypeName - -instance ToName FieldName where - toName = mkName . toHaskellName - -class ToString a b where - toString :: a -> b - -instance ToString a b => ToString a (Q b) where - toString = pure . toString - -instance ToString TypeName Lit where - toString = stringL . T.unpack . unpackName - -instance ToString TypeName Pat where - toString = LitP . toString - -instance ToString FieldName Lit where - toString = stringL . T.unpack . unpackName - -instance ToString TypeName Exp where - toString = LitE . toString - -instance ToString FieldName Exp where - toString = LitE . toString - -class ToCon a b where - toCon :: a -> b - -instance ToCon a b => ToCon a (Q b) where - toCon = pure . toCon - -instance (ToName a) => ToCon a Type where - toCon = ConT . toName - -instance (ToName a) => ToCon a Exp where - toCon = ConE . toName - -class ToVar a b where - toVar :: a -> b - -instance ToVar a b => ToVar a (Q b) where - toVar = pure . toVar - -instance (ToName a) => ToVar a Type where - toVar = VarT . toName - -instance (ToName a) => ToVar a Exp where - toVar = VarE . toName - -instance (ToName a) => ToVar a Pat where - toVar = VarP . toName - -class Apply a where - apply :: ToCon i a => i -> [a] -> a - -instance Apply TypeQ where - apply = foldl' appT . toCon - -instance Apply Type where - apply = foldl' AppT . toCon - -instance Apply Exp where - apply = foldl' AppE . toCon - -instance Apply ExpQ where - apply = foldl' appE . toCon - -applyVars :: - ( ToName con, - ToName var, - Apply res, - ToCon con res, - ToVar var res - ) => - con -> - [var] -> - res -applyVars name li = apply name (vars li) - -applyCons :: (ToName con, ToName cons) => con -> [cons] -> Q Type -applyCons name li = apply name (cons li) - -funDSimple :: Name -> [PatQ] -> ExpQ -> DecQ -funDSimple name args body = funD name [clause args (normalB body) []] - -#if MIN_VERSION_template_haskell(2,15,0) --- fix breaking changes -typeInstanceDec :: Name -> Type -> Type -> Dec -typeInstanceDec typeFamily arg res = TySynInstD (TySynEqn Nothing (AppT (ConT typeFamily) arg) res) -#else --- -typeInstanceDec :: Name -> Type -> Type -> Dec -typeInstanceDec typeFamily arg res = TySynInstD typeFamily (TySynEqn [arg] res) -#endif diff --git a/src/Data/Morpheus/CodeGen/Interpreting/Transform.hs b/src/Data/Morpheus/CodeGen/Interpreting/Transform.hs deleted file mode 100644 --- a/src/Data/Morpheus/CodeGen/Interpreting/Transform.hs +++ /dev/null @@ -1,608 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.CodeGen.Interpreting.Transform - ( parseServerTypeDefinitions, - ) -where - -import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Morpheus.CodeGen.Internal.AST - ( CodeGenConfig (..), - DerivingClass (..), - FIELD_TYPE_WRAPPER (..), - GQLTypeDefinition (..), - Kind (..), - ServerConstructorDefinition (..), - ServerDirectiveUsage (..), - ServerFieldDefinition (..), - ServerTypeDefinition (..), - TypeValue (..), - ) -import Data.Morpheus.CodeGen.Internal.Name - ( camelCaseFieldName, - toHaskellTypeName, - ) -import Data.Morpheus.CodeGen.Internal.TH - ( ToName (toName), - camelCaseTypeName, - ) -import Data.Morpheus.Core (internalSchema, parseDefinitions, render) -import Data.Morpheus.Error (gqlWarnings, renderGQLErrors) -import Data.Morpheus.Internal.Ext (GQLResult, Result (..)) -import Data.Morpheus.Internal.Utils (IsMap, selectOr) -import Data.Morpheus.Types.Internal.AST - ( ANY, - Argument (..), - ArgumentDefinition (..), - CONST, - DataEnumValue (..), - Description, - Directive (Directive, directiveArgs, directiveName), - DirectiveDefinition (..), - FieldContent (..), - FieldDefinition (..), - FieldName, - FieldsDefinition, - GQLError, - IN, - OUT, - ObjectEntry (..), - OperationType (Subscription), - RawTypeDefinition (..), - TRUE, - Token, - TypeContent (..), - TypeDefinition (..), - TypeKind (..), - TypeName, - TypeRef (..), - UnionMember (..), - isPossibleInterfaceType, - isResolverType, - kindOf, - lookupWith, - unpackName, - ) -import qualified Data.Morpheus.Types.Internal.AST as AST -import qualified Data.Morpheus.Types.Internal.AST as V -import Language.Haskell.TH - ( Dec (..), - Info (..), - Q, - TyVarBndr, - reify, - ) -import Relude hiding (ByteString, get) - -type ServerQ m = ReaderT (TypeContext CONST) m - -class (Monad m, MonadFail m) => CodeGenMonad m where - isParametrizedType :: TypeName -> m Bool - printWarnings :: [GQLError] -> m () - -isParametrizedHaskellType :: Info -> Bool -isParametrizedHaskellType (TyConI x) = not $ null $ getTypeVariables x -isParametrizedHaskellType _ = False - -#if MIN_VERSION_template_haskell(2,17,0) -getTypeVariables :: Dec -> [TyVarBndr ()] -#else -getTypeVariables :: Dec -> [TyVarBndr] -#endif -getTypeVariables (DataD _ _ args _ _ _) = args -getTypeVariables (NewtypeD _ _ args _ _ _) = args -getTypeVariables (TySynD _ args _) = args -getTypeVariables _ = [] - -instance CodeGenMonad Q where - isParametrizedType name = isParametrizedHaskellType <$> reify (toName name) - printWarnings = gqlWarnings - -instance CodeGenMonad GQLResult where - isParametrizedType _ = pure False - printWarnings _ = pure () - -data TypeContext s = TypeContext - { toArgsTypeName :: FieldName -> TypeName, - typeDefinitions :: [TypeDefinition ANY s], - directiveDefinitions :: [DirectiveDefinition s], - currentTypeName :: Maybe TypeName, - currentKind :: Maybe TypeKind, - hasNamespace :: Bool - } - -parseServerTypeDefinitions :: CodeGenMonad m => CodeGenConfig -> ByteString -> m [ServerTypeDefinition] -parseServerTypeDefinitions ctx txt = - case parseDefinitions txt of - Failure errors -> fail (renderGQLErrors errors) - Success {result, warnings} -> printWarnings warnings >> toTHDefinitions (namespace ctx) result - -toTHDefinitions :: - CodeGenMonad m => - Bool -> - [RawTypeDefinition] -> - m [ServerTypeDefinition] -toTHDefinitions namespace defs = concat <$> traverse generateTypes defs - where - typeDefinitions = [td | RawTypeDefinition td <- defs] - directiveDefinitions = [td | RawDirectiveDefinition td <- defs] - generateTypes :: CodeGenMonad m => RawTypeDefinition -> m [ServerTypeDefinition] - generateTypes (RawTypeDefinition typeDef) = - runReaderT - (genTypeDefinition typeDef) - TypeContext - { toArgsTypeName = mkArgsTypeName namespace (typeName typeDef), - typeDefinitions, - directiveDefinitions, - currentTypeName = Just (typeName typeDef), - currentKind = Just (kindOf typeDef), - hasNamespace = namespace - } - generateTypes (RawDirectiveDefinition DirectiveDefinition {..}) = - runReaderT - ( do - fields <- traverse renderDataField (argument <$> toList directiveDefinitionArgs) - pure - [ DirectiveTypeDefinition - { directiveConstructor = ServerConstructorDefinition (coerce directiveDefinitionName) fields, - directiveDerives = [SHOW, GENERIC], - directiveLocations = directiveDefinitionLocations, - directiveGQLType = - GQLTypeDefinition - { gqlKind = Type, - gqlTypeDescription = Nothing, - gqlTypeDescriptions = mempty, - gqlTypeDefaultValues = mempty, - gqlTypeDirectiveUses = [] - } - } - ] - ) - TypeContext - { toArgsTypeName = coerce, - typeDefinitions, - currentTypeName = Just (coerce directiveDefinitionName), - directiveDefinitions, - currentKind = Nothing, - hasNamespace = namespace - } - generateTypes _ = pure [] - -inType :: MonadReader (TypeContext s) m => Maybe TypeName -> m a -> m a -inType name = local (\x -> x {currentTypeName = name, currentKind = Nothing}) - -mkInterfaceName :: TypeName -> TypeName -mkInterfaceName = ("Interface" <>) - -mkPossibleTypesName :: TypeName -> TypeName -mkPossibleTypesName = ("PossibleTypes" <>) - -genTypeDefinition :: - CodeGenMonad m => - TypeDefinition ANY CONST -> - ServerQ m [ServerTypeDefinition] -genTypeDefinition - typeDef@TypeDefinition - { typeName = originalTypeName, - typeContent, - typeDescription - } = genTypeContent originalTypeName typeContent >>= withType - where - typeName = case typeContent of - DataInterface {} -> mkInterfaceName originalTypeName - _ -> originalTypeName - tKind = kindOf typeDef - tName = toHaskellTypeName typeName - deriveGQL = do - gqlTypeDescriptions <- getDesc typeDef - gqlTypeDirectiveUses <- getDirs typeDef - pure $ - Just - GQLTypeDefinition - { gqlTypeDescription = typeDescription, - gqlTypeDescriptions, - gqlTypeDirectiveUses, - gqlKind = derivingKind tKind, - gqlTypeDefaultValues = - fromList $ - mapMaybe getDefaultValue $ - getInputFields typeDef - } - typeParameters - | isResolverType tKind = ["m"] - | otherwise = [] - derives = derivesClasses (isResolverType tKind) - ------------------------- - withType (ConsIN tCons) = do - typeGQLType <- deriveGQL - pure [ServerTypeDefinition {..}] - withType (ConsOUT others tCons) = do - typeGQLType <- deriveGQL - pure (ServerTypeDefinition {..} : others) - -derivingKind :: TypeKind -> Kind -derivingKind KindScalar = Scalar -derivingKind _ = Type - -derivesClasses :: Bool -> [DerivingClass] -derivesClasses isResolver = GENERIC : [SHOW | not isResolver] - -mkObjectCons :: TypeName -> [ServerFieldDefinition] -> [ServerConstructorDefinition] -mkObjectCons name = pure . ServerConstructorDefinition name - -mkArgsTypeName :: Bool -> TypeName -> FieldName -> TypeName -mkArgsTypeName namespace typeName fieldName - | namespace = typeName <> argTName - | otherwise = argTName - where - argTName = camelCaseTypeName [fieldName] "Args" - -isParametrizedResolverType :: CodeGenMonad m => TypeName -> [TypeDefinition ANY s] -> m Bool -isParametrizedResolverType "__TypeKind" _ = pure False -isParametrizedResolverType "Boolean" _ = pure False -isParametrizedResolverType "String" _ = pure False -isParametrizedResolverType "Int" _ = pure False -isParametrizedResolverType "Float" _ = pure False -isParametrizedResolverType name lib = case lookupWith typeName name lib of - Just x -> pure (isResolverType x) - Nothing -> isParametrizedType name - -isSubscription :: TypeKind -> Bool -isSubscription (KindObject (Just Subscription)) = True -isSubscription _ = False - -mkObjectField :: - CodeGenMonad m => - FieldDefinition OUT CONST -> - ServerQ m ServerFieldDefinition -mkObjectField - FieldDefinition - { fieldName = fName, - fieldContent, - fieldType = TypeRef {typeConName, typeWrappers} - } = do - isParametrized <- lift . isParametrizedResolverType typeConName =<< asks typeDefinitions - genName <- asks toArgsTypeName - kind <- asks currentKind - fieldName <- renderFieldName fName - pure - ServerFieldDefinition - { fieldType = toHaskellTypeName typeConName, - wrappers = - mkFieldArguments fName genName (toArgList fieldContent) - <> [SUBSCRIPTION | fmap isSubscription kind == Just True] - <> [MONAD] - <> [GQL_WRAPPER typeWrappers] - <> [PARAMETRIZED | isParametrized], - .. - } - -mkFieldArguments :: FieldName -> (FieldName -> TypeName) -> [ArgumentDefinition s] -> [FIELD_TYPE_WRAPPER] -mkFieldArguments _ _ [] = [] -mkFieldArguments - _ - _ - [ ArgumentDefinition FieldDefinition {fieldName, fieldType} - ] = [TAGGED_ARG fieldName fieldType] -mkFieldArguments fName genName _ = [ARG (genName fName)] - -toArgList :: Maybe (FieldContent bool cat s) -> [ArgumentDefinition s] -toArgList (Just (FieldArgs args)) = toList args -toArgList _ = [] - -data BuildPlan - = ConsIN [ServerConstructorDefinition] - | ConsOUT [ServerTypeDefinition] [ServerConstructorDefinition] - -genInterfaceUnion :: Monad m => TypeName -> ServerQ m [ServerTypeDefinition] -genInterfaceUnion interfaceName = - mkInterface . map typeName . mapMaybe (isPossibleInterfaceType interfaceName) - <$> asks typeDefinitions - where - tKind = KindUnion - mkInterface [] = [] - mkInterface [possibleTypeName] = [mkGuardWithPossibleType possibleTypeName] - mkInterface members = - [ mkGuardWithPossibleType tName, - ServerTypeDefinition - { tName = toHaskellTypeName tName, - tCons = map (mkUnionFieldDefinition tName) members, - tKind, - typeParameters = ["m"], - derives = derivesClasses True, - typeGQLType = Nothing - } - ] - mkGuardWithPossibleType = ServerInterfaceDefinition interfaceName (mkInterfaceName interfaceName) - tName = mkPossibleTypesName interfaceName - -renderFieldName :: Monad m => FieldName -> ServerQ m FieldName -renderFieldName fieldName = do - TypeContext {hasNamespace, currentTypeName} <- ask - pure $ - if hasNamespace - then maybe fieldName (`camelCaseFieldName` fieldName) currentTypeName - else fieldName - -mkConsEnum :: Monad m => TypeName -> DataEnumValue CONST -> ServerQ m ServerConstructorDefinition -mkConsEnum name DataEnumValue {enumName} = do - namespace <- asks hasNamespace - pure - ServerConstructorDefinition - { constructorName = - if namespace - then camelCaseTypeName [name] enumName - else enumName, - constructorFields = [] - } - -renderDataField :: Monad m => FieldDefinition c CONST -> ServerQ m ServerFieldDefinition -renderDataField FieldDefinition {fieldType = TypeRef {typeConName, typeWrappers}, fieldName = fName} = do - fieldName <- renderFieldName fName - let wrappers = [GQL_WRAPPER typeWrappers] - let fieldType = toHaskellTypeName typeConName - pure ServerFieldDefinition {..} - -genTypeContent :: - CodeGenMonad m => - TypeName -> - TypeContent TRUE ANY CONST -> - ServerQ m BuildPlan -genTypeContent _ DataScalar {} = pure (ConsIN []) -genTypeContent typeName (DataEnum tags) = ConsIN <$> traverse (mkConsEnum typeName) tags -genTypeContent typeName (DataInputObject fields) = - ConsIN . mkObjectCons typeName <$> traverse renderDataField (toList fields) -genTypeContent _ DataInputUnion {} = fail "Input Unions not Supported" -genTypeContent typeName DataInterface {interfaceFields} = - ConsOUT - <$> ((<>) <$> genArgumentTypes interfaceFields <*> genInterfaceUnion typeName) - <*> ( do - let interfaceName = mkInterfaceName typeName - inType - (Just interfaceName) - ( mkObjectCons interfaceName - <$> traverse mkObjectField (toList interfaceFields) - ) - ) -genTypeContent typeName DataObject {objectFields} = - ConsOUT - <$> genArgumentTypes objectFields - <*> ( mkObjectCons typeName - <$> traverse mkObjectField (toList objectFields) - ) -genTypeContent typeName (DataUnion members) = - pure $ ConsOUT [] (unionCon <$> toList members) - where - unionCon UnionMember {memberName} = mkUnionFieldDefinition typeName memberName - -mkUnionFieldDefinition :: TypeName -> TypeName -> ServerConstructorDefinition -mkUnionFieldDefinition typeName memberName = - ServerConstructorDefinition - { constructorName, - constructorFields = - [ ServerFieldDefinition - { fieldName = coerce ("un" <> constructorName), - fieldType = toHaskellTypeName memberName, - wrappers = [PARAMETRIZED] - } - ] - } - where - constructorName = camelCaseTypeName [typeName] memberName - -genArgumentTypes :: Monad m => FieldsDefinition OUT CONST -> ServerQ m [ServerTypeDefinition] -genArgumentTypes = fmap concat . traverse genArgumentType . toList - -genArgumentType :: Monad m => FieldDefinition OUT CONST -> ServerQ m [ServerTypeDefinition] -genArgumentType - FieldDefinition - { fieldName, - fieldContent = Just (FieldArgs arguments) - } - | length arguments > 1 = do - tName <- (fieldName &) <$> asks toArgsTypeName - inType (Just tName) $ do - let argumentFields = argument <$> toList arguments - fields <- traverse renderDataField argumentFields - let tKind = KindInputObject - pure - [ ServerTypeDefinition - { tName = toHaskellTypeName tName, - tKind, - tCons = mkObjectCons tName fields, - derives = derivesClasses False, - typeParameters = [], - typeGQLType = - Just - ( GQLTypeDefinition - { gqlKind = Type, - gqlTypeDescription = Nothing, - gqlTypeDescriptions = fromList (mapMaybe mkFieldDescription argumentFields), - gqlTypeDefaultValues = fromList (mapMaybe getDefaultValue argumentFields), - gqlTypeDirectiveUses = [] - } - ) - } - ] -genArgumentType _ = pure [] - -mkFieldDescription :: FieldDefinition cat s -> Maybe (Text, Description) -mkFieldDescription FieldDefinition {..} = (unpackName fieldName,) <$> fieldDescription - ---- - -getDesc :: MonadFail m => TypeDefinition c CONST -> ServerQ m (Map Token Description) -getDesc = fmap fromList . get - -getDirs :: MonadFail m => TypeDefinition c CONST -> ServerQ m [ServerDirectiveUsage] -getDirs x = do - contentD <- map snd <$> get x - typeD <- traverse transform (toList $ AST.typeDirectives x) - pure (contentD <> typeD) - where - transform v = TypeDirectiveUsage <$> directiveTypeValue v - -class Meta a v where - get :: MonadFail m => a -> ServerQ m [(Token, v)] - -instance (Meta a v) => Meta (Maybe a) v where - get (Just x) = get x - get _ = pure [] - -instance - ( Meta (FieldsDefinition IN s) v, - Meta (FieldsDefinition OUT s) v, - Meta (DataEnumValue s) v - ) => - Meta (TypeDefinition c s) v - where - get TypeDefinition {typeContent} = get typeContent - -instance - ( Meta (FieldsDefinition IN s) v, - Meta (FieldsDefinition OUT s) v, - Meta (DataEnumValue s) v - ) => - Meta (TypeContent a c s) v - where - get DataObject {objectFields} = get objectFields - get DataInputObject {inputObjectFields} = get inputObjectFields - get DataInterface {interfaceFields} = get interfaceFields - get DataEnum {enumMembers} = concat <$> traverse get enumMembers - get _ = pure [] - -instance Meta (DataEnumValue CONST) Description where - get DataEnumValue {enumName, enumDescription = Just x} = pure [(unpackName enumName, x)] - get _ = pure [] - -instance Meta (DataEnumValue CONST) ServerDirectiveUsage where - get DataEnumValue {enumName, enumDirectives} - | null enumDirectives = pure [] - | otherwise = traverse transform (toList enumDirectives) - where - transform x = (unpackName enumName,) . EnumDirectiveUsage enumName <$> directiveTypeValue x - -instance - Meta (FieldDefinition c CONST) v => - Meta (FieldsDefinition c CONST) v - where - get = fmap concat . traverse get . toList - -instance Meta (FieldDefinition c CONST) Description where - get FieldDefinition {fieldName, fieldDescription = Just x} = pure [(unpackName fieldName, x)] - get _ = pure [] - -instance Meta (FieldDefinition c CONST) ServerDirectiveUsage where - get FieldDefinition {fieldName, fieldDirectives} - | null fieldDirectives = pure [] - | otherwise = traverse transform (toList fieldDirectives) - where - transform x = (unpackName fieldName,) . FieldDirectiveUsage fieldName <$> directiveTypeValue x - -getInputFields :: TypeDefinition c s -> [FieldDefinition IN s] -getInputFields TypeDefinition {typeContent = DataInputObject {inputObjectFields}} = toList inputObjectFields -getInputFields _ = [] - -getDefaultValue :: FieldDefinition c s -> Maybe (Text, V.Value s) -getDefaultValue - FieldDefinition - { fieldName, - fieldContent = Just DefaultInputValue {defaultInputValue} - } = Just (unpackName fieldName, defaultInputValue) -getDefaultValue _ = Nothing - -nativeDirectives :: V.DirectivesDefinition CONST -nativeDirectives = AST.directiveDefinitions internalSchema - -getDirective :: (MonadReader (TypeContext CONST) m, MonadFail m) => FieldName -> m (DirectiveDefinition CONST) -getDirective directiveName = do - dirs <- asks directiveDefinitions - case find (\DirectiveDefinition {directiveDefinitionName} -> directiveDefinitionName == directiveName) dirs of - Just dir -> pure dir - _ -> selectOr (fail $ "unknown directive" <> show directiveName) pure directiveName nativeDirectives - -directiveTypeValue :: MonadFail m => Directive CONST -> ServerQ m TypeValue -directiveTypeValue Directive {..} = inType typeContext $ do - dirs <- getDirective directiveName - TypeValueObject typename <$> traverse (renderArgumentValue directiveArgs) (toList $ directiveDefinitionArgs dirs) - where - (typeContext, typename) = renderDirectiveTypeName directiveName - -renderDirectiveTypeName :: FieldName -> (Maybe TypeName, TypeName) -renderDirectiveTypeName "deprecated" = (Nothing, "Deprecated") -renderDirectiveTypeName name = (Just (coerce name), coerce name) - -renderArgumentValue :: - (IsMap FieldName c, MonadFail m) => - c (Argument CONST) -> - ArgumentDefinition s -> - ReaderT (TypeContext CONST) m (FieldName, TypeValue) -renderArgumentValue args ArgumentDefinition {..} = do - let dirName = AST.fieldName argument - gqlValue <- selectOr (pure AST.Null) (pure . argumentValue) dirName args - typeValue <- mapWrappedValue (AST.fieldType argument) gqlValue - fName <- renderFieldName dirName - pure (fName, typeValue) - -notFound :: MonadFail m => String -> String -> m a -notFound name at = fail $ "can't found " <> name <> "at " <> at <> "!" - -lookupType :: MonadFail m => TypeName -> ServerQ m (TypeDefinition ANY CONST) -lookupType name = do - types <- asks typeDefinitions - case find (\t -> typeName t == name) types of - Just x -> pure x - Nothing -> notFound (show name) "type definitions" - -lookupValueFieldType :: MonadFail m => TypeName -> FieldName -> ServerQ m TypeRef -lookupValueFieldType name fieldName = do - TypeDefinition {typeContent} <- lookupType name - case typeContent of - DataInputObject fields -> do - FieldDefinition {fieldType} <- selectOr (notFound (show fieldName) (show name)) pure fieldName fields - pure fieldType - _ -> notFound "input object" (show name) - -mapField :: MonadFail m => TypeName -> ObjectEntry CONST -> ServerQ m (FieldName, TypeValue) -mapField tName ObjectEntry {..} = do - t <- lookupValueFieldType tName entryName - value <- mapWrappedValue t entryValue - pure (entryName, value) - -expected :: MonadFail m => String -> V.Value CONST -> ServerQ m TypeValue -expected typ value = fail ("expected " <> typ <> ", found " <> show (render value) <> "!") - -mapWrappedValue :: MonadFail m => TypeRef -> V.Value CONST -> ServerQ m TypeValue -mapWrappedValue (TypeRef name (AST.BaseType isRequired)) value - | isRequired = mapValue name value - | value == V.Null = pure (TypedValueMaybe Nothing) - | otherwise = TypedValueMaybe . Just <$> mapValue name value -mapWrappedValue (TypeRef name (AST.TypeList elems isRequired)) d = case d of - V.Null | not isRequired -> pure (TypedValueMaybe Nothing) - (V.List xs) -> TypedValueMaybe . Just . TypeValueList <$> traverse (mapWrappedValue (TypeRef name elems)) xs - value -> expected "list" value - -mapValue :: MonadFail m => TypeName -> V.Value CONST -> ServerQ m TypeValue -mapValue name (V.List xs) = TypeValueList <$> traverse (mapValue name) xs -mapValue _ (V.Enum name) = pure $ TypeValueObject name [] -mapValue name (V.Object fields) = TypeValueObject name <$> traverse (mapField name) (toList fields) -mapValue _ (V.Scalar x) = mapScalarValue x -mapValue t v = expected (show t) v - -mapScalarValue :: MonadFail m => V.ScalarValue -> ServerQ m TypeValue -mapScalarValue (V.Int x) = pure $ TypeValueNumber (fromIntegral x) -mapScalarValue (V.Float x) = pure $ TypeValueNumber x -mapScalarValue (V.String x) = pure $ TypeValueString x -mapScalarValue (V.Boolean x) = pure $ TypeValueBool x -mapScalarValue (V.Value _) = fail "JSON objects are not supported!" diff --git a/src/Data/Morpheus/CodeGen/Printing/GQLType.hs b/src/Data/Morpheus/CodeGen/Printing/GQLType.hs deleted file mode 100644 --- a/src/Data/Morpheus/CodeGen/Printing/GQLType.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.CodeGen.Printing.GQLType - ( renderGQLType, - ) -where - -import Data.Morpheus.CodeGen.Internal.AST - ( GQLTypeDefinition (..), - Kind (..), - ServerDirectiveUsage (..), - ServerTypeDefinition (..), - TypeKind, - ) -import Data.Morpheus.CodeGen.Printing.Terms - ( optional, - parametrizedType, - ) -import Prettyprinter -import Relude hiding (optional, show) -import Prelude (show) - -renderTypeableConstraints :: [Text] -> Doc n -renderTypeableConstraints xs = tupled (map (("Typeable" <+>) . pretty) xs) <+> "=>" - -defineTypeOptions :: Bool -> Text -> TypeKind -> Doc n -defineTypeOptions namespaces tName kind - | namespaces = "typeOptions _ = dropNamespaceOptions " <> pretty tName <> " (" <> pretty (show kind) <> ")" - | otherwise = "typeOptions _ options = options" - -renderGQLType :: ServerTypeDefinition -> Doc n -renderGQLType ServerTypeDefinition {..} = - "instance" - <> optional renderTypeableConstraints typeParameters - <+> "GQLType" - <+> typeHead - <+> "where" - <> line - <> indent 2 (vsep (renderMethods typeHead typeGQLType <> [options])) - where - options = defineTypeOptions False tName tKind - typeHead = - if null typeParameters - then parametrizedType tName typeParameters - else tupled (pure $ parametrizedType tName typeParameters) -renderGQLType _ = "" - -renderMethods :: Doc n -> Maybe GQLTypeDefinition -> [Doc n] -renderMethods _ Nothing = [] -renderMethods - typeHead - (Just GQLTypeDefinition {..}) = - ["type KIND" <+> typeHead <+> "=" <+> renderKind gqlKind] - <> ["description _ =" <+> pretty (show gqlTypeDescription) | not (null gqlTypeDescription)] - <> ["getDescriptions _ =" <+> pretty (show gqlTypeDescriptions) | not (null gqlTypeDescriptions)] - <> ["directives _=" <+> renderDirectiveUsages gqlTypeDirectiveUses | not (null gqlTypeDirectiveUses)] - -renderDirectiveUsages :: [ServerDirectiveUsage] -> Doc n -renderDirectiveUsages = align . vsep . punctuate " <>" . map renderDirectiveUsage - -renderDirectiveUsage :: ServerDirectiveUsage -> Doc n -renderDirectiveUsage (TypeDirectiveUsage value) = "typeDirective" <+> pretty value -renderDirectiveUsage (FieldDirectiveUsage place value) = "fieldDirective" <+> pretty (show place) <+> pretty value -renderDirectiveUsage (EnumDirectiveUsage place value) = "enumDirective" <+> pretty (show place) <+> pretty value - -renderKind :: Kind -> Doc n -renderKind Type = "TYPE" -renderKind Scalar = "SCALAR" diff --git a/src/Data/Morpheus/CodeGen/Printing/Render.hs b/src/Data/Morpheus/CodeGen/Printing/Render.hs deleted file mode 100644 --- a/src/Data/Morpheus/CodeGen/Printing/Render.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.CodeGen.Printing.Render - ( renderDocument, - ) -where - -import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Morpheus.CodeGen.Internal.AST - ( ModuleDefinition (..), - ServerTypeDefinition (..), - ) -import Data.Morpheus.CodeGen.Printing.Terms - ( renderExtension, - renderImport, - ) -import Data.Morpheus.CodeGen.Printing.Type - ( renderTypes, - ) -import Data.Text - ( pack, - ) -import qualified Data.Text.Lazy as LT - ( fromStrict, - ) -import Data.Text.Lazy.Encoding (encodeUtf8) -import Prettyprinter - ( Doc, - line, - pretty, - vsep, - (<+>), - ) -import Relude hiding (ByteString, encodeUtf8) - -renderDocument :: String -> [ServerTypeDefinition] -> ByteString -renderDocument moduleName types = - encodeUtf8 $ - LT.fromStrict $ - pack $ - show $ - renderModuleDefinition - ModuleDefinition - { moduleName = pack moduleName, - imports = - [ ("Data.Data", ["Typeable"]), - ("Data.Morpheus.Kind", ["TYPE"]), - ("Data.Morpheus.Types", []), - ("Data.Morpheus", []), - ("Data.Text", ["Text"]), - ("GHC.Generics", ["Generic"]), - ("Data.Map", ["fromList", "empty"]) - ], - extensions = - [ "DeriveAnyClass", - "DeriveGeneric", - "TypeFamilies", - "OverloadedStrings", - "DataKinds", - "DuplicateRecordFields" - ], - types - } - -renderModuleDefinition :: ModuleDefinition -> Doc n -renderModuleDefinition - ModuleDefinition - { extensions, - moduleName, - imports, - types - } = - vsep (map renderExtension extensions) - <> line - <> line - <> "module" - <+> pretty moduleName - <+> "where" - <> line - <> line - <> vsep (map renderImport imports) - <> line - <> line - <> either (error . show) id (renderTypes types) diff --git a/src/Data/Morpheus/CodeGen/Printing/Terms.hs b/src/Data/Morpheus/CodeGen/Printing/Terms.hs deleted file mode 100644 --- a/src/Data/Morpheus/CodeGen/Printing/Terms.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.CodeGen.Printing.Terms - ( renderExtension, - renderWrapped, - label, - parametrizedType, - TypeDoc (..), - appendType, - optional, - renderImport, - renderType, - renderName, - ) -where - -import Data.Morpheus.CodeGen.Internal.AST - ( TypeName, - TypeWrapper (..), - unpackName, - ) -import qualified Data.Text as T -import Prettyprinter - ( Doc, - hsep, - list, - pretty, - tupled, - (<+>), - ) -import Relude hiding (optional) - -parametrizedType :: Text -> [Text] -> Doc ann -parametrizedType tName typeParameters = hsep $ map pretty $ tName : typeParameters - --- TODO: this should be done in transformer -renderName :: TypeName -> Doc ann -renderName = pretty . T.unpack . unpackName - -renderExtension :: Text -> Doc ann -renderExtension name = "{-#" <+> "LANGUAGE" <+> pretty name <+> "#-}" - -data TypeDoc n = TypeDoc - { isComplex :: Bool, - unDoc :: Doc n - } - -renderType :: TypeDoc n -> Doc n -renderType TypeDoc {isComplex, unDoc = doc} = if isComplex then tupled [doc] else doc - -appendType :: TypeName -> TypeDoc n -> TypeDoc n -appendType t1 tyDoc = TypeDoc True $ renderName t1 <> " " <> renderType tyDoc - -renderMaybe :: Bool -> TypeDoc n -> TypeDoc n -renderMaybe True = id -renderMaybe False = appendType "Maybe" - -renderList :: TypeDoc n -> TypeDoc n -renderList = TypeDoc False . list . pure . unDoc - -renderWrapped :: TypeWrapper -> TypeDoc n -> TypeDoc n -renderWrapped (TypeList wrapper notNull) = renderMaybe notNull . renderList . renderWrapped wrapper -renderWrapped (BaseType notNull) = renderMaybe notNull - -label :: Text -> Doc ann -label typeName = "---- GQL " <> pretty typeName <> " -------------------------------\n" - -optional :: ([a] -> Doc n) -> [a] -> Doc n -optional _ [] = "" -optional f xs = " " <> f xs - -renderImport :: (Text, [Text]) -> Doc ann -renderImport (src, ls) = - "import" - <+> pretty src - <> optional (tupled . map pretty) ls diff --git a/src/Data/Morpheus/CodeGen/Printing/Type.hs b/src/Data/Morpheus/CodeGen/Printing/Type.hs deleted file mode 100644 --- a/src/Data/Morpheus/CodeGen/Printing/Type.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.CodeGen.Printing.Type - ( renderTypes, - ) -where - -import Data.Morpheus.CodeGen.Internal.AST - ( DerivingClass (..), - FIELD_TYPE_WRAPPER (..), - ServerConstructorDefinition (..), - ServerFieldDefinition (..), - ServerTypeDefinition (..), - TypeKind (..), - TypeRef (..), - unpackName, - ) -import Data.Morpheus.CodeGen.Printing.GQLType - ( renderGQLType, - ) -import Data.Morpheus.CodeGen.Printing.Terms - ( TypeDoc (TypeDoc, unDoc), - appendType, - label, - parametrizedType, - renderName, - renderType, - renderWrapped, - ) -import Prettyprinter - ( Doc, - comma, - enclose, - indent, - line, - nest, - pretty, - punctuate, - tupled, - vsep, - (<+>), - ) -import Relude hiding (show) -import Prelude (show) - -type Result = Either Text - -renderTypes :: [ServerTypeDefinition] -> Either Text (Doc ann) -renderTypes = fmap vsep . traverse render - -class RenderType a where - render :: a -> Result (Doc ann) - -instance RenderType DerivingClass where - render SHOW = pure "Show" - render GENERIC = pure "Generic" - -instance RenderType ServerTypeDefinition where - render ServerInterfaceDefinition {} = fail "not supported" - -- TODO: on scalar we should render user provided type - render ServerTypeDefinition {tKind = KindScalar, tName} = - pure $ label tName <> "type" <+> pretty tName <+> "= Int" - render typeDef@ServerTypeDefinition {tName, tCons, typeParameters, derives} = do - typeRendering <- renderTypeDef - pure $ label tName <> vsep [typeRendering, renderGQLType typeDef] - where - renderTypeDef = do - cons <- renderConstructors tCons - derivations <- renderDeriving derives - pure $ - "data" - <+> parametrizedType tName typeParameters - <> cons - <> line - <> indent 2 derivations - <> line - renderConstructors [cons] = (" =" <+>) <$> render cons - renderConstructors conses = nest 2 . (line <>) . vsep . prefixVariants <$> traverse render conses - prefixVariants (x : xs) = "=" <+> x : map ("|" <+>) xs - prefixVariants [] = [] - render typeDef@DirectiveTypeDefinition {directiveConstructor, directiveDerives} = do - typeRendering <- renderTypeDef - pure $ label name <> vsep [typeRendering, renderGQLType typeDef] - where - renderTypeDef = do - cons <- (" =" <+>) <$> render directiveConstructor - derivations <- renderDeriving directiveDerives - pure $ - "data" - <+> parametrizedType name [] - <> cons - <> line - <> indent 2 derivations - <> line - name = unpackName (constructorName directiveConstructor) - -renderDeriving :: [DerivingClass] -> Result (Doc n) -renderDeriving list = ("deriving" <+>) . tupled <$> traverse render list - -instance RenderType ServerConstructorDefinition where - render ServerConstructorDefinition {constructorName, constructorFields = []} = - pure $ renderName constructorName - render ServerConstructorDefinition {constructorName, constructorFields} = do - fields <- traverse render constructorFields - pure $ renderName constructorName <> renderSet fields - where - renderSet = nest 2 . enclose "\n{ " "\n}" . nest 2 . vsep . punctuate comma - -instance RenderType ServerFieldDefinition where - render - ServerFieldDefinition - { fieldName, - wrappers, - fieldType - } = - pure $ - pretty (unpackName fieldName :: Text) - <+> "::" - <+> unDoc (foldr renderWrapper (TypeDoc False $ pretty fieldType) wrappers) - -renderWrapper :: FIELD_TYPE_WRAPPER -> TypeDoc n -> TypeDoc n -renderWrapper PARAMETRIZED = \x -> TypeDoc True (unDoc x <+> "m") -renderWrapper MONAD = appendType "m" -renderWrapper SUBSCRIPTION = id -renderWrapper (GQL_WRAPPER typeWrappers) = renderWrapped typeWrappers -renderWrapper (ARG name) = TypeDoc True . ((renderName name <+> "->") <+>) . unDoc -renderWrapper (TAGGED_ARG name typeRef) = - TypeDoc True - . ( ( "Arg" - <+> pretty (show name) - <+> renderType (renderTypeRef typeRef) - <+> "->" - ) - <+> - ) - . unDoc - -renderTypeRef :: TypeRef -> TypeDoc n -renderTypeRef - TypeRef - { typeConName, - typeWrappers - } = - renderWrapped - typeWrappers - (TypeDoc False (renderName typeConName)) diff --git a/src/Data/Morpheus/CodeGen/Server.hs b/src/Data/Morpheus/CodeGen/Server.hs --- a/src/Data/Morpheus/CodeGen/Server.hs +++ b/src/Data/Morpheus/CodeGen/Server.hs @@ -2,23 +2,46 @@ {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.CodeGen.Server - ( printServerTypeDefinitions, + ( CodeGenConfig (..), PrinterConfig (..), + gqlDocument, + importServerTypeDefinitions, + printServerTypeDefinitions, ) where -import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Morpheus.CodeGen.Internal.AST - ( ServerTypeDefinition, +import Data.ByteString.Lazy.Char8 + ( ByteString, + readFile, ) -import Data.Morpheus.CodeGen.Printing.Render +import Data.FileEmbed (makeRelativeToProject) +import Data.Morpheus.CodeGen.Server.Internal.AST + ( CodeGenConfig (..), + ServerDeclaration, + ) +import Data.Morpheus.CodeGen.Server.Printing.Document ( renderDocument, ) -import Relude hiding (ByteString) +import Data.Morpheus.CodeGen.Server.Printing.TH + ( compileDocument, + gqlDocument, + ) +import Language.Haskell.TH (Dec, Q, runIO) +import Language.Haskell.TH.Syntax + ( qAddDependentFile, + ) +import Relude hiding (ByteString, readFile) newtype PrinterConfig = PrinterConfig { moduleName :: String } -printServerTypeDefinitions :: PrinterConfig -> [ServerTypeDefinition] -> ByteString +printServerTypeDefinitions :: PrinterConfig -> [ServerDeclaration] -> ByteString printServerTypeDefinitions PrinterConfig {moduleName} = renderDocument moduleName + +importServerTypeDefinitions :: CodeGenConfig -> FilePath -> Q [Dec] +importServerTypeDefinitions ctx rawSrc = do + src <- makeRelativeToProject rawSrc + qAddDependentFile src + runIO (readFile src) + >>= compileDocument ctx diff --git a/src/Data/Morpheus/CodeGen/Server/Internal/AST.hs b/src/Data/Morpheus/CodeGen/Server/Internal/AST.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/CodeGen/Server/Internal/AST.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.CodeGen.Server.Internal.AST + ( ModuleDefinition (..), + CodeGenConfig (..), + ServerDeclaration (..), + GQLTypeDefinition (..), + CONST, + TypeKind (..), + TypeName, + TypeRef (..), + TypeWrapper (..), + unpackName, + DerivingClass (..), + FIELD_TYPE_WRAPPER (..), + Kind (..), + ServerDirectiveUsage (..), + TypeValue (..), + InterfaceDefinition (..), + GQLDirectiveTypeClass (..), + ) +where + +import Data.Morpheus.CodeGen.Internal.AST + ( CodeGenType, + CodeGenTypeName, + DerivingClass (..), + FIELD_TYPE_WRAPPER (..), + TypeValue (..), + ) +import Data.Morpheus.CodeGen.TH + ( PrintExp (..), + PrintType (..), + ) +import Data.Morpheus.Server.Types + ( SCALAR, + TYPE, + enumDirective, + fieldDirective, + typeDirective, + ) +import Data.Morpheus.Types.Internal.AST + ( CONST, + DirectiveLocation (..), + FieldName, + TypeKind (..), + TypeName, + TypeRef (..), + TypeWrapper (..), + Value, + unpackName, + ) +import Language.Haskell.TH.Lib (appE, conT, varE) +import Prettyprinter (Pretty (..), (<+>)) +import Relude + +data ModuleDefinition = ModuleDefinition + { moduleName :: Text, + imports :: [(Text, [Text])], + extensions :: [Text], + types :: [ServerDeclaration] + } + +data Kind + = Scalar + | Type + deriving (Show, Eq) + +instance Pretty Kind where + pretty Type = "TYPE" + pretty Scalar = "SCALAR" + +instance PrintType Kind where + printType Scalar = conT ''SCALAR + printType Type = conT ''TYPE + +data ServerDirectiveUsage + = TypeDirectiveUsage TypeValue + | FieldDirectiveUsage FieldName TypeValue + | EnumDirectiveUsage TypeName TypeValue + deriving (Show) + +instance PrintExp ServerDirectiveUsage where + printExp (TypeDirectiveUsage x) = appE (varE 'typeDirective) (printExp x) + printExp (FieldDirectiveUsage field x) = appE (appE (varE 'fieldDirective) [|field|]) (printExp x) + printExp (EnumDirectiveUsage enum x) = appE (appE (varE 'enumDirective) [|enum|]) (printExp x) + +instance Pretty ServerDirectiveUsage where + pretty (TypeDirectiveUsage value) = "typeDirective" <+> pretty value + pretty (FieldDirectiveUsage place value) = "fieldDirective" <+> pretty (show place :: String) <+> pretty value + pretty (EnumDirectiveUsage place value) = "enumDirective" <+> pretty (show place :: String) <+> pretty value + +data GQLTypeDefinition = GQLTypeDefinition + { gqlTarget :: CodeGenTypeName, + gqlKind :: Kind, + gqlTypeDirectiveUses :: [ServerDirectiveUsage], + gqlTypeDefaultValues :: Map Text (Value CONST), + dropNamespace :: Maybe (TypeKind, Text) + } + deriving (Show) + +data InterfaceDefinition = InterfaceDefinition + { aliasName :: TypeName, + interfaceName :: TypeName, + unionName :: TypeName + } + deriving (Show) + +data GQLDirectiveTypeClass = GQLDirectiveTypeClass + { directiveTypeName :: CodeGenTypeName, + directiveLocations :: [DirectiveLocation] + } + deriving (Show) + +data ServerDeclaration + = GQLTypeInstance GQLTypeDefinition + | GQLDirectiveInstance GQLDirectiveTypeClass + | DataType CodeGenType + | ScalarType {scalarTypeName :: Text} + | InterfaceType InterfaceDefinition + deriving (Show) + +newtype CodeGenConfig = CodeGenConfig + { namespace :: Bool + } diff --git a/src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs b/src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs @@ -0,0 +1,613 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.CodeGen.Server.Interpreting.Transform + ( parseServerTypeDefinitions, + ) +where + +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Morpheus.CodeGen.Internal.AST + ( CodeGenConstructor (..), + CodeGenField (..), + CodeGenType (..), + CodeGenTypeName (CodeGenTypeName), + fromTypeName, + getFullName, + ) +import Data.Morpheus.CodeGen.Server.Internal.AST + ( CodeGenConfig (..), + DerivingClass (..), + FIELD_TYPE_WRAPPER (..), + GQLDirectiveTypeClass (..), + GQLTypeDefinition (..), + InterfaceDefinition (..), + Kind (..), + ServerDeclaration (..), + ServerDirectiveUsage (..), + TypeValue (..), + ) +import Data.Morpheus.CodeGen.TH + ( ToName (toName), + ) +import Data.Morpheus.CodeGen.Utils + ( camelCaseFieldName, + camelCaseTypeName, + toHaskellTypeName, + ) +import Data.Morpheus.Core (internalSchema, parseDefinitions, render) +import Data.Morpheus.Error (gqlWarnings, renderGQLErrors) +import Data.Morpheus.Internal.Ext (GQLResult, Result (..)) +import Data.Morpheus.Internal.Utils (IsMap, selectOr) +import Data.Morpheus.Server.Types (Arg, SubscriptionField) +import Data.Morpheus.Types.Internal.AST + ( ANY, + Argument (..), + ArgumentDefinition (..), + CONST, + DataEnumValue (..), + Description, + Directive (Directive, directiveArgs, directiveName), + DirectiveDefinition (..), + FieldContent (..), + FieldDefinition (..), + FieldName, + FieldsDefinition, + GQLError, + IN, + OUT, + ObjectEntry (..), + OperationType (Subscription), + RawTypeDefinition (..), + TRUE, + TypeContent (..), + TypeDefinition (..), + TypeKind (..), + TypeName, + TypeRef (..), + UnionMember (..), + isNullable, + isPossibleInterfaceType, + isResolverType, + kindOf, + lookupWith, + packName, + unpackName, + ) +import qualified Data.Morpheus.Types.Internal.AST as AST +import qualified Data.Morpheus.Types.Internal.AST as V +import Language.Haskell.TH + ( Dec (..), + Info (..), + Q, + TyVarBndr, + reify, + ) +import Relude hiding (ByteString, get) + +type ServerQ m = ReaderT (TypeContext CONST) m + +class (Monad m, MonadFail m) => CodeGenMonad m where + isParametrizedType :: TypeName -> m Bool + printWarnings :: [GQLError] -> m () + +isParametrizedHaskellType :: Info -> Bool +isParametrizedHaskellType (TyConI x) = not $ null $ getTypeVariables x +isParametrizedHaskellType _ = False + +#if MIN_VERSION_template_haskell(2,17,0) +getTypeVariables :: Dec -> [TyVarBndr ()] +#else +getTypeVariables :: Dec -> [TyVarBndr] +#endif +getTypeVariables (DataD _ _ args _ _ _) = args +getTypeVariables (NewtypeD _ _ args _ _ _) = args +getTypeVariables (TySynD _ args _) = args +getTypeVariables _ = [] + +instance CodeGenMonad Q where + isParametrizedType name = isParametrizedHaskellType <$> reify (toName name) + printWarnings = gqlWarnings + +instance CodeGenMonad GQLResult where + isParametrizedType _ = pure False + printWarnings _ = pure () + +data TypeContext s = TypeContext + { toArgsTypeName :: FieldName -> TypeName, + typeDefinitions :: [TypeDefinition ANY s], + directiveDefinitions :: [DirectiveDefinition s], + currentTypeName :: Maybe TypeName, + currentKind :: Maybe TypeKind, + hasNamespace :: Bool + } + +parseServerTypeDefinitions :: CodeGenMonad m => CodeGenConfig -> ByteString -> m [ServerDeclaration] +parseServerTypeDefinitions ctx txt = + case parseDefinitions txt of + Failure errors -> fail (renderGQLErrors errors) + Success {result, warnings} -> printWarnings warnings >> toTHDefinitions (namespace ctx) result + +toTHDefinitions :: + CodeGenMonad m => + Bool -> + [RawTypeDefinition] -> + m [ServerDeclaration] +toTHDefinitions namespace defs = concat <$> traverse generateTypes defs + where + typeDefinitions = [td | RawTypeDefinition td <- defs] + directiveDefinitions = [td | RawDirectiveDefinition td <- defs] + generateTypes :: CodeGenMonad m => RawTypeDefinition -> m [ServerDeclaration] + generateTypes (RawTypeDefinition typeDef) = + runReaderT + (genTypeDefinition typeDef) + TypeContext + { toArgsTypeName = mkArgsTypeName namespace (typeName typeDef), + typeDefinitions, + directiveDefinitions, + currentTypeName = Just (typeName typeDef), + currentKind = Just (kindOf typeDef), + hasNamespace = namespace + } + generateTypes (RawDirectiveDefinition DirectiveDefinition {..}) = + runReaderT + ( do + fields <- traverse renderDataField (argument <$> toList directiveDefinitionArgs) + let typename = coerce directiveDefinitionName + dropNamespace <- defineTypeOptions KindInputObject (unpackName typename) + let cgTypeName = fromTypeName typename + pure + [ DataType + CodeGenType + { cgTypeName, + cgConstructors = [CodeGenConstructor (fromTypeName typename) fields], + cgDerivations = [SHOW, GENERIC] + }, + GQLDirectiveInstance + GQLDirectiveTypeClass + { directiveTypeName = cgTypeName, + directiveLocations = directiveDefinitionLocations + }, + GQLTypeInstance + GQLTypeDefinition + { gqlTarget = cgTypeName, + gqlKind = Type, + gqlTypeDefaultValues = mempty, + gqlTypeDirectiveUses = [], + dropNamespace + } + ] + ) + TypeContext + { toArgsTypeName = coerce, + typeDefinitions, + currentTypeName = Just (coerce directiveDefinitionName), + directiveDefinitions, + currentKind = Nothing, + hasNamespace = namespace + } + generateTypes _ = pure [] + +defineTypeOptions :: MonadReader (TypeContext s) m => TypeKind -> Text -> m (Maybe (TypeKind, Text)) +defineTypeOptions kind tName = do + namespaces <- asks hasNamespace + pure $ if namespaces then Just (kind, tName) else Nothing + +inType :: MonadReader (TypeContext s) m => Maybe TypeName -> m a -> m a +inType name = local (\x -> x {currentTypeName = name, currentKind = Nothing}) + +mkInterfaceName :: TypeName -> TypeName +mkInterfaceName = ("Interface" <>) + +mkPossibleTypesName :: TypeName -> TypeName +mkPossibleTypesName = ("PossibleTypes" <>) + +genTypeDefinition :: + CodeGenMonad m => + TypeDefinition ANY CONST -> + ServerQ m [ServerDeclaration] +genTypeDefinition + typeDef@TypeDefinition {typeName = originalTypeName, typeContent} = + case tKind of + KindScalar -> do + scalarGQLType <- deriveGQL + pure + [ ScalarType (toHaskellTypeName typeName), + scalarGQLType + ] + _ -> genTypeContent originalTypeName typeContent >>= withType + where + typeName = case typeContent of + DataInterface {} -> mkInterfaceName originalTypeName + _ -> originalTypeName + tKind = kindOf typeDef + cgTypeName = CodeGenTypeName [] ["m" | isResolverType tKind] (packName $ toHaskellTypeName typeName) + deriveGQL = do + gqlTypeDirectiveUses <- getDirs typeDef + dropNamespace <- defineTypeOptions tKind (unpackName typeName) + pure $ + GQLTypeInstance $ + GQLTypeDefinition + { gqlTarget = cgTypeName, + gqlTypeDirectiveUses, + gqlKind = derivingKind tKind, + gqlTypeDefaultValues = + fromList $ + mapMaybe getDefaultValue $ + getInputFields typeDef, + dropNamespace + } + cgDerivations = derivesClasses (isResolverType tKind) + ------------------------- + withType (ConsIN cgConstructors) = do + gqlType <- deriveGQL + pure [DataType CodeGenType {..}, gqlType] + withType (ConsOUT others cgConstructors) = do + gqlType <- deriveGQL + pure (DataType CodeGenType {..} : gqlType : others) + +derivingKind :: TypeKind -> Kind +derivingKind KindScalar = Scalar +derivingKind _ = Type + +derivesClasses :: Bool -> [DerivingClass] +derivesClasses isResolver = GENERIC : [SHOW | not isResolver] + +mkObjectCons :: TypeName -> [CodeGenField] -> [CodeGenConstructor] +mkObjectCons name = pure . CodeGenConstructor (fromTypeName name) + +mkArgsTypeName :: Bool -> TypeName -> FieldName -> TypeName +mkArgsTypeName namespace typeName fieldName + | namespace = typeName <> argTName + | otherwise = argTName + where + argTName = camelCaseTypeName [fieldName] "Args" + +isParametrizedResolverType :: CodeGenMonad m => TypeName -> [TypeDefinition ANY s] -> m Bool +isParametrizedResolverType "__TypeKind" _ = pure False +isParametrizedResolverType "Boolean" _ = pure False +isParametrizedResolverType "String" _ = pure False +isParametrizedResolverType "Int" _ = pure False +isParametrizedResolverType "Float" _ = pure False +isParametrizedResolverType name lib = case lookupWith typeName name lib of + Just x -> pure (isResolverType x) + Nothing -> isParametrizedType name + +isSubscription :: TypeKind -> Bool +isSubscription (KindObject (Just Subscription)) = True +isSubscription _ = False + +mkObjectField :: + CodeGenMonad m => + FieldDefinition OUT CONST -> + ServerQ m CodeGenField +mkObjectField + FieldDefinition + { fieldName = fName, + fieldContent, + fieldType = TypeRef {typeConName, typeWrappers} + } = do + isParametrized <- lift . isParametrizedResolverType typeConName =<< asks typeDefinitions + genName <- asks toArgsTypeName + kind <- asks currentKind + fieldName <- renderFieldName fName + pure + CodeGenField + { fieldType = packName (toHaskellTypeName typeConName), + fieldIsNullable = isNullable typeWrappers, + wrappers = + mkFieldArguments fName genName (toArgList fieldContent) + <> [SUBSCRIPTION ''SubscriptionField | fmap isSubscription kind == Just True] + <> [MONAD] + <> [GQL_WRAPPER typeWrappers] + <> [PARAMETRIZED | isParametrized], + .. + } + +mkFieldArguments :: FieldName -> (FieldName -> TypeName) -> [ArgumentDefinition s] -> [FIELD_TYPE_WRAPPER] +mkFieldArguments _ _ [] = [] +mkFieldArguments + _ + _ + [ ArgumentDefinition FieldDefinition {fieldName, fieldType} + ] = [TAGGED_ARG ''Arg fieldName fieldType] +mkFieldArguments fName genName _ = [ARG (genName fName)] + +toArgList :: Maybe (FieldContent bool cat s) -> [ArgumentDefinition s] +toArgList (Just (FieldArgs args)) = toList args +toArgList _ = [] + +data BuildPlan + = ConsIN [CodeGenConstructor] + | ConsOUT [ServerDeclaration] [CodeGenConstructor] + +genInterfaceUnion :: Monad m => TypeName -> ServerQ m [ServerDeclaration] +genInterfaceUnion interfaceName = + mkInterface . map typeName . mapMaybe (isPossibleInterfaceType interfaceName) + <$> asks typeDefinitions + where + mkInterface [] = [] + mkInterface [possibleTypeName] = [mkGuardWithPossibleType possibleTypeName] + mkInterface members = + [ mkGuardWithPossibleType tName, + DataType + CodeGenType + { cgTypeName = possTypeName, + cgConstructors = map (mkUnionFieldDefinition tName) members, + cgDerivations = derivesClasses True + }, + GQLTypeInstance + GQLTypeDefinition + { gqlTarget = possTypeName, + gqlKind = Type, + gqlTypeDirectiveUses = empty, + gqlTypeDefaultValues = mempty, + dropNamespace = Nothing + } + ] + where + possTypeName = CodeGenTypeName [] ["m"] (packName $ toHaskellTypeName tName) + mkGuardWithPossibleType = InterfaceType . InterfaceDefinition interfaceName (mkInterfaceName interfaceName) + tName = mkPossibleTypesName interfaceName + +renderFieldName :: Monad m => FieldName -> ServerQ m FieldName +renderFieldName fieldName = do + TypeContext {hasNamespace, currentTypeName} <- ask + pure $ + if hasNamespace + then maybe fieldName (`camelCaseFieldName` fieldName) currentTypeName + else fieldName + +mkConsEnum :: Monad m => TypeName -> DataEnumValue CONST -> ServerQ m CodeGenConstructor +mkConsEnum name DataEnumValue {enumName} = do + namespace <- asks hasNamespace + pure + CodeGenConstructor + { constructorName = + if namespace + then CodeGenTypeName [coerce name] [] enumName + else fromTypeName enumName, + constructorFields = [] + } + +renderDataField :: Monad m => FieldDefinition c CONST -> ServerQ m CodeGenField +renderDataField FieldDefinition {fieldType = TypeRef {typeConName, typeWrappers}, fieldName = fName} = do + fieldName <- renderFieldName fName + let wrappers = [GQL_WRAPPER typeWrappers] + let fieldType = packName (toHaskellTypeName typeConName) + let fieldIsNullable = isNullable typeWrappers + pure CodeGenField {..} + +genTypeContent :: + CodeGenMonad m => + TypeName -> + TypeContent TRUE ANY CONST -> + ServerQ m BuildPlan +genTypeContent _ DataScalar {} = pure (ConsIN []) +genTypeContent typeName (DataEnum tags) = ConsIN <$> traverse (mkConsEnum typeName) tags +genTypeContent typeName (DataInputObject fields) = + ConsIN . mkObjectCons typeName <$> traverse renderDataField (toList fields) +genTypeContent _ DataInputUnion {} = fail "Input Unions not Supported" +genTypeContent typeName DataInterface {interfaceFields} = + ConsOUT + <$> ((<>) <$> genArgumentTypes interfaceFields <*> genInterfaceUnion typeName) + <*> ( do + let interfaceName = mkInterfaceName typeName + inType + (Just interfaceName) + ( mkObjectCons interfaceName + <$> traverse mkObjectField (toList interfaceFields) + ) + ) +genTypeContent typeName DataObject {objectFields} = + ConsOUT + <$> genArgumentTypes objectFields + <*> ( mkObjectCons typeName + <$> traverse mkObjectField (toList objectFields) + ) +genTypeContent typeName (DataUnion members) = + pure $ ConsOUT [] (unionCon <$> toList members) + where + unionCon UnionMember {memberName} = mkUnionFieldDefinition typeName memberName + +mkUnionFieldDefinition :: TypeName -> TypeName -> CodeGenConstructor +mkUnionFieldDefinition typeName memberName = + CodeGenConstructor + { constructorName, + constructorFields = + [ CodeGenField + { fieldName = coerce ("un" <> getFullName constructorName), + fieldType = packName (toHaskellTypeName memberName), + wrappers = [PARAMETRIZED], + fieldIsNullable = False + } + ] + } + where + constructorName = CodeGenTypeName [coerce typeName] [] memberName + +genArgumentTypes :: MonadFail m => FieldsDefinition OUT CONST -> ServerQ m [ServerDeclaration] +genArgumentTypes = fmap concat . traverse genArgumentType . toList + +genArgumentType :: MonadFail m => FieldDefinition OUT CONST -> ServerQ m [ServerDeclaration] +genArgumentType + FieldDefinition + { fieldName, + fieldContent = Just (FieldArgs arguments) + } + | length arguments > 1 = do + tName <- (fieldName &) <$> asks toArgsTypeName + inType (Just tName) $ do + let argumentFields = argument <$> toList arguments + fields <- traverse renderDataField argumentFields + let typename = toHaskellTypeName tName + gqlTypeDirectiveUses <- concat <$> traverse getDirs argumentFields + dropNamespace <- defineTypeOptions KindInputObject typename + let cgTypeName = fromTypeName (packName typename) + pure + [ DataType + CodeGenType + { cgTypeName, + cgConstructors = mkObjectCons tName fields, + cgDerivations = derivesClasses False + }, + GQLTypeInstance + GQLTypeDefinition + { gqlTarget = cgTypeName, + gqlKind = Type, + gqlTypeDefaultValues = fromList (mapMaybe getDefaultValue argumentFields), + gqlTypeDirectiveUses, + dropNamespace + } + ] +genArgumentType _ = pure [] + +-- mkFieldDescription :: FieldDefinition cat s -> Maybe (Text, Description) +-- mkFieldDescription FieldDefinition {..} = (unpackName fieldName,) <$> fieldDescription + +--- + +class Meta a where + getDirs :: MonadFail m => a -> ServerQ m [ServerDirectiveUsage] + +instance (Meta a) => Meta (Maybe a) where + getDirs (Just x) = getDirs x + getDirs _ = pure [] + +descDirective :: Maybe Description -> [TypeValue] +descDirective desc = map describe (maybeToList desc) + where + describe x = TypeValueObject "Describe" [("text", TypeValueString x)] + +instance Meta (TypeDefinition c CONST) where + getDirs TypeDefinition {typeContent, typeDirectives, typeDescription} = do + contentD <- getDirs typeContent + typeD <- traverse transform (toList typeDirectives) + pure (contentD <> typeD <> map TypeDirectiveUsage (descDirective typeDescription)) + where + transform v = TypeDirectiveUsage <$> directiveTypeValue v + +instance Meta (TypeContent a c CONST) where + getDirs DataObject {objectFields} = getDirs objectFields + getDirs DataInputObject {inputObjectFields} = getDirs inputObjectFields + getDirs DataInterface {interfaceFields} = getDirs interfaceFields + getDirs DataEnum {enumMembers} = concat <$> traverse getDirs enumMembers + getDirs _ = pure [] + +instance Meta (DataEnumValue CONST) where + getDirs DataEnumValue {enumName, enumDirectives, enumDescription} = do + dirs <- traverse directiveTypeValue (toList enumDirectives) + pure $ map (EnumDirectiveUsage enumName) (dirs <> descDirective enumDescription) + +instance Meta (FieldsDefinition c CONST) where + getDirs = fmap concat . traverse getDirs . toList + +instance Meta (FieldDefinition c CONST) where + getDirs FieldDefinition {fieldName, fieldDirectives, fieldDescription} = do + dirs <- traverse directiveTypeValue (toList fieldDirectives) + pure $ map (FieldDirectiveUsage fieldName) (dirs <> descDirective fieldDescription) + +getInputFields :: TypeDefinition c s -> [FieldDefinition IN s] +getInputFields TypeDefinition {typeContent = DataInputObject {inputObjectFields}} = toList inputObjectFields +getInputFields _ = [] + +getDefaultValue :: FieldDefinition c s -> Maybe (Text, V.Value s) +getDefaultValue + FieldDefinition + { fieldName, + fieldContent = Just DefaultInputValue {defaultInputValue} + } = Just (unpackName fieldName, defaultInputValue) +getDefaultValue _ = Nothing + +nativeDirectives :: V.DirectivesDefinition CONST +nativeDirectives = AST.directiveDefinitions internalSchema + +getDirective :: (MonadReader (TypeContext CONST) m, MonadFail m) => FieldName -> m (DirectiveDefinition CONST) +getDirective directiveName = do + dirs <- asks directiveDefinitions + case find (\DirectiveDefinition {directiveDefinitionName} -> directiveDefinitionName == directiveName) dirs of + Just dir -> pure dir + _ -> selectOr (fail $ "unknown directive" <> show directiveName) pure directiveName nativeDirectives + +directiveTypeValue :: MonadFail m => Directive CONST -> ServerQ m TypeValue +directiveTypeValue Directive {..} = inType typeContext $ do + dirs <- getDirective directiveName + TypeValueObject typename <$> traverse (renderArgumentValue directiveArgs) (toList $ directiveDefinitionArgs dirs) + where + (typeContext, typename) = renderDirectiveTypeName directiveName + +renderDirectiveTypeName :: FieldName -> (Maybe TypeName, TypeName) +renderDirectiveTypeName "deprecated" = (Nothing, "Deprecated") +renderDirectiveTypeName name = (Just (coerce name), coerce name) + +renderArgumentValue :: + (IsMap FieldName c, MonadFail m) => + c (Argument CONST) -> + ArgumentDefinition s -> + ReaderT (TypeContext CONST) m (FieldName, TypeValue) +renderArgumentValue args ArgumentDefinition {..} = do + let dirName = AST.fieldName argument + gqlValue <- selectOr (pure AST.Null) (pure . argumentValue) dirName args + typeValue <- mapWrappedValue (AST.fieldType argument) gqlValue + fName <- renderFieldName dirName + pure (fName, typeValue) + +notFound :: MonadFail m => String -> String -> m a +notFound name at = fail $ "can't found " <> name <> "at " <> at <> "!" + +lookupType :: MonadFail m => TypeName -> ServerQ m (TypeDefinition ANY CONST) +lookupType name = do + types <- asks typeDefinitions + case find (\t -> typeName t == name) types of + Just x -> pure x + Nothing -> notFound (show name) "type definitions" + +lookupValueFieldType :: MonadFail m => TypeName -> FieldName -> ServerQ m TypeRef +lookupValueFieldType name fieldName = do + TypeDefinition {typeContent} <- lookupType name + case typeContent of + DataInputObject fields -> do + FieldDefinition {fieldType} <- selectOr (notFound (show fieldName) (show name)) pure fieldName fields + pure fieldType + _ -> notFound "input object" (show name) + +mapField :: MonadFail m => TypeName -> ObjectEntry CONST -> ServerQ m (FieldName, TypeValue) +mapField tName ObjectEntry {..} = do + t <- lookupValueFieldType tName entryName + value <- mapWrappedValue t entryValue + pure (entryName, value) + +expected :: MonadFail m => String -> V.Value CONST -> ServerQ m TypeValue +expected typ value = fail ("expected " <> typ <> ", found " <> show (render value) <> "!") + +mapWrappedValue :: MonadFail m => TypeRef -> V.Value CONST -> ServerQ m TypeValue +mapWrappedValue (TypeRef name (AST.BaseType isRequired)) value + | isRequired = mapValue name value + | value == V.Null = pure (TypedValueMaybe Nothing) + | otherwise = TypedValueMaybe . Just <$> mapValue name value +mapWrappedValue (TypeRef name (AST.TypeList elems isRequired)) d = case d of + V.Null | not isRequired -> pure (TypedValueMaybe Nothing) + (V.List xs) -> TypedValueMaybe . Just . TypeValueList <$> traverse (mapWrappedValue (TypeRef name elems)) xs + value -> expected "list" value + +mapValue :: MonadFail m => TypeName -> V.Value CONST -> ServerQ m TypeValue +mapValue name (V.List xs) = TypeValueList <$> traverse (mapValue name) xs +mapValue _ (V.Enum name) = pure $ TypeValueObject name [] +mapValue name (V.Object fields) = TypeValueObject name <$> traverse (mapField name) (toList fields) +mapValue _ (V.Scalar x) = mapScalarValue x +mapValue t v = expected (show t) v + +mapScalarValue :: MonadFail m => V.ScalarValue -> ServerQ m TypeValue +mapScalarValue (V.Int x) = pure $ TypeValueNumber (fromIntegral x) +mapScalarValue (V.Float x) = pure $ TypeValueNumber x +mapScalarValue (V.String x) = pure $ TypeValueString x +mapScalarValue (V.Boolean x) = pure $ TypeValueBool x +mapScalarValue (V.Value _) = fail "JSON objects are not supported!" diff --git a/src/Data/Morpheus/CodeGen/Server/Printing/Document.hs b/src/Data/Morpheus/CodeGen/Server/Printing/Document.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/CodeGen/Server/Printing/Document.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.CodeGen.Server.Printing.Document + ( renderDocument, + ) +where + +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Morpheus.CodeGen.Internal.AST (CodeGenTypeName (..)) +import Data.Morpheus.CodeGen.Printer + ( Printer (..), + ignore, + optional, + renderExtension, + renderImport, + unpack, + ) +import Data.Morpheus.CodeGen.Server.Internal.AST + ( GQLTypeDefinition (..), + Kind (..), + ModuleDefinition (..), + ServerDeclaration (..), + ServerDirectiveUsage (..), + TypeKind, + ) +import Data.Text + ( pack, + ) +import qualified Data.Text.Lazy as LT + ( fromStrict, + ) +import Data.Text.Lazy.Encoding (encodeUtf8) +import Prettyprinter + ( Doc, + align, + indent, + line, + pretty, + punctuate, + tupled, + vsep, + (<+>), + ) +import Relude hiding (ByteString, encodeUtf8, optional, print) + +renderDocument :: String -> [ServerDeclaration] -> ByteString +renderDocument moduleName types = + encodeUtf8 $ + LT.fromStrict $ + pack $ + show $ + renderModuleDefinition + ModuleDefinition + { moduleName = pack moduleName, + imports = + [ ("Data.Data", ["Typeable"]), + ("Data.Morpheus.Kind", ["TYPE"]), + ("Data.Morpheus.Types", ["*"]), + ("Data.Morpheus", []), + ("Data.Text", ["Text"]), + ("GHC.Generics", ["Generic"]) + ], + extensions = + [ "DeriveGeneric", + "TypeFamilies", + "OverloadedStrings", + "DataKinds", + "DuplicateRecordFields" + ], + types + } + +renderModuleDefinition :: ModuleDefinition -> Doc n +renderModuleDefinition + ModuleDefinition + { extensions, + moduleName, + imports, + types + } = + vsep (map renderExtension extensions) + <> line + <> line + <> "module" + <+> pretty moduleName + <+> "where" + <> line + <> line + <> vsep (map renderImport imports) + <> line + <> line + <> either (error . show) id (renderTypes types) + +type Result = Either Text + +renderTypes :: [ServerDeclaration] -> Either Text (Doc ann) +renderTypes = fmap vsep . traverse render + +class RenderType a where + render :: a -> Result (Doc ann) + +instance RenderType ServerDeclaration where + render InterfaceType {} = fail "not supported" + -- TODO: on scalar we should render user provided type + render ScalarType {scalarTypeName} = + pure $ "type" <+> ignore (print scalarTypeName) <+> "= Int" + render (DataType cgType) = pure (pretty cgType) + render (GQLTypeInstance gqlType) = pure $ renderGQLType gqlType + render (GQLDirectiveInstance _) = fail "not supported" + +renderTypeableConstraints :: [Text] -> Doc n +renderTypeableConstraints xs = tupled (map (("Typeable" <+>) . pretty) xs) <+> "=>" + +defineTypeOptions :: Maybe (TypeKind, Text) -> [Doc n] +defineTypeOptions (Just (kind, tName)) = ["typeOptions _ = dropNamespaceOptions" <+> "(" <> pretty (show kind :: String) <> ")" <+> pretty (show tName :: String)] +defineTypeOptions _ = [] + +renderGQLType :: GQLTypeDefinition -> Doc ann +renderGQLType gql@GQLTypeDefinition {..} + | gqlKind == Scalar = "" + | otherwise = + "instance" + <> optional renderTypeableConstraints (typeParameters gqlTarget) + <+> "GQLType" + <+> typeHead + <+> "where" + <> line + <> indent 2 (vsep (renderMethods typeHead gql <> defineTypeOptions dropNamespace)) + where + typeHead = unpack (print gqlTarget) + +renderMethods :: Doc n -> GQLTypeDefinition -> [Doc n] +renderMethods typeHead GQLTypeDefinition {..} = + ["type KIND" <+> typeHead <+> "=" <+> pretty gqlKind] + <> ["directives _=" <+> renderDirectiveUsages gqlTypeDirectiveUses | not (null gqlTypeDirectiveUses)] + +renderDirectiveUsages :: [ServerDirectiveUsage] -> Doc n +renderDirectiveUsages = align . vsep . punctuate " <>" . map pretty diff --git a/src/Data/Morpheus/CodeGen/Server/Printing/TH.hs b/src/Data/Morpheus/CodeGen/Server/Printing/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/CodeGen/Server/Printing/TH.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.CodeGen.Server.Printing.TH + ( compileDocument, + gqlDocument, + ) +where + +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Morpheus.CodeGen.Internal.AST (CodeGenTypeName (..)) +import Data.Morpheus.CodeGen.Server.Internal.AST + ( CodeGenConfig (..), + GQLDirectiveTypeClass (..), + GQLTypeDefinition (..), + InterfaceDefinition (..), + ServerDeclaration (..), + ServerDirectiveUsage, + TypeKind, + ) +import Data.Morpheus.CodeGen.Server.Interpreting.Transform + ( parseServerTypeDefinitions, + ) +import Data.Morpheus.CodeGen.TH + ( PrintExp (..), + PrintType (..), + ToName (..), + apply, + m', + m_, + printDec, + printTypeClass, + printTypeSynonym, + toCon, + _', + ) +import Data.Morpheus.Server.Types + ( GQLDirective (..), + GQLType (..), + TypeGuard (..), + dropNamespaceOptions, + ) +import Data.Morpheus.Types.Internal.AST (DirectiveLocation) +import Language.Haskell.TH +import Language.Haskell.TH.Quote (QuasiQuoter (..)) +import Relude hiding (ByteString, Type) + +gqlDocument :: QuasiQuoter +gqlDocument = mkQuasiQuoter CodeGenConfig {namespace = False} + +mkQuasiQuoter :: CodeGenConfig -> QuasiQuoter +mkQuasiQuoter ctx = + QuasiQuoter + { quoteExp = notHandled "Expressions", + quotePat = notHandled "Patterns", + quoteType = notHandled "Types", + quoteDec = compileDocument ctx . LB.pack + } + where + notHandled things = + error $ things <> " are not supported by the GraphQL QuasiQuoter" + +compileDocument :: CodeGenConfig -> LB.ByteString -> Q [Dec] +compileDocument ctx = parseServerTypeDefinitions ctx >=> printDecQ + +class PrintDecQ a where + printDecQ :: a -> Q [Dec] + +instance PrintDecQ a => PrintDecQ [a] where + printDecQ = fmap concat . traverse printDecQ + +instance PrintDecQ InterfaceDefinition where + printDecQ InterfaceDefinition {..} = + pure [printTypeSynonym aliasName [m_] (apply ''TypeGuard [apply interfaceName [m'], apply unionName [m']])] + +instance PrintDecQ GQLTypeDefinition where + printDecQ GQLTypeDefinition {..} = do + let params = map toName (typeParameters gqlTarget) + associatedTypes <- fmap (pure . (''KIND,)) (printType gqlKind) + pure <$> printTypeClass (map (''Typeable,) params) ''GQLType (printType gqlTarget) associatedTypes methods + where + methods = + [ ('defaultValues, [_'], [|gqlTypeDefaultValues|]), + ('directives, [_'], printDirectiveUsages gqlTypeDirectiveUses) + ] + <> map printTypeOptions (maybeToList dropNamespace) + +instance PrintDecQ ServerDeclaration where + printDecQ (InterfaceType interface) = printDecQ interface + printDecQ ScalarType {} = pure [] + printDecQ (DataType dataType) = pure [printDec dataType] + printDecQ (GQLTypeInstance gql) = printDecQ gql + printDecQ (GQLDirectiveInstance dir) = printDecQ dir + +instance PrintDecQ GQLDirectiveTypeClass where + printDecQ GQLDirectiveTypeClass {..} = + pure + <$> printTypeClass + [] + ''GQLDirective + (toCon directiveTypeName) + [(''DIRECTIVE_LOCATIONS, promotedList directiveLocations)] + [] + +promotedList :: [DirectiveLocation] -> Type +promotedList = foldr (AppT . AppT PromotedConsT . PromotedT . toName) PromotedNilT + +printTypeOptions :: (TypeKind, Text) -> (Name, [PatQ], ExpQ) +printTypeOptions (kind, tName) = ('typeOptions, [_'], [|dropNamespaceOptions kind tName|]) + +printDirectiveUsages :: [ServerDirectiveUsage] -> ExpQ +printDirectiveUsages = foldr (appE . appE [|(<>)|] . printExp) [|mempty|]