morpheus-graphql-code-gen 0.28.1 → 0.28.2
raw patch · 8 files changed
+85/−78 lines, 8 filesdep ~bytestringdep ~containersdep ~filepath
Dependency ranges changed: bytestring, containers, filepath, optparse-applicative, unordered-containers
Files
- app/CLI/Generator.hs +39/−39
- app/Main.hs +10/−6
- morpheus-graphql-code-gen.cabal +10/−10
- src/Data/Morpheus/CodeGen/Server/Internal/AST.hs +3/−3
- src/Data/Morpheus/CodeGen/Server/Interpreting/Directive.hs +10/−10
- src/Data/Morpheus/CodeGen/Server/Interpreting/Transform.hs +6/−5
- src/Data/Morpheus/CodeGen/Server/Interpreting/Utils.hs +4/−4
- src/Data/Morpheus/CodeGen/Server/Printing/TH.hs +3/−1
app/CLI/Generator.hs view
@@ -49,30 +49,30 @@ getImports :: ServiceOptions -> [Flag] -> [(Text, [Text])] getImports buildOptions flags = collectExternals buildOptions [x | FlagExternal x <- flags] -uniq :: Ord a => [a] -> [a]+uniq :: (Ord a) => [a] -> [a] uniq = S.toList . S.fromList processServerDocument :: BuildConfig -> Text -> ByteString -> GQLResult ByteString processServerDocument BuildConfig {..} moduleName schema = do (types, flags) <- second uniq <$> parseServerTypeDefinitions CodeGenConfig {namespace = optionNamespace buildOptions} schema- pure $- print $- ModuleDefinition- { moduleName,- imports =- [ ("Data.Morpheus.Server.CodeGen.Internal", ["*"]),- ("Data.Morpheus.Server.Types", ["*"])- ]- <> map (,["*"]) (optionImports buildOptions)- <> getImports buildOptions flags,- extensions =- [ "DeriveGeneric",- "DuplicateRecordFields",- "TypeFamilies"- ]- <> getExtensions flags,- types- }+ pure+ $ print+ $ ModuleDefinition+ { moduleName,+ imports =+ [ ("Data.Morpheus.Server.CodeGen.Internal", ["*"]),+ ("Data.Morpheus.Server.Types", ["*"])+ ]+ <> map (,["*"]) (optionImports buildOptions)+ <> getImports buildOptions flags,+ extensions =+ [ "DeriveGeneric",+ "DuplicateRecordFields",+ "TypeFamilies"+ ]+ <> getExtensions flags,+ types+ } isScalars :: ClientDeclaration -> Bool isScalars (InstanceDeclaration SCALAR_MODE _) = True@@ -91,25 +91,25 @@ 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- }+ 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 :: (Pretty a) => a -> ByteString print = pack . show . pretty
app/Main.hs view
@@ -37,7 +37,7 @@ import qualified Paths_morpheus_graphql_code_gen as CLI import Relude hiding (ByteString) import System.Exit (ExitCode (..))-import System.FilePath (normalise, (</>))+import System.FilePath (dropFileName, normalise, (</>)) import System.FilePath.Glob (glob) currentVersion :: String@@ -46,14 +46,18 @@ main :: IO () main = parseCLI >>= runApp +sourcesWithFallback :: [FilePath] -> IO [FilePath]+sourcesWithFallback [] = fmap (map dropFileName) (glob "**/code-gen.yaml")+sourcesWithFallback xs = pure xs+ runApp :: App -> IO () runApp App {..} | version options = putStrLn currentVersion | otherwise = runOperation operations where runOperation About = putStrLn $ "Morpheus GraphQL CLI, version " <> currentVersion- runOperation (Build source) = processAll (scan . Context False) source- runOperation (Check source) = processAll (scan . Context True) source+ runOperation (Build source) = sourcesWithFallback source >>= processAll False+ runOperation (Check source) = sourcesWithFallback source >>= processAll True data Context = Context { isCheck :: Bool,@@ -62,9 +66,9 @@ type CommandResult = Bool -processAll :: (Traversable t, MonadIO m) => (a1 -> m Bool) -> t a1 -> m b-processAll f xs = do- res <- traverse f xs+processAll :: Bool -> [FilePath] -> IO b+processAll check xs = do+ res <- traverse (scan . Context check) xs if and res then putStr "\x1b[32mOK\x1b[0m\n" >> exitSuccess else exitWith (ExitFailure 1)
morpheus-graphql-code-gen.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0.+-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack name: morpheus-graphql-code-gen-version: 0.28.1+version: 0.28.2 synopsis: Morpheus GraphQL CLI description: code generator for Morpheus GraphQL category: web, graphql, cli@@ -41,8 +41,8 @@ ghc-options: -Wall build-depends: base >=4.7.0 && <5.0.0- , bytestring >=0.10.4 && <0.15.0- , containers >=0.4.2.1 && <=0.7+ , bytestring >=0.10.4 && <1.0.0+ , containers >=0.4.2.1 && <1.0.0 , file-embed >=0.0.10 && <1.0.0 , morpheus-graphql-code-gen-utils >=0.28.0 && <0.29.0 , morpheus-graphql-core >=0.28.0 && <0.29.0@@ -51,7 +51,7 @@ , relude >=0.3.0 && <2.0.0 , template-haskell >=2.0.0 && <3.0.0 , text >=1.2.3 && <3.0.0- , unordered-containers >=0.2.8 && <0.3.0+ , unordered-containers >=0.2.8 && <1.0.0 default-language: Haskell2010 executable morpheus@@ -68,20 +68,20 @@ build-depends: Glob >=0.7.0 && <1.0.0 , base >=4.7.0 && <5.0.0- , bytestring >=0.10.4 && <0.15.0- , containers >=0.4.2.1 && <=0.7+ , bytestring >=0.10.4 && <1.0.0+ , containers >=0.4.2.1 && <1.0.0 , file-embed >=0.0.10 && <1.0.0- , filepath >=1.1.0 && <=1.5.2.0+ , filepath >=1.1.0 && <2.0.0 , morpheus-graphql-client >=0.28.0 && <0.29.0 , morpheus-graphql-code-gen >=0.28.0 && <0.29.0 , morpheus-graphql-code-gen-utils >=0.28.0 && <0.29.0 , morpheus-graphql-core >=0.28.0 && <0.29.0 , morpheus-graphql-server >=0.28.0 && <0.29.0- , optparse-applicative >=0.12.0 && <0.20.0+ , optparse-applicative >=0.12.0 && <1.0.0 , prettyprinter >=1.7.0 && <2.0.0 , relude >=0.3.0 && <2.0.0 , template-haskell >=2.0.0 && <3.0.0 , text >=1.2.3 && <3.0.0- , unordered-containers >=0.2.8 && <0.3.0+ , unordered-containers >=0.2.8 && <1.0.0 , yaml >=0.8.32 && <1.0.0 default-language: Haskell2010
src/Data/Morpheus/CodeGen/Server/Internal/AST.hs view
@@ -112,8 +112,8 @@ instance PrintDec InterfaceDefinition where printDec InterfaceDefinition {..} =- pure $- printTypeSynonym+ pure+ $ printTypeSynonym aliasName [m_] ( apply@@ -144,7 +144,7 @@ <+> "TypeGuard" <+> unpack (print interfaceName .<> "m") <+> unpack (print unionName .<> "m")- <> line+ <> line pretty ScalarType {} = "" pretty (DataType cgType) = pretty cgType pretty (GQLTypeInstance kind gql)
src/Data/Morpheus/CodeGen/Server/Interpreting/Directive.hs view
@@ -55,12 +55,12 @@ import Data.Text (head) import Relude hiding (ByteString, get, head) -withDir :: CodeGenM m => [ServerDirectiveUsage] -> 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 :: (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]@@ -79,7 +79,7 @@ defValDirective :: Value CONST -> TypeValue defValDirective desc = TypeValueObject "DefaultValue" [("defaultValue", PrintableTypeValue $ PrintableValue desc)] -getNamespaceDirs :: CodeGenM m => Text -> m [ServerDirectiveUsage]+getNamespaceDirs :: (CodeGenM m) => Text -> m [ServerDirectiveUsage] getNamespaceDirs genTypeName = do namespaces <- asks hasNamespace withDir [TypeDirectiveUsage (dirDropNamespace genTypeName) | namespaces]@@ -96,7 +96,7 @@ dirRename name = TypeValueObject "Rename" [("newName", TypeValueString (unpackName name))] class Meta a where- getDirs :: CodeGenM m => a -> m [ServerDirectiveUsage]+ getDirs :: (CodeGenM m) => a -> m [ServerDirectiveUsage] instance (Meta a) => Meta (Maybe a) where getDirs (Just x) = getDirs x@@ -134,7 +134,7 @@ let renameField = [FieldDirectiveUsage name (dirRename fieldName) | isUpperCase fieldName] pure $ renameField <> map (FieldDirectiveUsage name) (dirs <> descDirective fieldDescription) -directiveTypeValue :: CodeGenM m => Directive CONST -> 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)@@ -170,7 +170,7 @@ fName <- getFieldName dirName pure (fName, typeValue) -mapWrappedValue :: CodeGenM m => TypeRef -> AST.Value CONST -> 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)@@ -180,24 +180,24 @@ (AST.List xs) -> TypedValueMaybe . Just . TypeValueList <$> traverse (mapWrappedValue (TypeRef name elems)) xs value -> expected "list" value -mapValue :: CodeGenM m => TypeName -> AST.Value CONST -> 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 :: CodeGenM m => AST.ScalarValue -> 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 -> m TypeValue+expected :: (MonadFail m) => String -> AST.Value CONST -> m TypeValue expected typ value = fail ("expected " <> typ <> ", found " <> show (render value) <> "!") -mapField :: CodeGenM m => TypeName -> ObjectEntry CONST -> 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
@@ -201,8 +201,8 @@ namespaceDirs <- getNamespaceDirs (unpackName hsTypeName) dirs <- getDirectives typeDef renameDir <- getRenameDir originalTypeName hsTypeName- pure $- gqlTypeToInstance+ pure+ $ gqlTypeToInstance GQLTypeDefinition { gqlTarget = cgTypeName, gqlTypeDirectiveUses = renameDir <> namespaceDirs <> dirs <> defaultValueDirs,@@ -271,7 +271,8 @@ [ ArgumentDefinition FieldDefinition {fieldName, fieldType} ] = checkTypeExistence (typeConName fieldType)- >> langExtension "DataKinds" $> [TAGGED_ARG ''Arg fieldName fieldType]+ >> langExtension "DataKinds"+ $> [TAGGED_ARG ''Arg fieldName fieldType] mkFieldArguments fName genName _ = pure [ARG (genName fName)] toArgList :: Maybe (FieldContent bool cat s) -> [ArgumentDefinition s]@@ -369,8 +370,8 @@ mkUnionFieldDefinition :: (CodeGenM m) => TypeName -> TypeName -> m CodeGenConstructor mkUnionFieldDefinition typeName memberName = do fieldType <- getFieldTypeName memberName- pure $- CodeGenConstructor+ pure+ $ CodeGenConstructor { constructorName, constructorFields = [ CodeGenField
src/Data/Morpheus/CodeGen/Server/Interpreting/Utils.hs view
@@ -91,16 +91,16 @@ getFieldName :: (CodeGenM m) => FieldName -> m FieldName getFieldName fieldName = do ServerCodeGenContext {hasNamespace, currentTypeName} <- ask- pure $- if hasNamespace+ pure+ $ if hasNamespace then maybe fieldName (`camelCaseFieldName` fieldName) currentTypeName else fieldName getEnumName :: (MonadReader ServerCodeGenContext m) => TypeName -> m CodeGenTypeName getEnumName enumName = do ServerCodeGenContext {hasNamespace, currentTypeName} <- ask- pure $- if hasNamespace+ pure+ $ if hasNamespace then CodeGenTypeName (map coerce $ maybeToList currentTypeName) [] enumName else fromTypeName enumName
src/Data/Morpheus/CodeGen/Server/Printing/TH.hs view
@@ -42,7 +42,9 @@ compileDocument :: CodeGenConfig -> ByteString -> Q [Dec] compileDocument config = parseServerTypeDefinitions config- >=> fmap concat . traverse printServerDec . fst+ >=> fmap concat+ . traverse printServerDec+ . fst printServerDec :: ServerDeclaration -> Q [Dec] printServerDec (InterfaceType interface) = pure <$> printDec interface