diff --git a/app/CLI/Generator.hs b/app/CLI/Generator.hs --- a/app/CLI/Generator.hs +++ b/app/CLI/Generator.hs @@ -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 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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) diff --git a/morpheus-graphql-code-gen.cabal b/morpheus-graphql-code-gen.cabal --- a/morpheus-graphql-code-gen.cabal +++ b/morpheus-graphql-code-gen.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.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 diff --git a/src/Data/Morpheus/CodeGen/Server/Internal/AST.hs b/src/Data/Morpheus/CodeGen/Server/Internal/AST.hs --- a/src/Data/Morpheus/CodeGen/Server/Internal/AST.hs +++ b/src/Data/Morpheus/CodeGen/Server/Internal/AST.hs @@ -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) 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 @@ -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 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 @@ -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 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 @@ -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 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,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