morpheus-graphql-code-gen 0.26.0 → 0.27.0
raw patch · 9 files changed
+338/−198 lines, 9 filesdep ~morpheus-graphql-code-gen-utilsdep ~morpheus-graphql-coredep ~morpheus-graphql-serverPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: morpheus-graphql-code-gen-utils, morpheus-graphql-core, morpheus-graphql-server
API changes (from Hackage documentation)
- Data.Morpheus.CodeGen: parseServerTypeDefinitions :: CodeGenMonad m => CodeGenConfig -> ByteString -> m [ServerDeclaration]
+ Data.Morpheus.CodeGen: parseServerTypeDefinitions :: CodeGenMonad m => CodeGenConfig -> ByteString -> m ([ServerDeclaration], Flags)
Files
- app/CLI/Config.hs +46/−10
- app/CLI/File.hs +7/−4
- app/CLI/Generator.hs +56/−29
- app/Main.hs +50/−40
- morpheus-graphql-code-gen.cabal +6/−6
- src/Data/Morpheus/CodeGen/Server/Interpreting/Directive.hs +29/−17
- src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs +102/−72
- src/Data/Morpheus/CodeGen/Server/Interpreting/Utils.hs +41/−19
- src/Data/Morpheus/CodeGen/Server/Printing/TH.hs +1/−1
app/CLI/Config.hs view
@@ -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,
app/CLI/File.hs view
@@ -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
app/CLI/Generator.hs view
@@ -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
app/Main.hs view
@@ -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
morpheus-graphql-code-gen.cabal view
@@ -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
src/Data/Morpheus/CodeGen/Server/Interpreting/Directive.hs view
@@ -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
src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs view
@@ -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
src/Data/Morpheus/CodeGen/Server/Interpreting/Utils.hs view
@@ -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})
src/Data/Morpheus/CodeGen/Server/Printing/TH.hs view
@@ -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