diff --git a/app/CLI/Config.hs b/app/CLI/Config.hs --- a/app/CLI/Config.hs +++ b/app/CLI/Config.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} module CLI.Config @@ -7,34 +9,68 @@ Config (..), readConfig, ServiceOptions (..), + Source (..), ) where import qualified Data.ByteString as L ( readFile, ) -import Data.Yaml (FromJSON, decodeThrow) +import Data.Yaml + ( FromJSON (..), + Value (..), + decodeThrow, + withObject, + (.:), + (.:?), + ) import Relude import System.FilePath.Posix ( (), ) data ServiceOptions = ServiceOptions - { namespace :: Maybe Bool, - globals :: Maybe [Text] + { optionNamespace :: Bool, + optionImports :: [Text], + optionExternals :: HashMap Text Text } - deriving - ( Generic, - FromJSON, - Show - ) + deriving (Show) +instance FromJSON ServiceOptions where + parseJSON = + withObject + "ServiceOptions" + ( \v -> do + optionNamespace <- fromMaybe False <$> v .:? "namespace" + optionExternals <- collection "externals" v + optionImports <- collection "globals" v + pure ServiceOptions {..} + ) + where + collection name v = fromMaybe mempty <$> (v .:? name) + +instance Semigroup ServiceOptions where + (ServiceOptions n1 g1 e1) <> (ServiceOptions n2 g2 e2) = ServiceOptions (n1 || n2) (g1 <> g2) (e1 <> e2) + +data Source = Source + { sourcePath :: FilePath, + sourceOptions :: Maybe ServiceOptions + } + deriving (Show) + +instance FromJSON Source where + parseJSON (Object o) = do + path <- o .: "path" + ops <- parseJSON (Object o) + pure (Source path ops) + parseJSON x = (`Source` Nothing) <$> parseJSON x + data Service = Service { name :: String, - includes :: [FilePath], + includes :: [Source], source :: FilePath, options :: Maybe ServiceOptions, - schema :: Maybe FilePath + schema :: Maybe Source } deriving ( Generic, diff --git a/app/CLI/File.hs b/app/CLI/File.hs --- a/app/CLI/File.hs +++ b/app/CLI/File.hs @@ -38,18 +38,21 @@ cliError :: GQLError -> IO () cliError = putStr . (" " <>) . printError "error" "\x1b[31m" -checkGenerated :: FilePath -> ByteString -> IO Bool +lookupFile :: FilePath -> IO (Maybe ByteString) +lookupFile x = fmap Just (readFile x) <|> pure Nothing + +checkGenerated :: FilePath -> Maybe ByteString -> IO Bool checkGenerated path result = do - file <- readFile path + file <- lookupFile path let isOutdated = file /= result traverse_ cliError ["outdated: " <> msg path | isOutdated] pure $ not isOutdated -processDocument :: Bool -> FilePath -> GQLResult ByteString -> IO Bool +processDocument :: Bool -> FilePath -> GQLResult (Maybe ByteString) -> IO Bool processDocument _ _ (Failure errors) = traverse_ cliError (toList errors) $> False processDocument check path Success {result, warnings} | check = printWarnings warnings >> checkGenerated path result - | otherwise = printWarnings warnings >> writeFile path result $> True + | otherwise = printWarnings warnings >> maybe (pure ()) (writeFile path) result $> True getModuleNameByPath :: FilePath -> FilePath -> Text getModuleNameByPath root path = pack . intercalate "." $ splitDirectories $ dropExtensions $ makeRelative root path diff --git a/app/CLI/Generator.hs b/app/CLI/Generator.hs --- a/app/CLI/Generator.hs +++ b/app/CLI/Generator.hs @@ -11,7 +11,9 @@ ) where +import CLI.Config (ServiceOptions (..)) import Data.ByteString.Lazy.Char8 (ByteString, pack) +import Data.HashMap.Lazy (lookup) import Data.Morpheus.Client ( SchemaSource, parseClientTypeDeclarations, @@ -22,20 +24,37 @@ parseServerTypeDefinitions, ) import Data.Morpheus.CodeGen.Internal.AST +import Data.Morpheus.CodeGen.Utils (Flag (..)) import Data.Morpheus.Internal.Ext (GQLResult) +import Data.Morpheus.Types.Internal.AST (unpackName) +import qualified Data.Set as S import Prettyprinter import Relude hiding (ByteString, print) data BuildConfig = BuildConfig { root :: String, - namespaces :: Bool, - globalImports :: [Text] + buildOptions :: ServiceOptions } deriving (Show) +getExtensions :: [Flag] -> [Text] +getExtensions xs = [x | FlagLanguageExtension x <- xs] + +resolveExternal :: ServiceOptions -> Text -> Maybe (Text, [Text]) +resolveExternal ServiceOptions {optionExternals} name = (,[name]) <$> name `lookup` optionExternals + +collectExternals :: ServiceOptions -> [Text] -> [(Text, [Text])] +collectExternals buildOptions exts = mapMaybe (resolveExternal buildOptions) (S.toList $ S.fromList exts) + +getImports :: ServiceOptions -> [Flag] -> [(Text, [Text])] +getImports buildOptions flags = collectExternals buildOptions [x | FlagExternal x <- flags] + +uniq :: Ord a => [a] -> [a] +uniq = S.toList . S.fromList + processServerDocument :: BuildConfig -> Text -> ByteString -> GQLResult ByteString processServerDocument BuildConfig {..} moduleName schema = do - types <- parseServerTypeDefinitions CodeGenConfig {namespace = namespaces} schema + (types, flags) <- second uniq <$> parseServerTypeDefinitions CodeGenConfig {namespace = optionNamespace buildOptions} schema pure $ print $ ModuleDefinition @@ -44,45 +63,53 @@ [ ("Data.Morpheus.Server.CodeGen.Internal", ["*"]), ("Data.Morpheus.Server.Types", ["*"]) ] - <> map (,["*"]) globalImports, + <> map (,["*"]) (optionImports buildOptions) + <> getImports buildOptions flags, extensions = - [ "DataKinds", - "DeriveGeneric", + [ "DeriveGeneric", "DuplicateRecordFields", - "OverloadedStrings", "TypeFamilies" - ], + ] + <> getExtensions flags, types } -notScalars :: ClientDeclaration -> Bool -notScalars (InstanceDeclaration SCALAR_MODE _) = False -notScalars _ = True +isScalars :: ClientDeclaration -> Bool +isScalars (InstanceDeclaration SCALAR_MODE _) = True +isScalars _ = False processClientDocument :: BuildConfig -> SchemaSource -> Maybe Text -> Text -> - GQLResult ByteString + GQLResult (Maybe ByteString) processClientDocument BuildConfig {..} schema query moduleName = do - types <- filter notScalars <$> parseClientTypeDeclarations schema query - let moduleDef = - ModuleDefinition - { moduleName, - imports = - [("Data.Morpheus.Client.CodeGen.Internal", ["*"])] - <> map (,["*"]) globalImports, - extensions = - [ "DeriveGeneric", - "DuplicateRecordFields", - "LambdaCase", - "OverloadedStrings", - "TypeFamilies" - ], - types - } - pure $ print moduleDef + (allTypes, flags) <- second uniq <$> parseClientTypeDeclarations schema query + let externalImports = collectExternals buildOptions [unpackName $ getFullName (typeClassTarget x) | InstanceDeclaration SCALAR_MODE x <- allTypes] + let types = filter (not . isScalars) allTypes + if null types + then pure Nothing + else + pure $ + Just $ + print + ModuleDefinition + { moduleName, + imports = + [("Data.Morpheus.Client.CodeGen.Internal", ["*"])] + <> map (,["*"]) (optionImports buildOptions) + <> externalImports + <> getImports buildOptions flags, + extensions = + [ "DeriveGeneric", + "DuplicateRecordFields", + "OverloadedStrings", + "TypeFamilies" + ] + <> getExtensions flags, + types + } print :: Pretty a => a -> ByteString print = pack . show . pretty diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -18,6 +18,7 @@ ( Config (..), Service (..), ServiceOptions (..), + Source (..), readConfig, ) import CLI.File (getModuleNameByPath, processDocument, processFileName) @@ -30,6 +31,7 @@ ( readFile, ) import Data.Morpheus.Client (readSchemaSource) +import Data.Morpheus.Internal.Ext (resultOr) import qualified Data.Text.IO as TIO import Data.Version (showVersion) import qualified Paths_morpheus_graphql_code_gen as CLI @@ -75,70 +77,78 @@ pure $ and (servers <> clients) getImports :: Maybe ServiceOptions -> [Text] -getImports = concat . maybeToList . (>>= globals) +getImports = concatMap optionImports . maybeToList -parseServiceData :: Context -> Service -> IO (FilePath, Bool, [FilePath], [Text]) +expandSource :: FilePath -> Source -> IO [Source] +expandSource root (Source p o) = do + files <- glob $ normalise (root p) + pure $ map (`Source` o) files + +parseServiceData :: Context -> Service -> IO (FilePath, [Source], ServiceOptions) parseServiceData ctx Service {source, includes, options} = do let root = normalise (configDir ctx source) - let namespaces = fromMaybe False (options >>= namespace) - let patterns = map (normalise . (root )) includes - files <- concat <$> traverse glob patterns + let namespaces = maybe False optionNamespace options + let externals = maybe mempty optionExternals options + files <- concat <$> traverse (expandSource root) includes pure ( root, - namespaces, files, - getImports options + ServiceOptions namespaces (getImports options) externals ) -getSchemaPath :: MonadFail m => FilePath -> String -> Maybe FilePath -> m FilePath -getSchemaPath root name schema = do - schemaPath <- maybe (fail $ "client service " <> name <> " should provide schema!") pure schema - pure $ normalise $ root schemaPath +getSchemaPath :: FilePath -> String -> Maybe Source -> IO Source +getSchemaPath root _ (Just Source {..}) = do + pure Source {sourcePath = normalise $ root sourcePath, ..} +getSchemaPath _ name _ = fail $ "client service " <> name <> " should provide schema!" handleClientService :: Context -> Service -> IO CommandResult handleClientService ctx s@Service {name, schema} = do - (root, namespaces, files, globalImports) <- parseServiceData ctx s + (root, files, buildOptions) <- parseServiceData ctx s putStrLn ("\n build:" <> name) schemaPath <- getSchemaPath root name schema let config = BuildConfig {..} - globals <- buildClientGlobals ctx config schemaPath - and . (globals :) <$> traverse (buildClientQuery ctx config schemaPath) files - -buildClientGlobals :: Context -> BuildConfig -> FilePath -> IO CommandResult -buildClientGlobals ctx options schemaPath = do - putStr (" - " <> schemaPath <> "\n") - schemaDoc <- readSchemaSource schemaPath - let hsPath = processFileName schemaPath - let moduleName = getModuleNameByPath (root options) hsPath - let result = processClientDocument options schemaDoc Nothing moduleName - processDocument (isCheck ctx) hsPath result + (imports, globals) <- buildClientGlobals ctx config schemaPath + let newConfig = config {buildOptions = buildOptions {optionImports = imports <> optionImports buildOptions}} + and . (globals :) <$> traverse (buildClientQuery ctx newConfig schemaPath) files -getSchemaImports :: BuildConfig -> FilePath -> [Text] -getSchemaImports options schemaPath = [getModuleNameByPath (root options) (processFileName schemaPath)] +buildClientGlobals :: Context -> BuildConfig -> Source -> IO ([Text], CommandResult) +buildClientGlobals ctx config src@Source {sourcePath} = do + putStr (" - " <> sourcePath <> "\n") + schemaDoc <- readSchemaSource sourcePath + let hsPath = processFileName sourcePath + let moduleName = getModuleNameByPath (root config) hsPath + let result = processClientDocument (localConfig config src) schemaDoc Nothing moduleName + res <- processDocument (isCheck ctx) hsPath result + pure ([moduleName | resultOr (const False) isJust result], res) -buildClientQuery :: Context -> BuildConfig -> FilePath -> FilePath -> IO CommandResult -buildClientQuery ctx options schemaPath queryPath = do +buildClientQuery :: Context -> BuildConfig -> Source -> Source -> IO CommandResult +buildClientQuery ctx config schemaPath querySrc = do + let queryPath = sourcePath querySrc putStr (" - " <> queryPath <> "\n") file <- TIO.readFile queryPath - schemaDoc <- readSchemaSource schemaPath + schemaDoc <- readSchemaSource (sourcePath schemaPath) let hsPath = processFileName queryPath - let moduleName = getModuleNameByPath (root options) hsPath - let imports = getSchemaImports options schemaPath <> globalImports options - let result = processClientDocument (options {globalImports = imports}) schemaDoc (Just file) moduleName + let moduleName = getModuleNameByPath (root config) hsPath + let result = processClientDocument (localConfig config querySrc) schemaDoc (Just file) moduleName processDocument (isCheck ctx) hsPath result handleServerService :: Context -> Service -> IO CommandResult handleServerService ctx s@Service {name} = do - (root, namespaces, files, globalImports) <- parseServiceData ctx s + (root, files, buildOptions) <- parseServiceData ctx s putStrLn ("\n build:" <> name) - and <$> traverse (buildServer ctx (BuildConfig {..}) {root, namespaces}) files + and <$> traverse (buildServer ctx BuildConfig {..}) files -buildServer :: Context -> BuildConfig -> FilePath -> IO CommandResult -buildServer ctx options path = do +buildServer :: Context -> BuildConfig -> Source -> IO CommandResult +buildServer ctx config src = do + let path = sourcePath src + let hsPath = processFileName path putStr (" - " <> path <> "\n") file <- L.readFile path - let moduleName = getModuleNameByPath (root options) hsPath - let result = processServerDocument options moduleName file - processDocument (isCheck ctx) hsPath result - where - hsPath = processFileName path + let moduleName = getModuleNameByPath (root config) hsPath + let result = processServerDocument (localConfig config src) moduleName file + processDocument (isCheck ctx) hsPath (Just <$> result) + +localConfig :: BuildConfig -> Source -> BuildConfig +localConfig (BuildConfig root ops) src = + let options = sconcat (ops :| maybeToList (sourceOptions src)) + in BuildConfig root options 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.26.0 +version: 0.27.0 synopsis: Morpheus GraphQL CLI description: code generator for Morpheus GraphQL category: web, graphql, cli @@ -44,9 +44,9 @@ , bytestring >=0.10.4 && <0.12.0 , containers >=0.4.2.1 && <0.7.0 , file-embed >=0.0.10 && <1.0.0 - , morpheus-graphql-code-gen-utils >=0.26.0 && <0.27.0 - , morpheus-graphql-core >=0.26.0 && <0.27.0 - , morpheus-graphql-server >=0.26.0 && <0.27.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 , prettyprinter >=1.7.0 && <2.0.0 , relude >=0.3.0 && <2.0.0 , template-haskell >=2.0.0 && <3.0.0 @@ -75,8 +75,8 @@ , morpheus-graphql-client , morpheus-graphql-code-gen , morpheus-graphql-code-gen-utils - , morpheus-graphql-core >=0.26.0 && <0.27.0 - , morpheus-graphql-server >=0.26.0 && <0.27.0 + , 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 , prettyprinter >=1.7.0 && <2.0.0 , relude >=0.3.0 && <2.0.0 diff --git a/src/Data/Morpheus/CodeGen/Server/Interpreting/Directive.hs b/src/Data/Morpheus/CodeGen/Server/Interpreting/Directive.hs --- a/src/Data/Morpheus/CodeGen/Server/Interpreting/Directive.hs +++ b/src/Data/Morpheus/CodeGen/Server/Interpreting/Directive.hs @@ -7,10 +7,10 @@ {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.CodeGen.Server.Interpreting.Directive - ( getDirs, + ( getDirectives, getNamespaceDirs, - dirRename, getDefaultValueDir, + getRenameDir, ) where @@ -21,13 +21,14 @@ ) import Data.Morpheus.CodeGen.Server.Internal.AST (ServerDirectiveUsage (..), TypeValue (..), unpackName) import Data.Morpheus.CodeGen.Server.Interpreting.Utils - ( CodeGenT, + ( CodeGenM, ServerCodeGenContext (..), getEnumName, getFieldName, inType, lookupFieldType, ) +import Data.Morpheus.CodeGen.Utils (langExtension) import Data.Morpheus.Core (internalSchema, render) import Data.Morpheus.Internal.Utils (IsMap, selectOr) import Data.Morpheus.Types.Internal.AST @@ -54,23 +55,34 @@ import Data.Text (head) import Relude hiding (ByteString, get, head) -getDefaultValueDir :: (Monad m) => FieldDefinition c CONST -> CodeGenT m [ServerDirectiveUsage] +withDir :: CodeGenM m => [ServerDirectiveUsage] -> m [ServerDirectiveUsage] +withDir xs + | null xs = pure [] + | otherwise = langExtension "OverloadedStrings" >> pure xs + +getRenameDir :: CodeGenM m => Name t -> Name t -> m [ServerDirectiveUsage] +getRenameDir originalTypeName hsTypeName = withDir [TypeDirectiveUsage (dirRename originalTypeName) | originalTypeName /= hsTypeName] + +getDirectives :: (CodeGenM m, Meta a) => a -> m [ServerDirectiveUsage] +getDirectives = getDirs >=> withDir + +getDefaultValueDir :: (CodeGenM m) => FieldDefinition c CONST -> m [ServerDirectiveUsage] getDefaultValueDir FieldDefinition { fieldName, fieldContent = Just DefaultInputValue {defaultInputValue} } = do name <- getFieldName fieldName - pure [FieldDirectiveUsage name (defValDirective defaultInputValue)] + withDir [FieldDirectiveUsage name (defValDirective defaultInputValue)] getDefaultValueDir _ = pure [] defValDirective :: Value CONST -> TypeValue defValDirective desc = TypeValueObject "DefaultValue" [("defaultValue", PrintableTypeValue $ PrintableValue desc)] -getNamespaceDirs :: MonadReader (ServerCodeGenContext s) m => Text -> m [ServerDirectiveUsage] +getNamespaceDirs :: CodeGenM m => Text -> m [ServerDirectiveUsage] getNamespaceDirs genTypeName = do namespaces <- asks hasNamespace - pure [TypeDirectiveUsage (dirDropNamespace genTypeName) | namespaces] + withDir [TypeDirectiveUsage (dirDropNamespace genTypeName) | namespaces] descDirective :: Maybe Description -> [TypeValue] descDirective desc = map describe (maybeToList desc) @@ -84,7 +96,7 @@ dirRename name = TypeValueObject "Rename" [("newName", TypeValueString (unpackName name))] class Meta a where - getDirs :: MonadFail m => a -> CodeGenT m [ServerDirectiveUsage] + getDirs :: CodeGenM m => a -> m [ServerDirectiveUsage] instance (Meta a) => Meta (Maybe a) where getDirs (Just x) = getDirs x @@ -122,7 +134,7 @@ let renameField = [FieldDirectiveUsage name (dirRename fieldName) | isUpperCase fieldName] pure $ renameField <> map (FieldDirectiveUsage name) (dirs <> descDirective fieldDescription) -directiveTypeValue :: MonadFail m => Directive CONST -> CodeGenT m TypeValue +directiveTypeValue :: CodeGenM m => Directive CONST -> m TypeValue directiveTypeValue Directive {..} = inType typeContext $ do dirs <- getDirective directiveName TypeValueObject typename <$> traverse (renderArgumentValue directiveArgs) (toList $ directiveDefinitionArgs dirs) @@ -135,7 +147,7 @@ isUpperCase :: Name t -> Bool isUpperCase = isUpper . head . unpackName -getDirective :: (MonadReader (ServerCodeGenContext CONST) m, MonadFail m) => FieldName -> m (DirectiveDefinition CONST) +getDirective :: (CodeGenM m) => FieldName -> m (DirectiveDefinition CONST) getDirective directiveName = do dirs <- asks directiveDefinitions case find (\DirectiveDefinition {directiveDefinitionName} -> directiveDefinitionName == directiveName) dirs of @@ -147,10 +159,10 @@ renderDirectiveTypeName name = (Just (coerce name), coerce name) renderArgumentValue :: - (IsMap FieldName c, MonadFail m) => + (IsMap FieldName c, CodeGenM m) => c (Argument CONST) -> ArgumentDefinition s -> - ReaderT (ServerCodeGenContext CONST) m (FieldName, TypeValue) + m (FieldName, TypeValue) renderArgumentValue args ArgumentDefinition {..} = do let dirName = AST.fieldName argument gqlValue <- selectOr (pure AST.Null) (pure . argumentValue) dirName args @@ -158,7 +170,7 @@ fName <- getFieldName dirName pure (fName, typeValue) -mapWrappedValue :: MonadFail m => TypeRef -> AST.Value CONST -> CodeGenT m TypeValue +mapWrappedValue :: CodeGenM m => TypeRef -> AST.Value CONST -> m TypeValue mapWrappedValue (TypeRef name (AST.BaseType isRequired)) value | isRequired = mapValue name value | value == AST.Null = pure (TypedValueMaybe Nothing) @@ -168,24 +180,24 @@ (AST.List xs) -> TypedValueMaybe . Just . TypeValueList <$> traverse (mapWrappedValue (TypeRef name elems)) xs value -> expected "list" value -mapValue :: MonadFail m => TypeName -> AST.Value CONST -> CodeGenT m TypeValue +mapValue :: CodeGenM m => TypeName -> AST.Value CONST -> m TypeValue mapValue name (AST.List xs) = TypeValueList <$> traverse (mapValue name) xs mapValue _ (AST.Enum name) = pure $ TypeValueObject name [] mapValue name (AST.Object fields) = TypeValueObject name <$> traverse (mapField name) (toList fields) mapValue _ (AST.Scalar x) = mapScalarValue x mapValue t v = expected (show t) v -mapScalarValue :: MonadFail m => AST.ScalarValue -> CodeGenT m TypeValue +mapScalarValue :: CodeGenM m => AST.ScalarValue -> m TypeValue mapScalarValue (AST.Int x) = pure $ TypeValueNumber (fromIntegral x) mapScalarValue (AST.Float x) = pure $ TypeValueNumber x mapScalarValue (AST.String x) = pure $ TypeValueString x mapScalarValue (AST.Boolean x) = pure $ TypeValueBool x mapScalarValue (AST.Value _) = fail "JSON objects are not supported!" -expected :: MonadFail m => String -> AST.Value CONST -> CodeGenT m TypeValue +expected :: MonadFail m => String -> AST.Value CONST -> m TypeValue expected typ value = fail ("expected " <> typ <> ", found " <> show (render value) <> "!") -mapField :: MonadFail m => TypeName -> ObjectEntry CONST -> CodeGenT m (FieldName, TypeValue) +mapField :: CodeGenM m => TypeName -> ObjectEntry CONST -> m (FieldName, TypeValue) mapField tName ObjectEntry {..} = do t <- lookupFieldType tName entryName value <- mapWrappedValue t entryValue 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 @@ -24,6 +24,7 @@ MethodArgument (..), TypeClassInstance (..), fromTypeName, + getFullName, ) import Data.Morpheus.CodeGen.Server.Internal.AST ( CodeGenConfig (..), @@ -33,14 +34,33 @@ InterfaceDefinition (..), Kind (..), ServerDeclaration (..), - ServerDirectiveUsage (..), ServerMethod (..), ) -import Data.Morpheus.CodeGen.Server.Interpreting.Directive (dirRename, getDefaultValueDir, getDirs, getNamespaceDirs) -import Data.Morpheus.CodeGen.Server.Interpreting.Utils (CodeGenMonad (printWarnings), CodeGenT, ServerCodeGenContext (..), getEnumName, getFieldName, inType, isParamResolverType, isSubscription) +import Data.Morpheus.CodeGen.Server.Interpreting.Directive + ( getDefaultValueDir, + getDirectives, + getNamespaceDirs, + getRenameDir, + ) +import Data.Morpheus.CodeGen.Server.Interpreting.Utils + ( CodeGenM, + CodeGenMonad (printWarnings), + ServerCodeGenContext (..), + checkTypeExistence, + getEnumName, + getFieldName, + getFieldTypeName, + inType, + isParamResolverType, + isSubscription, + ) import Data.Morpheus.CodeGen.TH (ToName (..)) import Data.Morpheus.CodeGen.Utils - ( camelCaseTypeName, + ( Flag (..), + Flags, + camelCaseTypeName, + langExtension, + runCodeGenT, toHaskellTypeName, ) import Data.Morpheus.Core (parseDefinitions) @@ -76,24 +96,31 @@ ) import Relude hiding (ByteString, get) -parseServerTypeDefinitions :: CodeGenMonad m => CodeGenConfig -> ByteString -> m [ServerDeclaration] +parseServerTypeDefinitions :: CodeGenMonad m => CodeGenConfig -> ByteString -> m ([ServerDeclaration], Flags) parseServerTypeDefinitions ctx txt = case parseDefinitions txt of Failure errors -> fail (renderGQLErrors errors) Success {result, warnings} -> printWarnings warnings >> toTHDefinitions (namespace ctx) result +getExternals :: [ServerDeclaration] -> Flags +getExternals xs = + [FlagExternal scalarTypeName | ScalarType {scalarTypeName} <- xs] + <> [FlagExternal (unpackName $ getFullName $ typeClassTarget v) | GQLTypeInstance Scalar v <- xs] + toTHDefinitions :: CodeGenMonad m => Bool -> [RawTypeDefinition] -> - m [ServerDeclaration] -toTHDefinitions namespace defs = concat <$> traverse generateTypes defs + m ([ServerDeclaration], Flags) +toTHDefinitions namespace defs = do + (types, flags) <- bimap concat concat . unzip <$> traverse generateTypes defs + pure (types, flags <> getExternals types) where typeDefinitions = [td | RawTypeDefinition td <- defs] directiveDefinitions = [td | RawDirectiveDefinition td <- defs] - generateTypes :: CodeGenMonad m => RawTypeDefinition -> m [ServerDeclaration] + generateTypes :: CodeGenMonad m => RawTypeDefinition -> m ([ServerDeclaration], Flags) generateTypes (RawTypeDefinition typeDef) = - runReaderT + runCodeGenT (genTypeDefinition typeDef) ServerCodeGenContext { toArgsTypeName = mkArgsTypeName namespace (typeName typeDef), @@ -104,7 +131,7 @@ hasNamespace = namespace } generateTypes (RawDirectiveDefinition DirectiveDefinition {..}) = - runReaderT + runCodeGenT ( do fields <- traverse renderDataField (argument <$> toList directiveDefinitionArgs) let typename = coerce directiveDefinitionName @@ -141,7 +168,7 @@ currentKind = Nothing, hasNamespace = namespace } - generateTypes _ = pure [] + generateTypes _ = pure (mempty, mempty) mkInterfaceName :: TypeName -> TypeName mkInterfaceName = ("Interface" <>) @@ -150,28 +177,28 @@ mkPossibleTypesName = ("PossibleTypes" <>) genTypeDefinition :: - CodeGenMonad m => + CodeGenM m => TypeDefinition ANY CONST -> - CodeGenT m [ServerDeclaration] + m [ServerDeclaration] genTypeDefinition typeDef@TypeDefinition {typeName = originalTypeName, typeContent} = case tKind of - KindScalar -> do + KIND_SCALAR -> do scalarGQLType <- deriveGQL pure [ScalarType (toHaskellTypeName typeName), scalarGQLType] _ -> genTypeContent originalTypeName typeContent >>= withType where typeName - | tKind == KindInterface = mkInterfaceName originalTypeName + | tKind == KIND_INTERFACE = mkInterfaceName originalTypeName | otherwise = originalTypeName tKind = kindOf typeDef hsTypeName = packName $ toHaskellTypeName typeName cgTypeName = CodeGenTypeName [] ["m" | isResolverType tKind] hsTypeName - renameDir = [TypeDirectiveUsage (dirRename originalTypeName) | originalTypeName /= hsTypeName] deriveGQL = do defaultValueDirs <- concat <$> traverse getDefaultValueDir (getInputFields typeDef) namespaceDirs <- getNamespaceDirs (unpackName hsTypeName) - dirs <- getDirs typeDef + dirs <- getDirectives typeDef + renameDir <- getRenameDir originalTypeName hsTypeName pure $ gqlTypeToInstance GQLTypeDefinition @@ -189,7 +216,7 @@ pure (DataType CodeGenType {..} : gqlType : others) derivingKind :: TypeKind -> Kind -derivingKind KindScalar = Scalar +derivingKind KIND_SCALAR = Scalar derivingKind _ = Type derivesClasses :: Bool -> [DerivingClass] @@ -206,9 +233,9 @@ argTName = camelCaseTypeName [fieldName] "Args" mkObjectField :: - CodeGenMonad m => + CodeGenM m => FieldDefinition OUT CONST -> - CodeGenT m CodeGenField + m CodeGenField mkObjectField FieldDefinition { fieldName = fName, @@ -219,12 +246,14 @@ genName <- asks toArgsTypeName kind <- asks currentKind fieldName <- getFieldName fName + args <- mkFieldArguments fName genName (toArgList fieldContent) + fieldType <- getFieldTypeName typeConName pure CodeGenField - { fieldType = packName (toHaskellTypeName typeConName), + { fieldType, fieldIsNullable = isNullable typeWrappers, wrappers = - mkFieldArguments fName genName (toArgList fieldContent) + args <> [SUBSCRIPTION ''SubscriptionField | fmap isSubscription kind == Just True] <> [MONAD] <> [GQL_WRAPPER typeWrappers] @@ -232,14 +261,16 @@ .. } -mkFieldArguments :: FieldName -> (FieldName -> TypeName) -> [ArgumentDefinition s] -> [FIELD_TYPE_WRAPPER] -mkFieldArguments _ _ [] = [] +mkFieldArguments :: CodeGenM m => FieldName -> (FieldName -> TypeName) -> [ArgumentDefinition s] -> m [FIELD_TYPE_WRAPPER] +mkFieldArguments _ _ [] = pure [] mkFieldArguments _ _ [ ArgumentDefinition FieldDefinition {fieldName, fieldType} - ] = [TAGGED_ARG ''Arg fieldName fieldType] -mkFieldArguments fName genName _ = [ARG (genName fName)] + ] = + checkTypeExistence (typeConName fieldType) + >> langExtension "DataKinds" $> [TAGGED_ARG ''Arg fieldName fieldType] +mkFieldArguments fName genName _ = pure [ARG (genName fName)] toArgList :: Maybe (FieldContent bool cat s) -> [ArgumentDefinition s] toArgList (Just (FieldArgs args)) = toList args @@ -264,51 +295,48 @@ ] } -genInterfaceUnion :: Monad m => TypeName -> CodeGenT m [ServerDeclaration] +genInterfaceUnion :: CodeGenM m => TypeName -> m [ServerDeclaration] genInterfaceUnion interfaceName = - mkInterface . map typeName . mapMaybe (isPossibleInterfaceType interfaceName) - <$> asks typeDefinitions + asks typeDefinitions >>= mkInterface . map typeName . mapMaybe (isPossibleInterfaceType interfaceName) where - mkInterface [] = [] - mkInterface [possibleTypeName] = [mkGuardWithPossibleType possibleTypeName] - mkInterface members = - [ mkGuardWithPossibleType tName, - DataType - CodeGenType - { cgTypeName = possTypeName, - cgConstructors = map (mkUnionFieldDefinition tName) members, - cgDerivations = derivesClasses True - }, - gqlTypeToInstance - GQLTypeDefinition - { gqlTarget = possTypeName, - gqlKind = Type, - gqlTypeDirectiveUses = empty - } - ] + mkInterface [] = pure [] + mkInterface [possibleTypeName] = pure [mkGuardWithPossibleType possibleTypeName] + mkInterface members = do + cgConstructors <- traverse (mkUnionFieldDefinition tName) members + pure + [ mkGuardWithPossibleType tName, + DataType + CodeGenType + { cgTypeName = possTypeName, + cgConstructors, + cgDerivations = derivesClasses True + }, + gqlTypeToInstance + GQLTypeDefinition + { gqlTarget = possTypeName, + gqlKind = Type, + gqlTypeDirectiveUses = empty + } + ] where possTypeName = CodeGenTypeName [] ["m"] (packName $ toHaskellTypeName tName) mkGuardWithPossibleType = InterfaceType . InterfaceDefinition interfaceName (mkInterfaceName interfaceName) tName = mkPossibleTypesName interfaceName -mkConsEnum :: Monad m => DataEnumValue CONST -> CodeGenT m CodeGenConstructor +mkConsEnum :: CodeGenM m => DataEnumValue CONST -> m CodeGenConstructor mkConsEnum DataEnumValue {enumName} = do constructorName <- getEnumName enumName pure CodeGenConstructor {constructorName, constructorFields = []} -renderDataField :: Monad m => FieldDefinition c CONST -> CodeGenT 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] - let fieldType = packName (toHaskellTypeName typeConName) + fieldType <- getFieldTypeName typeConName let fieldIsNullable = isNullable typeWrappers pure CodeGenField {..} -genTypeContent :: - CodeGenMonad m => - TypeName -> - TypeContent TRUE ANY CONST -> - CodeGenT 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) = @@ -331,31 +359,33 @@ <*> ( mkObjectCons typeName <$> traverse mkObjectField (toList objectFields) ) -genTypeContent typeName (DataUnion members) = - pure $ ConsOUT [] (unionCon <$> toList members) +genTypeContent typeName (DataUnion members) = do + ConsOUT [] <$> traverse unionCon (toList members) where unionCon UnionMember {memberName} = mkUnionFieldDefinition typeName memberName -mkUnionFieldDefinition :: TypeName -> TypeName -> CodeGenConstructor -mkUnionFieldDefinition typeName memberName = - CodeGenConstructor - { constructorName, - constructorFields = - [ CodeGenField - { fieldName = "_", - fieldType = packName (toHaskellTypeName memberName), - wrappers = [PARAMETRIZED], - fieldIsNullable = False - } - ] - } +mkUnionFieldDefinition :: CodeGenM m => TypeName -> TypeName -> m CodeGenConstructor +mkUnionFieldDefinition typeName memberName = do + fieldType <- getFieldTypeName memberName + pure $ + CodeGenConstructor + { constructorName, + constructorFields = + [ CodeGenField + { fieldName = "_", + fieldType, + wrappers = [MONAD, PARAMETRIZED], + fieldIsNullable = False + } + ] + } where constructorName = CodeGenTypeName [coerce typeName] [] memberName -genArgumentTypes :: MonadFail m => FieldsDefinition OUT CONST -> CodeGenT m [ServerDeclaration] +genArgumentTypes :: CodeGenM m => FieldsDefinition OUT CONST -> m [ServerDeclaration] genArgumentTypes = fmap concat . traverse genArgumentType . toList -genArgumentType :: MonadFail m => FieldDefinition OUT CONST -> CodeGenT m [ServerDeclaration] +genArgumentType :: CodeGenM m => FieldDefinition OUT CONST -> m [ServerDeclaration] genArgumentType FieldDefinition { fieldName, @@ -368,7 +398,7 @@ fields <- traverse renderDataField argumentFields let typename = toHaskellTypeName tName namespaceDirs <- getNamespaceDirs typename - dirs <- concat <$> traverse getDirs argumentFields + dirs <- concat <$> traverse getDirectives argumentFields let cgTypeName = fromTypeName (packName typename) defaultValueDirs <- concat <$> traverse getDefaultValueDir argumentFields pure 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 @@ -8,14 +8,16 @@ module Data.Morpheus.CodeGen.Server.Interpreting.Utils ( CodeGenMonad (..), + CodeGenM, ServerCodeGenContext (..), - CodeGenT, getFieldName, getEnumName, isParamResolverType, lookupFieldType, isSubscription, inType, + getFieldTypeName, + checkTypeExistence, ) where @@ -27,7 +29,11 @@ ( ToName (toName), ) import Data.Morpheus.CodeGen.Utils - ( camelCaseFieldName, + ( CodeGenT, + Flags, + camelCaseFieldName, + requireExternal, + toHaskellTypeName, ) import Data.Morpheus.Error (gqlWarnings) import Data.Morpheus.Internal.Ext (GQLResult) @@ -47,6 +53,8 @@ TypeRef (..), isResolverType, lookupWith, + packName, + unpackName, ) import Language.Haskell.TH ( Dec (..), @@ -57,18 +65,30 @@ ) import Relude hiding (ByteString, get) -type CodeGenT m = ReaderT (ServerCodeGenContext CONST) m +class (MonadReader ServerCodeGenContext m, Monad m, MonadFail m, CodeGenMonad m, MonadState Flags m) => CodeGenM m -data ServerCodeGenContext s = ServerCodeGenContext +instance CodeGenMonad m => CodeGenM (CodeGenT ServerCodeGenContext m) + +data ServerCodeGenContext = ServerCodeGenContext { toArgsTypeName :: FieldName -> TypeName, - typeDefinitions :: [TypeDefinition ANY s], - directiveDefinitions :: [DirectiveDefinition s], + typeDefinitions :: [TypeDefinition ANY CONST], + directiveDefinitions :: [DirectiveDefinition CONST], currentTypeName :: Maybe TypeName, currentKind :: Maybe TypeKind, hasNamespace :: Bool } -getFieldName :: Monad m => FieldName -> CodeGenT m FieldName +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 name = checkTypeExistence name $> packName (toHaskellTypeName name) + +getFieldName :: CodeGenM m => FieldName -> m FieldName getFieldName fieldName = do ServerCodeGenContext {hasNamespace, currentTypeName} <- ask pure $ @@ -76,7 +96,7 @@ then maybe fieldName (`camelCaseFieldName` fieldName) currentTypeName else fieldName -getEnumName :: MonadReader (ServerCodeGenContext s) m => TypeName -> m CodeGenTypeName +getEnumName :: MonadReader ServerCodeGenContext m => TypeName -> m CodeGenTypeName getEnumName enumName = do ServerCodeGenContext {hasNamespace, currentTypeName} <- ask pure $ @@ -88,6 +108,10 @@ isParametrizedType :: TypeName -> m Bool printWarnings :: [GQLError] -> m () +instance CodeGenMonad m => CodeGenMonad (CodeGenT ctx m) where + isParametrizedType = lift . isParametrizedType + printWarnings = lift . printWarnings + instance CodeGenMonad Q where isParametrizedType name = isParametrizedHaskellType <$> reify (toName name) printWarnings = gqlWarnings @@ -112,7 +136,7 @@ isParametrizedHaskellType (TyConI x) = not $ null $ getTypeVariables x isParametrizedHaskellType _ = False -isParametrizedResolverType :: CodeGenMonad m => TypeName -> [TypeDefinition ANY s] -> CodeGenT m Bool +isParametrizedResolverType :: CodeGenM m => TypeName -> [TypeDefinition ANY s] -> m Bool isParametrizedResolverType "__TypeKind" _ = pure False isParametrizedResolverType "Boolean" _ = pure False isParametrizedResolverType "String" _ = pure False @@ -120,25 +144,23 @@ isParametrizedResolverType "Float" _ = pure False isParametrizedResolverType name lib = case lookupWith typeName name lib of Just x -> pure (isResolverType x) - Nothing -> lift (isParametrizedType name) + Nothing -> isParametrizedType name -isParamResolverType :: CodeGenMonad m => TypeName -> ReaderT (ServerCodeGenContext CONST) m Bool +isParamResolverType :: CodeGenM m => TypeName -> m Bool isParamResolverType typeConName = isParametrizedResolverType typeConName =<< asks typeDefinitions notFoundError :: MonadFail m => String -> String -> m a notFoundError name at = fail $ "can't found " <> name <> "at " <> at <> "!" -lookupType :: MonadFail m => TypeName -> CodeGenT m (TypeDefinition ANY CONST) +lookupType :: CodeGenM m => TypeName -> m (Maybe (TypeDefinition ANY CONST)) lookupType name = do types <- asks typeDefinitions - case find (\t -> typeName t == name) types of - Just x -> pure x - Nothing -> notFoundError (show name) "type definitions" + pure $ find (\t -> typeName t == name) types -lookupFieldType :: MonadFail m => TypeName -> FieldName -> CodeGenT m TypeRef +lookupFieldType :: CodeGenM m => TypeName -> FieldName -> m TypeRef lookupFieldType name fieldName = do - TypeDefinition {typeContent} <- lookupType name + TypeDefinition {typeContent} <- lookupType name >>= maybe (notFoundError (show name) "type definitions") pure case typeContent of DataInputObject fields -> do FieldDefinition {fieldType} <- selectOr (notFoundError (show fieldName) (show name)) pure fieldName fields @@ -146,8 +168,8 @@ _ -> notFoundError "input object" (show name) isSubscription :: TypeKind -> Bool -isSubscription (KindObject (Just Subscription)) = True +isSubscription (KIND_OBJECT (Just OPERATION_SUBSCRIPTION)) = True isSubscription _ = False -inType :: MonadReader (ServerCodeGenContext s) 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}) diff --git a/src/Data/Morpheus/CodeGen/Server/Printing/TH.hs b/src/Data/Morpheus/CodeGen/Server/Printing/TH.hs --- a/src/Data/Morpheus/CodeGen/Server/Printing/TH.hs +++ b/src/Data/Morpheus/CodeGen/Server/Printing/TH.hs @@ -42,7 +42,7 @@ compileDocument :: CodeGenConfig -> ByteString -> Q [Dec] compileDocument config = parseServerTypeDefinitions config - >=> fmap concat . traverse printServerDec + >=> fmap concat . traverse printServerDec . fst printServerDec :: ServerDeclaration -> Q [Dec] printServerDec (InterfaceType interface) = pure <$> printDec interface