diff --git a/morpheus-graphql-client.cabal b/morpheus-graphql-client.cabal --- a/morpheus-graphql-client.cabal +++ b/morpheus-graphql-client.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: morpheus-graphql-client -version: 0.22.1 +version: 0.23.0 synopsis: Morpheus GraphQL Client description: Build GraphQL APIs with your favorite functional language! category: web, graphql, client @@ -55,28 +55,29 @@ library exposed-modules: Data.Morpheus.Client + Data.Morpheus.Client.CodeGen.Internal other-modules: - Data.Morpheus.Client.Declare + Data.Morpheus.Client.CodeGen.AST + Data.Morpheus.Client.CodeGen.Declare + Data.Morpheus.Client.CodeGen.Interpreting.Core + Data.Morpheus.Client.CodeGen.Interpreting.Global + Data.Morpheus.Client.CodeGen.Interpreting.Local + Data.Morpheus.Client.CodeGen.Interpreting.PreDeclarations + Data.Morpheus.Client.CodeGen.QuasiQuoter + Data.Morpheus.Client.CodeGen.TH + Data.Morpheus.Client.CodeGen.Utils Data.Morpheus.Client.Fetch Data.Morpheus.Client.Fetch.GQLClient Data.Morpheus.Client.Fetch.Http Data.Morpheus.Client.Fetch.RequestType Data.Morpheus.Client.Fetch.ResponseStream + Data.Morpheus.Client.Fetch.Types Data.Morpheus.Client.Fetch.WebSockets - Data.Morpheus.Client.Internal.TH - Data.Morpheus.Client.Internal.Types - Data.Morpheus.Client.Internal.Utils - Data.Morpheus.Client.Printing.TH - Data.Morpheus.Client.QuasiQuoter Data.Morpheus.Client.Schema.JSON.Parse Data.Morpheus.Client.Schema.JSON.TypeKind Data.Morpheus.Client.Schema.JSON.TypeRef Data.Morpheus.Client.Schema.JSON.Types Data.Morpheus.Client.Schema.Parse - Data.Morpheus.Client.Transform - Data.Morpheus.Client.Transform.Core - Data.Morpheus.Client.Transform.Global - Data.Morpheus.Client.Transform.Local Paths_morpheus_graphql_client hs-source-dirs: src @@ -89,9 +90,10 @@ , file-embed >=0.0.10 && <1.0.0 , modern-uri >=0.1.0.0 && <1.0.0 , morpheus-graphql-code-gen-utils - , morpheus-graphql-core >=0.22.0 && <0.23.0 + , morpheus-graphql-core >=0.23.0 && <0.24.0 , morpheus-graphql-subscriptions , mtl >=2.0.0 && <3.0.0 + , prettyprinter >=1.7.0 && <2.0.0 , relude >=0.3.0 && <2.0.0 , req >=3.0.0 && <4.0.0 , template-haskell >=2.0.0 && <3.0.0 @@ -130,9 +132,10 @@ , modern-uri >=0.1.0.0 && <1.0.0 , morpheus-graphql-client , morpheus-graphql-code-gen-utils - , morpheus-graphql-core >=0.22.0 && <0.23.0 + , morpheus-graphql-core >=0.23.0 && <0.24.0 , morpheus-graphql-subscriptions , mtl >=2.0.0 && <3.0.0 + , prettyprinter >=1.7.0 && <2.0.0 , relude >=0.3.0 && <2.0.0 , req >=3.0.0 && <4.0.0 , tasty >=0.1.0 && <1.5.0 diff --git a/src/Data/Morpheus/Client.hs b/src/Data/Morpheus/Client.hs --- a/src/Data/Morpheus/Client.hs +++ b/src/Data/Morpheus/Client.hs @@ -34,6 +34,9 @@ defineByIntrospection, defineByIntrospectionFile, defineByIntrospectionFile', + parseClientTypeDeclarations, + readSchemaSource, + SchemaSource, ) where @@ -41,15 +44,17 @@ import qualified Data.ByteString.Lazy as L ( readFile, ) -import Data.Morpheus.Client.Declare +import Data.Morpheus.Client.CodeGen.Declare ( clientTypeDeclarations, declareGlobalTypes, declareGlobalTypesByName, declareLocalTypes, declareLocalTypesInline, internalLegacyLocalDeclareTypes, + parseClientTypeDeclarations, raw, ) +import Data.Morpheus.Client.CodeGen.Utils (readSchemaSource) import Data.Morpheus.Client.Fetch ( Fetch (..), ) @@ -61,7 +66,7 @@ single, withHeaders, ) -import Data.Morpheus.Client.Internal.Types +import Data.Morpheus.Client.Fetch.Types ( ExecutableSource, FetchError (..), GQLClientResult, diff --git a/src/Data/Morpheus/Client/CodeGen/AST.hs b/src/Data/Morpheus/Client/CodeGen/AST.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/CodeGen/AST.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.CodeGen.AST + ( AesonField, + ClientDeclaration (..), + ClientMethod (..), + ClientPreDeclaration (..), + DERIVING_MODE (..), + MValue (..), + Printable (..), + RequestTypeDefinition (..), + UnionPat (..), + ClientTypeDefinition (..), + ) +where + +import Data.Foldable (foldr1) +import Data.Morpheus.Client.CodeGen.Internal + ( takeValueType, + withObject, + ) +import Data.Morpheus.CodeGen.Internal.AST + ( CodeGenConstructor (..), + CodeGenType, + CodeGenTypeName, + TypeClassInstance, + printTHName, + ) +import Data.Morpheus.CodeGen.TH + ( PrintExp (..), + ToName (toName), + toCon, + toString, + toVar, + v', + ) +import Data.Morpheus.Types.Internal.AST (FieldName, OperationType, TypeKind, TypeName, unpackName) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (Lift (..)) +import Prettyprinter + ( Doc, + Pretty (..), + indent, + line, + list, + tupled, + vsep, + (<+>), + ) +import Relude hiding (lift, show, toString) +import Prelude (show) + +data DERIVING_MODE = SCALAR_MODE | ENUM_MODE | TYPE_MODE + +data ClientDeclaration + = InstanceDeclaration (TypeClassInstance ClientMethod) + | ClientTypeDeclaration CodeGenType + +data ClientPreDeclaration + = ToJSONClass DERIVING_MODE CodeGenType + | FromJSONClass DERIVING_MODE CodeGenType + | RequestTypeClass RequestTypeDefinition + | ClientType CodeGenType + +data ClientTypeDefinition = ClientTypeDefinition + { clientTypeName :: CodeGenTypeName, + clientCons :: [CodeGenConstructor], + clientKind :: TypeKind + } + deriving (Show) + +data RequestTypeDefinition = RequestTypeDefinition + { requestName :: TypeName, + requestArgs :: TypeName, + requestType :: OperationType, + requestQuery :: String + } + deriving (Show) + +instance Pretty ClientDeclaration where + pretty (ClientTypeDeclaration def) = pretty def + pretty (InstanceDeclaration def) = pretty def + +data Printable where + Printable :: forall a. (Show a, Lift a) => a -> Printable + +instance Pretty Printable where + pretty (Printable x) = pretty (show x :: String) + +instance PrintExp Printable where + printExp (Printable x) = [|x|] + +data ClientMethod + = PrintableMethod Printable + | FunctionNameMethod Name + | MatchMethod ValueMatch + | ToJSONObjectMethod Name [(FieldName, Name, Name)] + | FromJSONObjectMethod TypeName [AesonField] + | FromJSONUnionMethod [([UnionPat], (Name, [AesonField]))] + +type AesonField = (Name, Name, FieldName) + +instance Pretty ClientMethod where + pretty (FunctionNameMethod x) = printTHName x + pretty (PrintableMethod x) = pretty x + pretty (MatchMethod x) = printMatchDoc x + pretty (ToJSONObjectMethod name fields) = printTHName name <+> indent 2 (line <+> list (map mkEntry fields)) + where + mkEntry (n, o, v) = prettyLit n <+> printTHName o <+> printTHName v + pretty (FromJSONObjectMethod name xs) = withBody $ printObjectDoc (toName name, xs) + where + withBody body = "withObject" <+> prettyLit name <+> "(\\v ->" <+> body <+> ")" + pretty (FromJSONUnionMethod xs) = "takeValueType" <+> tupled [matchDoc (map toMatch xs)] + where + toMatch (pat, expr) = (tuple $ map mapP pat, printObjectDoc expr) + mapP (UString v) = prettyLit v + mapP (UVar v) = pretty v + tuple ls = "(" <> foldr1 (\a b -> a <> "," <+> b) ls <> ")" + +instance PrintExp ClientMethod where + printExp (FunctionNameMethod v) = varE v + printExp (PrintableMethod v) = printExp v + printExp (MatchMethod p) = printMatchExp p + printExp (ToJSONObjectMethod name fields) = appE (varE name) (listE $ map mkEntry fields) + where + mkEntry (n, o, v) = uInfixE (toString n) (toVar o) (toVar v) + printExp (FromJSONObjectMethod name fields) = withBody $ printObjectExp (toName name, fields) + where + withBody body = appE (appE (toVar 'withObject) (toString name)) (lamE [v'] body) + printExp (FromJSONUnionMethod matches) = appE (toVar 'takeValueType) (matchExp $ map toMatch matches) + where + toMatch (pat, expr) = (tupP $ map mapP pat, printObjectExp expr) + -- + mapP (UString v) = toString v + mapP (UVar v) = toVar v + +printObjectExp :: (Name, [AesonField]) -> ExpQ +printObjectExp (con, fields) + | null fields = appE [|pure|] (toCon con) + | otherwise = uInfixE (toCon con) [|(<$>)|] $ foldr1 (\x -> uInfixE x [|(<*>)|]) (map printFieldExp fields) + +printObjectDoc :: (Name, [AesonField]) -> Doc n +printObjectDoc (name, fields) + | null fields = "pure" <+> printTHName name + | otherwise = printTHName name <+> "<$>" <+> foldr1 (\a b -> a <+> "<*>" <+> b) (map printFieldDoc fields) + +printFieldExp :: AesonField -> ExpQ +printFieldExp (v, o, str) = uInfixE (toVar v) (toVar o) (toString str) + +printFieldDoc :: AesonField -> Doc n +printFieldDoc (v, o, l) = printTHName v <+> printTHName o <+> prettyLit l + +prettyLit :: Show a => a -> Doc ann +prettyLit a = pretty (show a) + +prettyName :: TypeName -> Doc ann +prettyName a = pretty (unpackName a :: Text) + +data UnionPat + = UString TypeName + | UVar String + +data MValue + = MFrom TypeName TypeName + | MTo TypeName TypeName + | MFunction String Name + +type ValueMatch = [MValue] + +printMatchDoc :: ValueMatch -> Doc n +printMatchDoc = matchDoc . map buildMatch + where + buildMatch (MFrom a b) = (prettyLit a, "pure" <+> prettyName b) + buildMatch (MTo a b) = (prettyName a, prettyLit b) + buildMatch (MFunction v name) = (pretty v, printTHName name <+> pretty v) + +printMatchExp :: ValueMatch -> ExpQ +printMatchExp = matchExp . map buildMatch + where + buildMatch (MFrom a b) = (toString a, appE (toVar 'pure) (toCon b)) + buildMatch (MTo a b) = (toCon a, toString b) + buildMatch (MFunction v name) = (toVar v, appE (varE name) v') + +matchExp :: [(PatQ, ExpQ)] -> ExpQ +matchExp xs = lamCaseE (map buildMatch xs) + where + buildMatch (pat, fb) = match pat (normalB fb) [] + +matchDoc :: [(Doc n, Doc n)] -> Doc n +matchDoc = ("\\case " <>) . indent 4 . vsep . map buildMatch + where + buildMatch (pat, fb) = pat <+> "->" <+> fb diff --git a/src/Data/Morpheus/Client/CodeGen/Declare.hs b/src/Data/Morpheus/Client/CodeGen/Declare.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/CodeGen/Declare.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.CodeGen.Declare + ( declareGlobalTypes, + declareGlobalTypesByName, + declareLocalTypes, + declareLocalTypesInline, + internalLegacyLocalDeclareTypes, + clientTypeDeclarations, + raw, + parseClientTypeDeclarations, + ) +where + +import Data.Morpheus.Client.CodeGen.AST + ( ClientDeclaration (..), + ) +import Data.Morpheus.Client.CodeGen.Interpreting.Global + ( toGlobalDefinitions, + ) +import Data.Morpheus.Client.CodeGen.Interpreting.Local + ( toLocalDefinitions, + ) +import Data.Morpheus.Client.CodeGen.QuasiQuoter (raw) +import Data.Morpheus.Client.CodeGen.TH + ( declareIfNotDeclared, + deriveIfNotDefined, + ) +import Data.Morpheus.Client.CodeGen.Utils (getFile, getSource, handleResult) +import Data.Morpheus.Client.Fetch.Types + ( ExecutableSource, + SchemaSource, + ) +import Data.Morpheus.Client.Schema.Parse (parseSchema) +import Data.Morpheus.CodeGen.TH + ( PrintDec (printDec), + ) +import Data.Morpheus.Core (parseRequest) +import Data.Morpheus.Internal.Ext (GQLResult) +import Data.Morpheus.Types.IO (GQLRequest (..)) +import Data.Morpheus.Types.Internal.AST (TypeName) +import qualified Data.Set as S +import Language.Haskell.TH (Dec, Q, runIO) +import Relude + +printDeclarations :: [ClientDeclaration] -> Q [Dec] +printDeclarations clientType = concat <$> traverse typeDeclarations clientType + +typeDeclarations :: ClientDeclaration -> Q [Dec] +typeDeclarations (InstanceDeclaration dec) = deriveIfNotDefined printDec dec +typeDeclarations (ClientTypeDeclaration c) = declareIfNotDeclared printDec c + +internalLegacyLocalDeclareTypes :: IO SchemaSource -> ExecutableSource -> Q [Dec] +internalLegacyLocalDeclareTypes schemaSrc query = do + schemaText <- runIO schemaSrc + clientTypeDeclarations schemaText (Just query) + +globalTypeDeclarations :: SchemaSource -> (TypeName -> Bool) -> Q [Dec] +globalTypeDeclarations src f = handleResult (parseSchema src >>= toGlobalDefinitions f) printDeclarations + +parseClientTypeDeclarations :: SchemaSource -> Maybe Text -> GQLResult [ClientDeclaration] +parseClientTypeDeclarations schemaText (Just query) = do + schemaDoc <- parseSchema schemaText + executableDoc <- + parseRequest + GQLRequest + { query, + operationName = Nothing, + variables = Nothing + } + toLocalDefinitions (query, executableDoc) schemaDoc +parseClientTypeDeclarations src Nothing = parseSchema src >>= toGlobalDefinitions (const True) + +-- | declares global or local types, depending +-- on whether the second argument is specified or not +clientTypeDeclarations :: + SchemaSource -> + Maybe ExecutableSource -> + Q [Dec] +clientTypeDeclarations src x = handleResult (parseClientTypeDeclarations src x) printDeclarations + +{- ORMOLU_DISABLE -} +-- | declares input, enum and scalar types for specified schema +-- +-- Example where the schema is defined in SDL format +-- +-- @ +-- 'declareGlobalTypes' "schema.gql" +-- @ +-- +-- Example with schema as introspection in JSON format. +-- +-- @ +-- 'declareGlobalTypes' "schema.json" +-- @ +declareGlobalTypes :: + FilePath -- ^ the schema path relative to the project location, + -- both introspection (.json) and + -- schema definition (.gql, .graphql) are accepted. + -> Q [Dec] +declareGlobalTypes = flip declareClientTypes Nothing +{- ORMOLU_ENABLE -} + +-- | declares global types like 'declareGlobalTypes', +-- while enabling to select only the types that are needed. +declareGlobalTypesByName :: FilePath -> [TypeName] -> Q [Dec] +declareGlobalTypesByName path names = do + schema <- getSource path + globalTypeDeclarations schema (`S.member` S.fromList names) + +{- ORMOLU_DISABLE -} +-- | declares object, interface and union types for +-- specified schema and query. +-- +-- Example where the schema is defined in SDL format +-- +-- @ +-- 'declareLocalTypes' "schema.gql" "query.gql" +-- @ +-- +-- Example with schema as introspection in JSON format. +-- +-- @ +-- 'declareLocalTypes' "schema.json" "query.gql" +-- @ +declareLocalTypes :: + FilePath -- ^ the schema path relative to the project location. + -- both introspection (`.json`) and + -- schema definition (`.gql`, `.graphql`) are accepted. + -> FilePath -- ^ query path relative to the project location + -> Q [Dec] +declareLocalTypes schema query = declareClientTypes schema (Just query) +{- ORMOLU_ENABLE -} + +{- ORMOLU_DISABLE -} +-- | inline version of `declareLocalTypes`, however +-- instead of specifying the file path, you can simply +-- pass the query as text using QuasiQuoter `raw` +-- +-- @ +-- `declareLocalTypesInline` "schema.gql" +-- [`raw`| +-- query GetUsers { +-- users { +-- name +-- } +-- } +-- ] +-- @ +declareLocalTypesInline :: + FilePath -- ^ the schema path relative to the project location. + -- both introspection (`.json`) and + -- schema definition (`.gql`, `.graphql`) are accepted. + -> ExecutableSource -- ^ inline graphql query in Text format + -> Q [Dec] +declareLocalTypesInline schemaPath query = do + schema <- getSource schemaPath + clientTypeDeclarations schema (Just query) +{- ORMOLU_ENABLE -} + +declareClientTypes :: + FilePath -> + Maybe FilePath -> + Q [Dec] +declareClientTypes schemaPath queryPath = do + schema <- getSource schemaPath + query <- traverse getFile queryPath + clientTypeDeclarations schema query diff --git a/src/Data/Morpheus/Client/CodeGen/Internal.hs b/src/Data/Morpheus/Client/CodeGen/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/CodeGen/Internal.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.CodeGen.Internal + ( FromJSON (..), + ToJSON (..), + RequestType (..), + Generic, + OperationType (..), + scalarFromJSON, + scalarToJSON, + invalidConstructorError, + omitNulls, + (.=), + withObject, + (.:), + (.:?), + takeValueType, + ) +where + +import Data.Aeson (FromJSON (..), Object, ToJSON (..), object, withObject, (.:), (.:?), (.=)) +import Data.Aeson.Types (Pair, Parser, Value (..)) +import Data.Morpheus.Client.Fetch.RequestType + ( RequestType (..), + ) +import Data.Morpheus.Internal.Utils (IsMap (lookup)) +import Data.Morpheus.Types.GQLScalar (scalarFromJSON, scalarToJSON) +import Data.Morpheus.Types.Internal.AST (OperationType (..)) +import qualified Data.Text as T +import Relude + +invalidConstructorError :: (MonadFail m, Show a) => a -> m b +invalidConstructorError v = fail $ show v <> " is Not Valid Union Constructor" + +takeValueType :: ((String, Object) -> Parser a) -> Value -> Parser a +takeValueType f (Object hMap) = case lookup "__typename" hMap of + Nothing -> fail "key \"__typename\" not found on object" + Just (String x) -> f (T.unpack x, hMap) + Just val -> + fail $ "key \"__typename\" should be string but found: " <> show val +takeValueType _ _ = fail "expected Object" + +omitNulls :: [Pair] -> Value +omitNulls = object . filter notNull + where + notNull (_, Null) = False + notNull _ = True diff --git a/src/Data/Morpheus/Client/CodeGen/Interpreting/Core.hs b/src/Data/Morpheus/Client/CodeGen/Interpreting/Core.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/CodeGen/Interpreting/Core.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.CodeGen.Interpreting.Core + ( Converter (..), + compileError, + getType, + typeFrom, + deprecationWarning, + toCodeGenField, + toClientDeclarations, + ) +where + +import Control.Monad.Except (MonadError) +import Data.Morpheus.Client.CodeGen.AST + ( ClientPreDeclaration (..), + ClientTypeDefinition (..), + DERIVING_MODE (..), + ) +import Data.Morpheus.CodeGen.Internal.AST + ( CodeGenField (..), + CodeGenType (..), + DerivingClass (..), + FIELD_TYPE_WRAPPER (..), + ) +import Data.Morpheus.CodeGen.Utils (camelCaseTypeName) +import Data.Morpheus.Error + ( deprecatedField, + ) +import Data.Morpheus.Internal.Ext + ( GQLResult, + Result (..), + ) +import Data.Morpheus.Internal.Utils + ( selectBy, + ) +import Data.Morpheus.Types.Internal.AST + ( ANY, + Directives, + FieldDefinition (..), + FieldName, + GQLError, + RAW, + Ref (..), + Schema (..), + TypeContent (..), + TypeDefinition (..), + TypeKind (..), + TypeName, + TypeRef (..), + VALID, + VariableDefinitions, + internal, + isNullable, + isResolverType, + lookupDeprecated, + lookupDeprecatedReason, + msg, + typeDefinitions, + ) +import Relude + +type Env = (Schema VALID, VariableDefinitions RAW) + +newtype Converter a = Converter + { runConverter :: + ReaderT + Env + GQLResult + a + } + deriving + ( Functor, + Applicative, + Monad, + MonadReader Env, + MonadError GQLError + ) + +compileError :: GQLError -> GQLError +compileError x = internal $ "Unhandled Compile Time Error: \"" <> x <> "\" ;" + +getType :: TypeName -> Converter (TypeDefinition ANY VALID) +getType typename = + asks (typeDefinitions . fst) + >>= selectBy (compileError $ " can't find Type" <> msg typename) typename + +typeFrom :: [FieldName] -> TypeDefinition a VALID -> TypeName +typeFrom path TypeDefinition {typeName, typeContent} = __typeFrom typeContent + where + __typeFrom DataObject {} = camelCaseTypeName path typeName + __typeFrom DataInterface {} = camelCaseTypeName path typeName + __typeFrom DataUnion {} = camelCaseTypeName path typeName + __typeFrom _ = typeName + +deprecationWarning :: Directives VALID -> (FieldName, Ref FieldName) -> Converter () +deprecationWarning dirs (typename, ref) = case lookupDeprecated dirs of + Just deprecation -> Converter $ lift $ Success {result = (), warnings} + where + warnings = + [ deprecatedField + typename + ref + (lookupDeprecatedReason deprecation) + ] + Nothing -> pure () + +toCodeGenField :: FieldDefinition a b -> CodeGenField +toCodeGenField FieldDefinition {fieldType = field@TypeRef {..}, ..} = + CodeGenField + { fieldName, + fieldType = typeConName, + wrappers = [GQL_WRAPPER typeWrappers], + fieldIsNullable = isNullable field + } + +toClientDeclarations :: ClientTypeDefinition -> [ClientPreDeclaration] +toClientDeclarations def@ClientTypeDefinition {clientKind} + | KindScalar == clientKind = [FromJSONClass SCALAR_MODE cgType, ToJSONClass SCALAR_MODE cgType] + | KindEnum == clientKind = [ClientType cgType, FromJSONClass ENUM_MODE cgType, ToJSONClass ENUM_MODE cgType] + | isResolverType clientKind = [ClientType cgType, FromJSONClass TYPE_MODE cgType] + | otherwise = [ClientType cgType, ToJSONClass TYPE_MODE cgType] + where + cgType = printClientType def + +printClientType :: ClientTypeDefinition -> CodeGenType +printClientType ClientTypeDefinition {..} = + CodeGenType + { cgTypeName = clientTypeName, + cgConstructors = clientCons, + cgDerivations = [GENERIC, SHOW, CLASS_EQ] + } diff --git a/src/Data/Morpheus/Client/CodeGen/Interpreting/Global.hs b/src/Data/Morpheus/Client/CodeGen/Interpreting/Global.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/CodeGen/Interpreting/Global.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.CodeGen.Interpreting.Global + ( toGlobalDefinitions, + ) +where + +import Data.Morpheus.Client.CodeGen.AST + ( ClientDeclaration, + ClientTypeDefinition (..), + ) +import Data.Morpheus.Client.CodeGen.Interpreting.Core (toClientDeclarations, toCodeGenField) +import Data.Morpheus.Client.CodeGen.Interpreting.PreDeclarations + ( mapPreDeclarations, + ) +import Data.Morpheus.CodeGen.Internal.AST + ( CodeGenConstructor (..), + CodeGenTypeName (..), + fromTypeName, + ) +import Data.Morpheus.Internal.Ext (GQLResult) +import Data.Morpheus.Types.Internal.AST + ( ANY, + DataEnumValue (DataEnumValue, enumName), + Schema (Schema, types), + TRUE, + TypeContent (..), + TypeDefinition (..), + TypeKind (..), + TypeName, + VALID, + isNotSystemTypeName, + isResolverType, + ) +import Relude hiding (empty) + +toGlobalDefinitions :: (TypeName -> Bool) -> Schema VALID -> GQLResult [ClientDeclaration] +toGlobalDefinitions f Schema {types} = + traverse mapPreDeclarations $ + concatMap toClientDeclarations $ + mapMaybe generateGlobalType $ + filter shouldInclude (sortWith typeName $ toList types) + where + shouldInclude t = + not (isResolverType t) + && isNotSystemTypeName (typeName t) + && f (typeName t) + +generateGlobalType :: TypeDefinition ANY VALID -> Maybe ClientTypeDefinition +generateGlobalType TypeDefinition {typeName, typeContent} = do + (clientKind, clientCons) <- genContent typeContent + pure + ClientTypeDefinition + { clientTypeName = fromTypeName typeName, + clientKind, + clientCons + } + where + genContent :: TypeContent TRUE ANY VALID -> Maybe (TypeKind, [CodeGenConstructor]) + genContent (DataInputObject inputFields) = + pure + ( KindInputObject, + [ CodeGenConstructor + { constructorName = fromTypeName typeName, + constructorFields = toCodeGenField <$> toList inputFields + } + ] + ) + genContent (DataEnum enumTags) = pure (KindEnum, mkConsEnum typeName <$> enumTags) + genContent DataScalar {} = pure (KindScalar, []) + genContent _ = Nothing + +mkConsEnum :: TypeName -> DataEnumValue s -> CodeGenConstructor +mkConsEnum typename DataEnumValue {enumName} = + CodeGenConstructor (CodeGenTypeName [coerce typename] [] enumName) [] diff --git a/src/Data/Morpheus/Client/CodeGen/Interpreting/Local.hs b/src/Data/Morpheus/Client/CodeGen/Interpreting/Local.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/CodeGen/Interpreting/Local.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.CodeGen.Interpreting.Local + ( toLocalDefinitions, + ) +where + +import Control.Monad.Except (MonadError (throwError)) +import Data.Morpheus.Client.CodeGen.AST + ( ClientDeclaration, + ClientPreDeclaration (..), + ClientTypeDefinition (..), + RequestTypeDefinition (..), + ) +import Data.Morpheus.Client.CodeGen.Interpreting.Core (Converter (..), compileError, deprecationWarning, getType, toClientDeclarations, toCodeGenField, typeFrom) +import Data.Morpheus.Client.CodeGen.Interpreting.PreDeclarations + ( mapPreDeclarations, + ) +import Data.Morpheus.CodeGen.Internal.AST (CodeGenConstructor (..), CodeGenTypeName (..), fromTypeName) +import Data.Morpheus.Core (Config (..), VALIDATION_MODE (WITHOUT_VARIABLES), validateRequest) +import Data.Morpheus.Internal.Ext + ( GQLResult, + ) +import Data.Morpheus.Internal.Utils + ( empty, + keyOf, + selectBy, + ) +import Data.Morpheus.Types.Internal.AST + ( ANY, + ExecutableDocument (..), + FieldDefinition (..), + FieldName, + OUT, + Operation (..), + RAW, + Ref (..), + Schema (..), + Selection (..), + SelectionContent (..), + SelectionSet, + TRUE, + TypeContent (..), + TypeDefinition (..), + TypeKind (..), + TypeName, + TypeRef (..), + UnionTag (..), + VALID, + Variable (..), + VariableDefinitions, + getOperationDataType, + getOperationName, + mkTypeRef, + msg, + toAny, + ) +import qualified Data.Text as T +import Relude hiding (empty, show) +import Prelude (show) + +clientConfig :: Config +clientConfig = + Config + { debug = False, + validationMode = WITHOUT_VARIABLES + } + +toLocalDefinitions :: (Text, ExecutableDocument) -> Schema VALID -> GQLResult [ClientDeclaration] +toLocalDefinitions (query, request) schema = do + validOperation <- validateRequest clientConfig schema request + x <- flip runReaderT (schema, operationArguments $ operation request) $ runConverter $ genLocalDeclarations query validOperation + traverse mapPreDeclarations x + +genLocalDeclarations :: Text -> Operation VALID -> Converter [ClientPreDeclaration] +genLocalDeclarations query op@Operation {operationName, operationSelection, operationType} = do + (schema, varDefs) <- asks id + datatype <- getOperationDataType op schema + let argumentsType = toArgumentsType (fromTypeName $ getOperationName operationName <> "Args") varDefs + (rootType :| localTypes) <- + genLocalTypes + [] + (getOperationName operationName) + (toAny datatype) + operationSelection + pure + ( RequestTypeClass + RequestTypeDefinition + { requestArgs = maybe "()" (typename . clientTypeName) argumentsType, + requestName = typename (clientTypeName rootType), + requestType = operationType, + requestQuery = T.unpack query + } + : concatMap toClientDeclarations (rootType : (localTypes <> maybeToList argumentsType)) + ) + +------------------------------------------------------------------------- +-- generates selection Object Types +genLocalTypes :: + [FieldName] -> + TypeName -> + TypeDefinition ANY VALID -> + SelectionSet VALID -> + Converter (NonEmpty ClientTypeDefinition) +genLocalTypes namespace tName dataType recordSelSet = do + let clientTypeName = CodeGenTypeName {namespace, typeParameters = [], typename = tName} + (con, subTypes) <- toConstructorDefinition (if null namespace then [coerce tName] else namespace) clientTypeName dataType recordSelSet + pure $ + ClientTypeDefinition + { clientTypeName, + clientCons = [con], + clientKind = KindObject Nothing + } + :| subTypes + +toConstructorDefinition :: + [FieldName] -> + CodeGenTypeName -> + TypeDefinition ANY VALID -> + SelectionSet VALID -> + Converter (CodeGenConstructor, [ClientTypeDefinition]) +toConstructorDefinition path name datatype selSet = do + (fields, subTypes) <- unzip <$> traverse genField (toList selSet) + pure (CodeGenConstructor {constructorName = name, constructorFields = map toCodeGenField fields}, concat subTypes) + where + genField :: Selection VALID -> Converter (FieldDefinition ANY VALID, [ClientTypeDefinition]) + genField sel = do + let fieldName = keyOf sel + let fieldPath = path <> [fieldName] + (fieldDataType, fieldType) <- getFieldType fieldPath datatype sel + subTypes <- subTypesBySelection fieldPath fieldDataType sel + pure + ( FieldDefinition + { fieldName, + fieldType, + fieldContent = Nothing, + fieldDescription = Nothing, + fieldDirectives = empty + }, + subTypes + ) + +------------------------------------------ +subTypesBySelection :: + [FieldName] -> + TypeDefinition ANY VALID -> + Selection VALID -> + Converter [ClientTypeDefinition] +subTypesBySelection _ _ Selection {selectionContent = SelectionField} = pure [] +subTypesBySelection path dType Selection {selectionContent = SelectionSet selectionSet} = + toList <$> genLocalTypes path (typeFrom [] dType) dType selectionSet +subTypesBySelection namespace dType Selection {selectionContent = UnionSelection interface unionSelections} = + do + let variants = UnionTag (typeName dType) interface : toList unionSelections + (clientCons, subTypes) <- unzip <$> traverse (getVariantType namespace) variants + pure + ( ClientTypeDefinition + { clientTypeName = CodeGenTypeName {namespace, typeParameters = [], typename = typeFrom [] dType}, + clientCons, + clientKind = KindUnion + } + : concat subTypes + ) + +getVariantType :: [FieldName] -> UnionTag -> Converter (CodeGenConstructor, [ClientTypeDefinition]) +getVariantType path (UnionTag selectedTyName selectionVariant) = do + conDatatype <- getType selectedTyName + toConstructorDefinition path (CodeGenTypeName path [] selectedTyName) conDatatype selectionVariant + +getFieldType :: + [FieldName] -> + TypeDefinition ANY VALID -> + Selection VALID -> + Converter (TypeDefinition ANY VALID, TypeRef) +getFieldType + path + TypeDefinition {typeContent, typeName} + Selection + { selectionName, + selectionPosition + } = toFieldDef typeContent >>= processFieldDefinition + where + toFieldDef :: TypeContent TRUE ANY VALID -> Converter (FieldDefinition OUT VALID) + toFieldDef _ + | selectionName == "__typename" = + pure + FieldDefinition + { fieldName = "__typename", + fieldDescription = Nothing, + fieldType = mkTypeRef "String", + fieldDirectives = empty, + fieldContent = Nothing + } + toFieldDef DataObject {objectFields} = selectBy selError selectionName objectFields + toFieldDef DataInterface {interfaceFields} = selectBy selError selectionName interfaceFields + toFieldDef dt = throwError (compileError $ "Type should be output Object \"" <> msg (show dt)) + selError = compileError $ "can't find field " <> msg selectionName <> " on type: " <> msg (show typeContent) + -- + processFieldDefinition + FieldDefinition + { fieldType = TypeRef {..}, + fieldDirectives + } = + checkDeprecated *> (trans <$> getType typeConName) + where + trans x = (x, TypeRef {typeConName = typeFrom path x, ..}) + ------------------------------------------------------------------ + checkDeprecated :: Converter () + checkDeprecated = deprecationWarning fieldDirectives (coerce typeName, Ref selectionName selectionPosition) + +toArgumentsType :: + CodeGenTypeName -> + VariableDefinitions RAW -> + Maybe ClientTypeDefinition +toArgumentsType clientTypeName variables + | null variables = Nothing + | otherwise = + Just + ClientTypeDefinition + { clientTypeName, + clientKind = KindInputObject, + clientCons = + [ CodeGenConstructor + { constructorName = clientTypeName, + constructorFields = toCodeGenField . toFieldDefinition <$> toList variables + } + ] + } + +toFieldDefinition :: Variable RAW -> FieldDefinition ANY VALID +toFieldDefinition Variable {variableName, variableType} = + FieldDefinition + { fieldName = variableName, + fieldContent = Nothing, + fieldType = variableType, + fieldDescription = Nothing, + fieldDirectives = empty + } diff --git a/src/Data/Morpheus/Client/CodeGen/Interpreting/PreDeclarations.hs b/src/Data/Morpheus/Client/CodeGen/Interpreting/PreDeclarations.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/CodeGen/Interpreting/PreDeclarations.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.CodeGen.Interpreting.PreDeclarations + ( mapPreDeclarations, + ) +where + +import Data.Aeson + ( FromJSON (parseJSON), + ToJSON (toJSON), + ) +import Data.Aeson.Types ((.:), (.:?), (.=)) +import Data.Morpheus.Client.CodeGen.AST + ( AesonField, + ClientDeclaration (..), + ClientMethod (..), + ClientPreDeclaration (..), + DERIVING_MODE (..), + MValue (..), + Printable (..), + RequestTypeDefinition (..), + UnionPat (..), + ) +import Data.Morpheus.Client.CodeGen.Internal (invalidConstructorError, omitNulls) +import Data.Morpheus.Client.Fetch.RequestType + ( RequestType (..), + ) +import Data.Morpheus.CodeGen.Internal.AST + ( AssociatedType (AssociatedTypeName), + CodeGenConstructor (..), + CodeGenField (..), + CodeGenType (..), + CodeGenTypeName (typename), + MethodArgument (..), + TypeClassInstance (..), + fromTypeName, + getFullName, + ) +import Data.Morpheus.CodeGen.TH + ( ToName (toName), + ) +import Data.Morpheus.CodeGen.Utils (camelCaseFieldName) +import Data.Morpheus.Types.GQLScalar + ( scalarFromJSON, + scalarToJSON, + ) +import Data.Morpheus.Types.Internal.AST (Msg (..), internal) +import Language.Haskell.TH.Syntax (Name) +import Relude hiding (ToString, Type, toString) + +mapPreDeclarations :: MonadFail m => ClientPreDeclaration -> m ClientDeclaration +mapPreDeclarations (FromJSONClass mode dec) = InstanceDeclaration <$> deriveFromJSON mode dec +mapPreDeclarations (ToJSONClass mode clientDef) = InstanceDeclaration <$> deriveToJSON mode clientDef +mapPreDeclarations (ClientType c) = pure $ ClientTypeDeclaration c +mapPreDeclarations (RequestTypeClass req) = pure $ InstanceDeclaration (getRequestInstance req) + +getRequestInstance :: RequestTypeDefinition -> TypeClassInstance ClientMethod +getRequestInstance RequestTypeDefinition {..} = + TypeClassInstance + { typeClassName = ''RequestType, + typeClassContext = [], + typeClassTarget = fromTypeName requestName, + assoc = [(''RequestArgs, AssociatedTypeName $ toName requestArgs)], + typeClassMethods + } + where + typeClassMethods = + [ ('__name, ProxyArgument, PrintableMethod $ Printable requestName), + ('__query, ProxyArgument, PrintableMethod $ Printable requestQuery), + ('__type, ProxyArgument, PrintableMethod $ Printable requestType) + ] + +-- FromJSON +deriveFromJSONMethod :: MonadFail m => DERIVING_MODE -> CodeGenType -> m ClientMethod +deriveFromJSONMethod SCALAR_MODE _ = pure $ FunctionNameMethod 'scalarFromJSON +deriveFromJSONMethod _ CodeGenType {cgConstructors = [], ..} = emptyTypeError cgTypeName +deriveFromJSONMethod ENUM_MODE CodeGenType {..} = + pure $ + MatchMethod $ + map (fromJSONEnum . constructorName) cgConstructors + <> [MFunction "v" 'invalidConstructorError] +deriveFromJSONMethod _ CodeGenType {cgConstructors = [CodeGenConstructor {..}]} = pure $ FromJSONObjectMethod (getFullName constructorName) (map defField constructorFields) +deriveFromJSONMethod _ CodeGenType {..} = pure $ FromJSONUnionMethod $ map f cgConstructors <> elseCondition + where + interfaceConstructor = map genObj (maybeToList $ find ((typename cgTypeName ==) . typename . constructorName) cgConstructors) + elseCondition = map ([UVar "_", UVar "v"],) interfaceConstructor + f cons@CodeGenConstructor {..} = ([UString $ typename constructorName, if null constructorFields then UVar "_" else UVar "v"], genObj cons) + +genObj :: CodeGenConstructor -> (Name, [AesonField]) +genObj CodeGenConstructor {..} = (toName constructorName, map defField constructorFields) + +defField :: CodeGenField -> AesonField +defField CodeGenField {..} = (toName ("v" :: String), bindField fieldIsNullable, fieldName) + +bindField :: Bool -> Name +bindField nullable + | nullable = '(.:?) + | otherwise = '(.:) + +deriveToJSONMethod :: MonadFail m => DERIVING_MODE -> CodeGenType -> m (MethodArgument, ClientMethod) +deriveToJSONMethod SCALAR_MODE _ = pure (NoArgument, FunctionNameMethod 'scalarToJSON) +deriveToJSONMethod _ CodeGenType {cgConstructors = [], ..} = emptyTypeError cgTypeName +deriveToJSONMethod ENUM_MODE CodeGenType {cgConstructors} = + pure + ( NoArgument, + MatchMethod $ map (toJSONEnum . constructorName) cgConstructors + ) +deriveToJSONMethod _ CodeGenType {cgConstructors = [CodeGenConstructor {..}]} = + pure + ( DestructArgument (toName constructorName) (map (\(_, _, v) -> v) entries), + ToJSONObjectMethod 'omitNulls entries + ) + where + entries = map mkEntry constructorFields + mkEntry CodeGenField {fieldName} = + ( fieldName, + '(.=), + toName $ camelCaseFieldName (getFullName constructorName) fieldName + ) +deriveToJSONMethod _ _ = fail "Input Unions are not yet supported" + +toJSONEnum :: CodeGenTypeName -> MValue +toJSONEnum name = MTo (getFullName name) (typename name) + +fromJSONEnum :: CodeGenTypeName -> MValue +fromJSONEnum name = MFrom (typename name) (getFullName name) + +deriveToJSON :: MonadFail m => DERIVING_MODE -> CodeGenType -> m (TypeClassInstance ClientMethod) +deriveToJSON mode cType = do + (args, expr) <- deriveToJSONMethod mode cType + pure + TypeClassInstance + { typeClassName = ''ToJSON, + typeClassContext = [], + typeClassTarget = cgTypeName cType, + assoc = [], + typeClassMethods = [('toJSON, args, expr)] + } + +deriveFromJSON :: MonadFail m => DERIVING_MODE -> CodeGenType -> m (TypeClassInstance ClientMethod) +deriveFromJSON mode cType = do + expr <- deriveFromJSONMethod mode cType + pure + TypeClassInstance + { typeClassName = ''FromJSON, + typeClassContext = [], + typeClassTarget = cgTypeName cType, + assoc = [], + typeClassMethods = [('parseJSON, NoArgument, expr)] + } + +emptyTypeError :: MonadFail m => CodeGenTypeName -> m a +emptyTypeError name = fail $ show $ internal ("Type " <> msg (getFullName name) <> " Should Have at least one Constructor") diff --git a/src/Data/Morpheus/Client/CodeGen/QuasiQuoter.hs b/src/Data/Morpheus/Client/CodeGen/QuasiQuoter.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/CodeGen/QuasiQuoter.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.CodeGen.QuasiQuoter + ( raw, + ) +where + +import qualified Data.Text as T +import Language.Haskell.TH.Quote +import Relude hiding (ByteString) + +notSupported :: Text -> a +notSupported things = + error $ + things + <> " are not supported by the GraphQL QuasiQuoter" + +-- | QuasiQuoter to insert multiple lines of text in Haskell +raw :: QuasiQuoter +raw = + QuasiQuoter + { quoteExp = \txt -> [|T.pack txt|], + quotePat = notSupported "Patterns", + quoteType = notSupported "Types", + quoteDec = notSupported "Declarations" + } diff --git a/src/Data/Morpheus/Client/CodeGen/TH.hs b/src/Data/Morpheus/Client/CodeGen/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/CodeGen/TH.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.CodeGen.TH + ( deriveIfNotDefined, + declareIfNotDeclared, + ) +where + +import Data.Morpheus.CodeGen.Internal.AST + ( CodeGenType (..), + CodeGenTypeName (..), + TypeClassInstance (..), + getFullName, + ) +import Data.Morpheus.CodeGen.TH (toName) +import Language.Haskell.TH +import Relude + +isTypeDeclared :: CodeGenTypeName -> Q Bool +isTypeDeclared name = isJust <$> lookupTypeName (toString $ getFullName name) + +isInstanceDefined :: Name -> CodeGenTypeName -> Q Bool +isInstanceDefined typeClass tName = do + exists <- isTypeDeclared tName + if exists + then isInstance typeClass [ConT (toName tName)] + else pure False + +deriveIfNotDefined :: (TypeClassInstance a -> Q Dec) -> TypeClassInstance a -> Q [Dec] +deriveIfNotDefined f dec = do + exists <- isInstanceDefined (typeClassName dec) (typeClassTarget dec) + traverse f [dec | not exists] + +declareIfNotDeclared :: (CodeGenType -> Q a) -> CodeGenType -> Q [a] +declareIfNotDeclared f codeGenType = do + exists <- isTypeDeclared (cgTypeName codeGenType) + traverse f [codeGenType | not exists] diff --git a/src/Data/Morpheus/Client/CodeGen/Utils.hs b/src/Data/Morpheus/Client/CodeGen/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/CodeGen/Utils.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.CodeGen.Utils + ( getSource, + handleResult, + getFile, + readSchemaSource, + ) +where + +import Control.Monad.Except (MonadError (catchError)) +import qualified Data.ByteString.Lazy.Char8 as L +import Data.FileEmbed (makeRelativeToProject) +import Data.List (isSuffixOf) +import Data.Morpheus.Client.Fetch.Types + ( SchemaSource (..), + ) +import Data.Morpheus.Error (gqlWarnings, renderGQLErrors) +import Data.Morpheus.Internal.Ext (GQLResult, Result (..)) +import qualified Data.Text.IO as TIO +import Language.Haskell.TH (Q, runIO) +import Language.Haskell.TH.Syntax (qAddDependentFile) +import Relude + +readSchemaSource :: FilePath -> IO SchemaSource +readSchemaSource p + | ".json" `isSuffixOf` p = JSON <$> L.readFile p + | ".gql" `isSuffixOf` p || ".graphql" `isSuffixOf` p = GQL <$> L.readFile p + | otherwise = fail "Unsupported file format! The input should have one of the following extensions: json, gql, graphql" + +getSource :: FilePath -> Q SchemaSource +getSource = readWith readSchemaSource + +getFile :: FilePath -> Q Text +getFile = readWith TIO.readFile + +readWith :: (FilePath -> IO a) -> FilePath -> Q a +readWith f path = do + p <- makeRelativeToProject path + qAddDependentFile p + file <- runIO (catchError ((fmap Right . f) p) (pure . Left . show)) + case file of + Left x -> fail x + Right x -> pure x + +handleResult :: GQLResult t -> (t -> Q a) -> Q a +handleResult x f = case x of + Failure errors -> fail (renderGQLErrors errors) + Success + { result, + warnings + } -> gqlWarnings warnings >> f result diff --git a/src/Data/Morpheus/Client/Declare.hs b/src/Data/Morpheus/Client/Declare.hs deleted file mode 100644 --- a/src/Data/Morpheus/Client/Declare.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.Client.Declare - ( declareGlobalTypes, - declareGlobalTypesByName, - declareLocalTypes, - declareLocalTypesInline, - internalLegacyLocalDeclareTypes, - clientTypeDeclarations, - raw, - ) -where - -import Data.Morpheus.Client.Internal.Types - ( ExecutableSource, - SchemaSource, - ) -import Data.Morpheus.Client.Internal.Utils (getFile, getSource, handleResult) -import Data.Morpheus.Client.Printing.TH - ( printDeclarations, - ) -import Data.Morpheus.Client.QuasiQuoter (raw) -import Data.Morpheus.Client.Schema.Parse (parseSchema) -import Data.Morpheus.Client.Transform - ( toGlobalDefinitions, - toLocalDefinitions, - ) -import Data.Morpheus.Core (parseRequest) -import Data.Morpheus.Types.IO (GQLRequest (..)) -import Data.Morpheus.Types.Internal.AST (TypeName) -import qualified Data.Set as S -import Language.Haskell.TH (Dec, Q, runIO) -import Relude - -internalLegacyLocalDeclareTypes :: IO SchemaSource -> ExecutableSource -> Q [Dec] -internalLegacyLocalDeclareTypes schemaSrc query = do - schemaText <- runIO schemaSrc - let request = - GQLRequest - { query, - operationName = Nothing, - variables = Nothing - } - handleResult - ( do - schemaDoc <- parseSchema schemaText - executableDoc <- parseRequest request - toLocalDefinitions (query, executableDoc) schemaDoc - ) - printDeclarations - -globalTypeDeclarations :: SchemaSource -> (TypeName -> Bool) -> Q [Dec] -globalTypeDeclarations src f = handleResult (toGlobalDefinitions f <$> parseSchema src) printDeclarations - --- | declares global or local types, depending --- on whether the second argument is specified or not -clientTypeDeclarations :: - SchemaSource -> - Maybe ExecutableSource -> - Q [Dec] -clientTypeDeclarations src (Just doc) = internalLegacyLocalDeclareTypes (pure src) doc -clientTypeDeclarations src Nothing = globalTypeDeclarations src (const True) - -{- ORMOLU_DISABLE -} --- | declares input, enum and scalar types for specified schema --- --- Example where the schema is defined in SDL format --- --- @ --- 'declareGlobalTypes' "schema.gql" --- @ --- --- Example with schema as introspection in JSON format. --- --- @ --- 'declareGlobalTypes' "schema.json" --- @ -declareGlobalTypes :: - FilePath -- ^ the schema path relative to the project location, - -- both introspection (.json) and - -- schema definition (.gql, .graphql) are accepted. - -> Q [Dec] -declareGlobalTypes = flip declareClientTypes Nothing -{- ORMOLU_ENABLE -} - --- | declares global types like 'declareGlobalTypes', --- while enabling to select only the types that are needed. -declareGlobalTypesByName :: FilePath -> [TypeName] -> Q [Dec] -declareGlobalTypesByName path names = do - schema <- getSource path - globalTypeDeclarations schema (`S.member` S.fromList names) - -{- ORMOLU_DISABLE -} --- | declares object, interface and union types for --- specified schema and query. --- --- Example where the schema is defined in SDL format --- --- @ --- 'declareLocalTypes' "schema.gql" "query.gql" --- @ --- --- Example with schema as introspection in JSON format. --- --- @ --- 'declareLocalTypes' "schema.json" "query.gql" --- @ -declareLocalTypes :: - FilePath -- ^ the schema path relative to the project location. - -- both introspection (`.json`) and - -- schema definition (`.gql`, `.graphql`) are accepted. - -> FilePath -- ^ query path relative to the project location - -> Q [Dec] -declareLocalTypes schema query = declareClientTypes schema (Just query) -{- ORMOLU_ENABLE -} - -{- ORMOLU_DISABLE -} --- | inline version of `declareLocalTypes`, however --- instead of specifying the file path, you can simply --- pass the query as text using QuasiQuoter `raw` --- --- @ --- `declareLocalTypesInline` "schema.gql" --- [`raw`| --- query GetUsers { --- users { --- name --- } --- } --- ] --- @ -declareLocalTypesInline :: - FilePath -- ^ the schema path relative to the project location. - -- both introspection (`.json`) and - -- schema definition (`.gql`, `.graphql`) are accepted. - -> ExecutableSource -- ^ inline graphql query in Text format - -> Q [Dec] -declareLocalTypesInline schemaPath query = do - schema <- getSource schemaPath - clientTypeDeclarations schema (Just query) -{- ORMOLU_ENABLE -} - -declareClientTypes :: - FilePath -> - Maybe FilePath -> - Q [Dec] -declareClientTypes schemaPath queryPath = do - schema <- getSource schemaPath - query <- traverse getFile queryPath - clientTypeDeclarations schema query diff --git a/src/Data/Morpheus/Client/Fetch.hs b/src/Data/Morpheus/Client/Fetch.hs --- a/src/Data/Morpheus/Client/Fetch.hs +++ b/src/Data/Morpheus/Client/Fetch.hs @@ -23,7 +23,7 @@ ) import Data.ByteString.Lazy (ByteString) import Data.Morpheus.Client.Fetch.RequestType (Request (Request), RequestType (RequestArgs), processResponse, toRequest) -import Data.Morpheus.Client.Internal.Types +import Data.Morpheus.Client.Fetch.Types ( FetchError (..), ) import Relude hiding (ByteString) diff --git a/src/Data/Morpheus/Client/Fetch/Http.hs b/src/Data/Morpheus/Client/Fetch/Http.hs --- a/src/Data/Morpheus/Client/Fetch/Http.hs +++ b/src/Data/Morpheus/Client/Fetch/Http.hs @@ -18,7 +18,7 @@ decodeResponse, toRequest, ) -import Data.Morpheus.Client.Internal.Types (GQLClientResult) +import Data.Morpheus.Client.Fetch.Types (GQLClientResult) import qualified Data.Text as T import Network.HTTP.Req ( POST (..), diff --git a/src/Data/Morpheus/Client/Fetch/RequestType.hs b/src/Data/Morpheus/Client/Fetch/RequestType.hs --- a/src/Data/Morpheus/Client/Fetch/RequestType.hs +++ b/src/Data/Morpheus/Client/Fetch/RequestType.hs @@ -29,7 +29,7 @@ import qualified Data.Aeson as A import qualified Data.Aeson.Types as A import Data.ByteString.Lazy (ByteString) -import Data.Morpheus.Client.Internal.Types +import Data.Morpheus.Client.Fetch.Types ( FetchError (..), ) import Data.Morpheus.Client.Schema.JSON.Types diff --git a/src/Data/Morpheus/Client/Fetch/ResponseStream.hs b/src/Data/Morpheus/Client/Fetch/ResponseStream.hs --- a/src/Data/Morpheus/Client/Fetch/ResponseStream.hs +++ b/src/Data/Morpheus/Client/Fetch/ResponseStream.hs @@ -26,6 +26,7 @@ Request (..), isSubscription, ) +import Data.Morpheus.Client.Fetch.Types import Data.Morpheus.Client.Fetch.WebSockets ( endSession, receiveResponse, @@ -34,7 +35,6 @@ sendRequest, useWS, ) -import Data.Morpheus.Client.Internal.Types import qualified Data.Text as T import Relude hiding (ByteString) import Text.URI (URI, mkURI) diff --git a/src/Data/Morpheus/Client/Fetch/Types.hs b/src/Data/Morpheus/Client/Fetch/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Fetch/Types.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.Fetch.Types + ( FetchError (..), + SchemaSource (..), + ExecutableSource, + GQLClientResult, + ) +where + +import Data.ByteString.Lazy (ByteString) +import Data.Morpheus.Types.Internal.AST + ( GQLErrors, + ) +import Relude hiding (ByteString) + +data FetchError a + = FetchErrorParseFailure String + | FetchErrorProducedErrors GQLErrors (Maybe a) + | FetchErrorNoResult + deriving (Show, Eq, Generic) + +data SchemaSource + = JSON ByteString + | GQL ByteString + deriving (Show, Eq) + +type ExecutableSource = Text + +type GQLClientResult (a :: Type) = (Either (FetchError a) a) diff --git a/src/Data/Morpheus/Client/Fetch/WebSockets.hs b/src/Data/Morpheus/Client/Fetch/WebSockets.hs --- a/src/Data/Morpheus/Client/Fetch/WebSockets.hs +++ b/src/Data/Morpheus/Client/Fetch/WebSockets.hs @@ -22,7 +22,7 @@ import qualified Data.Map as M import Data.Morpheus.Client.Fetch.GQLClient (Headers) import Data.Morpheus.Client.Fetch.RequestType (Request, RequestType (..), processResponse, toRequest) -import Data.Morpheus.Client.Internal.Types (FetchError (..), GQLClientResult) +import Data.Morpheus.Client.Fetch.Types (FetchError (..), GQLClientResult) import Data.Morpheus.Client.Schema.JSON.Types (JSONResponse (..)) import Data.Morpheus.Subscriptions.Internal (ApolloSubscription (..)) import qualified Data.Text as T diff --git a/src/Data/Morpheus/Client/Internal/TH.hs b/src/Data/Morpheus/Client/Internal/TH.hs deleted file mode 100644 --- a/src/Data/Morpheus/Client/Internal/TH.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.Client.Internal.TH - ( matchWith, - decodeObjectE, - mkFieldsE, - failExp, - deriveIfNotDefined, - declareIfNotDeclared, - ) -where - -import Data.Aeson ((.:)) -import Data.Aeson.Types ((.:?)) -import Data.Foldable (foldr1) -import Data.Morpheus.CodeGen.Internal.AST - ( CodeGenConstructor (..), - CodeGenField (..), - CodeGenType (cgTypeName), - CodeGenTypeName (..), - getFullName, - ) -import Data.Morpheus.CodeGen.TH - ( toCon, - toName, - toString, - toVar, - v', - ) -import Data.Morpheus.CodeGen.Utils - ( camelCaseFieldName, - ) -import Language.Haskell.TH -import Relude hiding (toString) - -matchWith :: - Maybe (PatQ, ExpQ) -> - (t -> (PatQ, ExpQ)) -> - [t] -> - ExpQ -matchWith fbexp f xs = lamCaseE (map buildMatch xs <> fallback fbexp) - where - fallback (Just (pat, fb)) = [match pat (normalB fb) []] - fallback _ = [] - buildMatch x = match pat (normalB body) [] - where - (pat, body) = f x - -failExp :: ExpQ -failExp = - appE - (toVar 'fail) - ( uInfixE - (appE [|show|] v') - [|(<>)|] - (stringE " is Not Valid Union Constructor") - ) - -decodeObjectE :: CodeGenConstructor -> ExpQ -decodeObjectE CodeGenConstructor {..} - | null constructorFields = appE [|pure|] (toCon constructorName) - | otherwise = - uInfixE - (toCon constructorName) - [|(<$>)|] - (foldr1 withApplicative $ map defField constructorFields) - -defField :: CodeGenField -> ExpQ -defField CodeGenField {..} = uInfixE v' (varE $ bindField fieldIsNullable) (toString fieldName) - -bindField :: Bool -> Name -bindField nullable - | nullable = '(.:?) - | otherwise = '(.:) - -withApplicative :: ExpQ -> ExpQ -> ExpQ -withApplicative x = uInfixE x [|(<*>)|] - --- | 'mkFieldsE' --- --- input : --- >>> --- mkFieldsE 'mkValue [FieldDefinition { fieldName = \"field1" ,..} ,..] --- >>> --- --- expression : --- >>> --- [ mkValue \"field1\" field1, --- .. --- ] --- >>> -mkFieldsE :: CodeGenTypeName -> Name -> [CodeGenField] -> Exp -mkFieldsE conName name = ListE . map (mkEntryWith conName name) - --- input : mkFieldWith 'mkValue (FieldDefinition { fieldName = "field1", ..}) --- expression: mkValue "field1" field1 -mkEntryWith :: - CodeGenTypeName -> - Name -> - CodeGenField -> - Exp -mkEntryWith conName f CodeGenField {fieldName} = - AppE - (AppE (VarE f) (toString fieldName)) - (toVar $ camelCaseFieldName (getFullName conName) fieldName) - -isTypeDeclared :: CodeGenTypeName -> Q Bool -isTypeDeclared clientTypeName = do - let name = toName clientTypeName - m <- lookupTypeName (show name) - case m of - Nothing -> pure False - _ -> pure True - -hasInstance :: Name -> CodeGenType -> Q Bool -hasInstance typeClass clientDef = isInstance typeClass [ConT (toName (cgTypeName clientDef))] - -deriveIfNotDefined :: (CodeGenType -> Q Dec) -> Name -> CodeGenType -> Q [Dec] -deriveIfNotDefined derivation typeClass clientDef = do - exists <- isTypeDeclared (cgTypeName clientDef) - if exists - then do - has <- hasInstance typeClass clientDef - if has - then pure [] - else mkDerivation - else mkDerivation - where - mkDerivation :: Q [Dec] - mkDerivation = pure <$> derivation clientDef - -declareIfNotDeclared :: (CodeGenType -> a) -> CodeGenType -> Q [a] -declareIfNotDeclared f c = do - exists <- isTypeDeclared (cgTypeName c) - if exists - then pure [] - else pure [f c] diff --git a/src/Data/Morpheus/Client/Internal/Types.hs b/src/Data/Morpheus/Client/Internal/Types.hs deleted file mode 100644 --- a/src/Data/Morpheus/Client/Internal/Types.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.Client.Internal.Types - ( ClientTypeDefinition (..), - RequestTypeDefinition (..), - FetchError (..), - SchemaSource (..), - ExecutableSource, - GQLClientResult, - ClientDeclaration (..), - DERIVING_MODE (..), - ) -where - -import Data.ByteString.Lazy (ByteString) -import Data.Morpheus.CodeGen.Internal.AST - ( CodeGenConstructor (..), - CodeGenType, - CodeGenTypeName, - ) -import Data.Morpheus.Types.Internal.AST - ( GQLErrors, - OperationType, - TypeKind, - TypeName, - ) -import Relude hiding (ByteString) - -data DERIVING_MODE = SCALAR_MODE | ENUM_MODE | TYPE_MODE - -data ClientDeclaration - = ToJSONClass DERIVING_MODE CodeGenType - | FromJSONClass DERIVING_MODE CodeGenType - | RequestTypeClass RequestTypeDefinition - | ClientType CodeGenType - -data ClientTypeDefinition = ClientTypeDefinition - { clientTypeName :: CodeGenTypeName, - clientCons :: [CodeGenConstructor], - clientKind :: TypeKind - } - deriving (Show) - -data RequestTypeDefinition = RequestTypeDefinition - { requestName :: TypeName, - requestArgs :: TypeName, - requestType :: OperationType, - requestQuery :: String - } - deriving (Show) - -data FetchError a - = FetchErrorParseFailure String - | FetchErrorProducedErrors GQLErrors (Maybe a) - | FetchErrorNoResult - deriving (Show, Eq, Generic) - -data SchemaSource - = JSON ByteString - | GQL ByteString - deriving (Show, Eq) - -type ExecutableSource = Text - -type GQLClientResult (a :: Type) = (Either (FetchError a) a) diff --git a/src/Data/Morpheus/Client/Internal/Utils.hs b/src/Data/Morpheus/Client/Internal/Utils.hs deleted file mode 100644 --- a/src/Data/Morpheus/Client/Internal/Utils.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.Client.Internal.Utils - ( removeDuplicates, - isEnum, - getSource, - handleResult, - getFile, - omitNulls, - emptyTypeError, - takeValueType, - ) -where - -import Control.Monad.Except (MonadError (catchError)) -import Data.Aeson (Object) -import Data.Aeson.Types (Pair, Parser, Value (..), object) -import qualified Data.ByteString.Lazy.Char8 as L -import Data.FileEmbed (makeRelativeToProject) -import Data.List (isSuffixOf) -import Data.Morpheus.Client.Internal.Types - ( SchemaSource (..), - ) -import Data.Morpheus.CodeGen.Internal.AST (CodeGenConstructor (..), CodeGenTypeName (..), getFullName) -import Data.Morpheus.Error (gqlWarnings, renderGQLErrors) -import Data.Morpheus.Internal.Ext (GQLResult, Result (..)) -import Data.Morpheus.Internal.Utils (IsMap (lookup)) -import Data.Morpheus.Types.Internal.AST (Msg (msg), internal) -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import Language.Haskell.TH (Q, runIO) -import Language.Haskell.TH.Syntax (qAddDependentFile) -import Relude - -removeDuplicates :: Eq a => [a] -> [a] -removeDuplicates = fst . splitDuplicates - -splitDuplicates :: Eq a => [a] -> ([a], [a]) -splitDuplicates = collectElems ([], []) - where - collectElems :: Eq a => ([a], [a]) -> [a] -> ([a], [a]) - collectElems collected [] = collected - collectElems (collected, errors) (x : xs) - | x `elem` collected = collectElems (collected, errors <> [x]) xs - | otherwise = collectElems (collected <> [x], errors) xs - -isEnum :: [CodeGenConstructor] -> Bool -isEnum = all (null . constructorFields) - -getSource :: FilePath -> Q SchemaSource -getSource p - | ".json" `isSuffixOf` p = JSON <$> readWith L.readFile p - | ".gql" `isSuffixOf` p || ".graphql" `isSuffixOf` p = GQL <$> readWith L.readFile p - | otherwise = fail "Unsupported file format! The input should have one of the following extensions: json, gql, graphql" - -getFile :: FilePath -> Q Text -getFile = readWith TIO.readFile - -readWith :: (FilePath -> IO a) -> FilePath -> Q a -readWith f path = do - p <- makeRelativeToProject path - qAddDependentFile p - file <- runIO (catchError ((fmap Right . f) p) (pure . Left . show)) - case file of - Left x -> fail x - Right x -> pure x - -handleResult :: GQLResult t -> (t -> Q a) -> Q a -handleResult x f = case x of - Failure errors -> fail (renderGQLErrors errors) - Success - { result, - warnings - } -> gqlWarnings warnings >> f result - -omitNulls :: [Pair] -> Value -omitNulls = object . filter notNull - where - notNull (_, Null) = False - notNull _ = True - -emptyTypeError :: MonadFail m => CodeGenTypeName -> m a -emptyTypeError name = fail $ show $ internal ("Type " <> msg (getFullName name) <> " Should Have at least one Constructor") - -takeValueType :: ((String, Object) -> Parser a) -> Value -> Parser a -takeValueType f (Object hMap) = case lookup "__typename" hMap of - Nothing -> fail "key \"__typename\" not found on object" - Just (String x) -> f (T.unpack x, hMap) - Just val -> - fail $ "key \"__typename\" should be string but found: " <> show val -takeValueType _ _ = fail "expected Object" diff --git a/src/Data/Morpheus/Client/Printing/TH.hs b/src/Data/Morpheus/Client/Printing/TH.hs deleted file mode 100644 --- a/src/Data/Morpheus/Client/Printing/TH.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.Client.Printing.TH - ( printDeclarations, - ) -where - -import Data.Aeson - ( FromJSON (parseJSON), - KeyValue ((.=)), - ToJSON (toJSON), - withObject, - ) -import Data.Morpheus.Client.Fetch.RequestType - ( RequestType (..), - ) -import Data.Morpheus.Client.Internal.TH - ( declareIfNotDeclared, - decodeObjectE, - deriveIfNotDefined, - failExp, - matchWith, - mkFieldsE, - ) -import Data.Morpheus.Client.Internal.Types - ( ClientDeclaration (..), - DERIVING_MODE (..), - RequestTypeDefinition (..), - ) -import Data.Morpheus.Client.Internal.Utils - ( emptyTypeError, - omitNulls, - takeValueType, - ) -import Data.Morpheus.CodeGen.Internal.AST - ( CodeGenConstructor (..), - CodeGenType (..), - CodeGenTypeName (..), - getFullName, - ) -import Data.Morpheus.CodeGen.TH - ( PrintDec (printDec), - ToString (..), - destructConstructor, - printTypeClass, - toCon, - toName, - toString, - toVar, - v', - _', - ) -import Data.Morpheus.Types.GQLScalar - ( scalarFromJSON, - scalarToJSON, - ) -import Data.Morpheus.Types.Internal.AST - ( TypeName, - ) -import Language.Haskell.TH - ( Dec, - DecQ, - Exp (..), - ExpQ, - PatQ, - Q, - appE, - tupP, - ) -import Relude hiding (ToString, toString) - -printDeclarations :: [ClientDeclaration] -> Q [Dec] -printDeclarations clientType = concat <$> traverse typeDeclarations clientType - -typeDeclarations :: ClientDeclaration -> Q [Dec] -typeDeclarations (FromJSONClass mode clientDef) = deriveIfNotDefined (deriveFromJSON mode) ''FromJSON clientDef -typeDeclarations (ToJSONClass mode clientDef) = deriveIfNotDefined (deriveToJSON mode) ''ToJSON clientDef -typeDeclarations (ClientType c) = declareIfNotDeclared printDec c -typeDeclarations (RequestTypeClass RequestTypeDefinition {..}) = - pure <$> printTypeClass [] ''RequestType (toCon requestName) [(''RequestArgs, toCon requestArgs)] methods - where - methods = - [ ('__name, [_'], [|requestName|]), - ('__query, [_'], [|requestQuery|]), - ('__type, [_'], [|requestType|]) - ] - --- UTILS - -mkFromJSON :: CodeGenTypeName -> ExpQ -> DecQ -mkFromJSON name expr = printTypeClass [] ''FromJSON (toCon (toName name)) [] [('parseJSON, [], expr)] - -mkToJSON :: CodeGenTypeName -> [PatQ] -> ExpQ -> DecQ -mkToJSON name args expr = printTypeClass [] ''ToJSON (toCon $ toName name) [] [('toJSON, args, expr)] - -originalLit :: ToString TypeName a => CodeGenTypeName -> Q a -originalLit = toString . typename - --- FromJSON -deriveFromJSON :: DERIVING_MODE -> CodeGenType -> DecQ -deriveFromJSON SCALAR_MODE CodeGenType {cgTypeName} = mkFromJSON cgTypeName [|scalarFromJSON|] -deriveFromJSON _ CodeGenType {cgConstructors = [], ..} = emptyTypeError cgTypeName -deriveFromJSON ENUM_MODE CodeGenType {..} = - mkFromJSON cgTypeName (matchWith (Just (v', failExp)) fromJSONEnum cgConstructors) -deriveFromJSON _ CodeGenType {cgConstructors = [cons], ..} = - mkFromJSON cgTypeName (fromJSONObject cons) -deriveFromJSON _ typeD@CodeGenType {cgTypeName} = - mkFromJSON cgTypeName (fromJSONUnion typeD) - -fromJSONEnum :: CodeGenConstructor -> (PatQ, ExpQ) -fromJSONEnum CodeGenConstructor {constructorName} = (originalLit constructorName, appE (toVar 'pure) (toCon constructorName)) - -fromJSONObject :: CodeGenConstructor -> ExpQ -fromJSONObject con@CodeGenConstructor {constructorName} = withBody <$> decodeObjectE con - where - withBody body = AppE (AppE (VarE 'withObject) name) (LamE [v'] body) - name :: Exp - name = toString (getFullName constructorName) - -fromJSONUnion :: CodeGenType -> ExpQ -fromJSONUnion CodeGenType {..} = appE (toVar 'takeValueType) (matchWith elseCondition f cgConstructors) - where - elseCondition = - (tupP [_', v'],) . decodeObjectE - <$> find ((typename cgTypeName ==) . typename . constructorName) cgConstructors - f cons@CodeGenConstructor {..} = - ( tupP [originalLit constructorName, if null constructorFields then _' else v'], - decodeObjectE cons - ) - --- ToJSON -deriveToJSON :: DERIVING_MODE -> CodeGenType -> DecQ -deriveToJSON SCALAR_MODE CodeGenType {..} = mkToJSON cgTypeName [] [|scalarToJSON|] -deriveToJSON _ CodeGenType {cgConstructors = [], ..} = emptyTypeError cgTypeName -deriveToJSON ENUM_MODE CodeGenType {..} = - mkToJSON cgTypeName [] (matchWith Nothing toJSONEnum cgConstructors) -deriveToJSON _ CodeGenType {cgConstructors = [cons], ..} = - mkToJSON cgTypeName [destructConstructor cons] (toJSONObject cons) -deriveToJSON _ _ = fail "Input Unions are not yet supported" - -toJSONEnum :: CodeGenConstructor -> (PatQ, ExpQ) -toJSONEnum CodeGenConstructor {constructorName} = (toCon constructorName, originalLit constructorName) - -toJSONObject :: CodeGenConstructor -> ExpQ -toJSONObject CodeGenConstructor {..} = pure $ AppE (VarE 'omitNulls) (mkFieldsE constructorName '(.=) constructorFields) diff --git a/src/Data/Morpheus/Client/QuasiQuoter.hs b/src/Data/Morpheus/Client/QuasiQuoter.hs deleted file mode 100644 --- a/src/Data/Morpheus/Client/QuasiQuoter.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.Client.QuasiQuoter - ( raw, - ) -where - -import qualified Data.Text as T -import Language.Haskell.TH.Quote -import Relude hiding (ByteString) - -notSupported :: Text -> a -notSupported things = - error $ - things - <> " are not supported by the GraphQL QuasiQuoter" - --- | QuasiQuoter to insert multiple lines of text in Haskell -raw :: QuasiQuoter -raw = - QuasiQuoter - { quoteExp = \txt -> [|T.pack txt|], - quotePat = notSupported "Patterns", - quoteType = notSupported "Types", - quoteDec = notSupported "Declarations" - } diff --git a/src/Data/Morpheus/Client/Schema/Parse.hs b/src/Data/Morpheus/Client/Schema/Parse.hs --- a/src/Data/Morpheus/Client/Schema/Parse.hs +++ b/src/Data/Morpheus/Client/Schema/Parse.hs @@ -3,7 +3,7 @@ ) where -import Data.Morpheus.Client.Internal.Types (SchemaSource (..)) +import Data.Morpheus.Client.Fetch.Types (SchemaSource (..)) import Data.Morpheus.Client.Schema.JSON.Parse ( decodeIntrospection, ) diff --git a/src/Data/Morpheus/Client/Transform.hs b/src/Data/Morpheus/Client/Transform.hs deleted file mode 100644 --- a/src/Data/Morpheus/Client/Transform.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Data.Morpheus.Client.Transform - ( toGlobalDefinitions, - toLocalDefinitions, - ) -where - -import Data.Morpheus.Client.Transform.Global (toGlobalDefinitions) -import Data.Morpheus.Client.Transform.Local - ( toLocalDefinitions, - ) diff --git a/src/Data/Morpheus/Client/Transform/Core.hs b/src/Data/Morpheus/Client/Transform/Core.hs deleted file mode 100644 --- a/src/Data/Morpheus/Client/Transform/Core.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.Client.Transform.Core - ( Converter (..), - compileError, - getType, - typeFrom, - deprecationWarning, - toCodeGenField, - toClientDeclarations, - ) -where - -import Control.Monad.Except (MonadError) -import Data.Morpheus.Client.Internal.Types - ( ClientDeclaration (..), - ClientTypeDefinition (..), - DERIVING_MODE (..), - ) -import Data.Morpheus.CodeGen.Internal.AST - ( CodeGenField (..), - CodeGenType (..), - DerivingClass (..), - FIELD_TYPE_WRAPPER (..), - ) -import Data.Morpheus.CodeGen.Utils (camelCaseTypeName) -import Data.Morpheus.Error - ( deprecatedField, - ) -import Data.Morpheus.Internal.Ext - ( GQLResult, - Result (..), - ) -import Data.Morpheus.Internal.Utils - ( selectBy, - ) -import Data.Morpheus.Types.Internal.AST - ( ANY, - Directives, - FieldDefinition (..), - FieldName, - GQLError, - RAW, - Ref (..), - Schema (..), - TypeContent (..), - TypeDefinition (..), - TypeKind (..), - TypeName, - TypeRef (..), - VALID, - VariableDefinitions, - internal, - isNullable, - isResolverType, - lookupDeprecated, - lookupDeprecatedReason, - msg, - typeDefinitions, - ) -import Relude - -type Env = (Schema VALID, VariableDefinitions RAW) - -newtype Converter a = Converter - { runConverter :: - ReaderT - Env - GQLResult - a - } - deriving - ( Functor, - Applicative, - Monad, - MonadReader Env, - MonadError GQLError - ) - -compileError :: GQLError -> GQLError -compileError x = internal $ "Unhandled Compile Time Error: \"" <> x <> "\" ;" - -getType :: TypeName -> Converter (TypeDefinition ANY VALID) -getType typename = - asks (typeDefinitions . fst) - >>= selectBy (compileError $ " can't find Type" <> msg typename) typename - -typeFrom :: [FieldName] -> TypeDefinition a VALID -> TypeName -typeFrom path TypeDefinition {typeName, typeContent} = __typeFrom typeContent - where - __typeFrom DataObject {} = camelCaseTypeName path typeName - __typeFrom DataInterface {} = camelCaseTypeName path typeName - __typeFrom DataUnion {} = camelCaseTypeName path typeName - __typeFrom _ = typeName - -deprecationWarning :: Directives VALID -> (FieldName, Ref FieldName) -> Converter () -deprecationWarning dirs (typename, ref) = case lookupDeprecated dirs of - Just deprecation -> Converter $ lift $ Success {result = (), warnings} - where - warnings = - [ deprecatedField - typename - ref - (lookupDeprecatedReason deprecation) - ] - Nothing -> pure () - -toCodeGenField :: FieldDefinition a b -> CodeGenField -toCodeGenField FieldDefinition {fieldType = field@TypeRef {..}, ..} = - CodeGenField - { fieldName, - fieldType = typeConName, - wrappers = [GQL_WRAPPER typeWrappers], - fieldIsNullable = isNullable field - } - -toClientDeclarations :: ClientTypeDefinition -> [ClientDeclaration] -toClientDeclarations def@ClientTypeDefinition {clientKind} - | KindScalar == clientKind = [FromJSONClass SCALAR_MODE cgType, ToJSONClass SCALAR_MODE cgType] - | KindEnum == clientKind = [ClientType cgType, FromJSONClass ENUM_MODE cgType, ToJSONClass ENUM_MODE cgType] - | isResolverType clientKind = [ClientType cgType, FromJSONClass TYPE_MODE cgType] - | otherwise = [ClientType cgType, ToJSONClass TYPE_MODE cgType] - where - cgType = printClientType def - -printClientType :: ClientTypeDefinition -> CodeGenType -printClientType ClientTypeDefinition {..} = - CodeGenType - { cgTypeName = clientTypeName, - cgConstructors = clientCons, - cgDerivations = [GENERIC, SHOW, CLASS_EQ] - } diff --git a/src/Data/Morpheus/Client/Transform/Global.hs b/src/Data/Morpheus/Client/Transform/Global.hs deleted file mode 100644 --- a/src/Data/Morpheus/Client/Transform/Global.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.Client.Transform.Global - ( toArgumentsType, - toGlobalDefinitions, - ) -where - -import Data.Morpheus.Client.Internal.Types - ( ClientDeclaration, - ClientTypeDefinition (..), - ) -import Data.Morpheus.Client.Transform.Core (toClientDeclarations, toCodeGenField) -import Data.Morpheus.CodeGen.Internal.AST - ( CodeGenConstructor (..), - CodeGenTypeName (..), - fromTypeName, - ) -import Data.Morpheus.Internal.Utils - ( empty, - ) -import Data.Morpheus.Types.Internal.AST - ( ANY, - DataEnumValue (DataEnumValue, enumName), - FieldDefinition (..), - RAW, - Schema (Schema, types), - TRUE, - TypeContent (..), - TypeDefinition (..), - TypeKind (..), - TypeName, - VALID, - Variable (..), - VariableDefinitions, - isNotSystemTypeName, - isResolverType, - ) -import Relude hiding (empty) - -toArgumentsType :: - CodeGenTypeName -> - VariableDefinitions RAW -> - Maybe ClientTypeDefinition -toArgumentsType clientTypeName variables - | null variables = Nothing - | otherwise = - Just - ClientTypeDefinition - { clientTypeName, - clientKind = KindInputObject, - clientCons = - [ CodeGenConstructor - { constructorName = clientTypeName, - constructorFields = toCodeGenField . toFieldDefinition <$> toList variables - } - ] - } - -toFieldDefinition :: Variable RAW -> FieldDefinition ANY VALID -toFieldDefinition Variable {variableName, variableType} = - FieldDefinition - { fieldName = variableName, - fieldContent = Nothing, - fieldType = variableType, - fieldDescription = Nothing, - fieldDirectives = empty - } - -toGlobalDefinitions :: (TypeName -> Bool) -> Schema VALID -> [ClientDeclaration] -toGlobalDefinitions f Schema {types} = - concatMap toClientDeclarations $ - mapMaybe generateGlobalType $ - filter shouldInclude (toList types) - where - shouldInclude t = - not (isResolverType t) - && isNotSystemTypeName (typeName t) - && f (typeName t) - -generateGlobalType :: TypeDefinition ANY VALID -> Maybe ClientTypeDefinition -generateGlobalType TypeDefinition {typeName, typeContent} = do - (clientKind, clientCons) <- genContent typeContent - pure - ClientTypeDefinition - { clientTypeName = fromTypeName typeName, - clientKind, - clientCons - } - where - genContent :: TypeContent TRUE ANY VALID -> Maybe (TypeKind, [CodeGenConstructor]) - genContent (DataInputObject inputFields) = - pure - ( KindInputObject, - [ CodeGenConstructor - { constructorName = fromTypeName typeName, - constructorFields = toCodeGenField <$> toList inputFields - } - ] - ) - genContent (DataEnum enumTags) = pure (KindEnum, mkConsEnum typeName <$> enumTags) - genContent DataScalar {} = pure (KindScalar, []) - genContent _ = Nothing - -mkConsEnum :: TypeName -> DataEnumValue s -> CodeGenConstructor -mkConsEnum typename DataEnumValue {enumName} = - CodeGenConstructor (CodeGenTypeName [coerce typename] [] enumName) [] diff --git a/src/Data/Morpheus/Client/Transform/Local.hs b/src/Data/Morpheus/Client/Transform/Local.hs deleted file mode 100644 --- a/src/Data/Morpheus/Client/Transform/Local.hs +++ /dev/null @@ -1,209 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.Client.Transform.Local - ( toLocalDefinitions, - ) -where - -import Control.Monad.Except (MonadError (throwError)) -import Data.Morpheus.Client.Internal.Types - ( ClientDeclaration (..), - ClientTypeDefinition (..), - RequestTypeDefinition (..), - ) -import Data.Morpheus.Client.Transform.Core (Converter (..), compileError, deprecationWarning, getType, toClientDeclarations, toCodeGenField, typeFrom) -import Data.Morpheus.Client.Transform.Global (toArgumentsType) -import Data.Morpheus.CodeGen.Internal.AST (CodeGenConstructor (..), CodeGenTypeName (..), fromTypeName) -import Data.Morpheus.Core (Config (..), VALIDATION_MODE (WITHOUT_VARIABLES), validateRequest) -import Data.Morpheus.Internal.Ext - ( GQLResult, - ) -import Data.Morpheus.Internal.Utils - ( empty, - keyOf, - selectBy, - ) -import Data.Morpheus.Types.Internal.AST - ( ANY, - ExecutableDocument (..), - FieldDefinition (..), - FieldName, - OUT, - Operation (..), - Ref (..), - Schema (..), - Selection (..), - SelectionContent (..), - SelectionSet, - TRUE, - TypeContent (..), - TypeDefinition (..), - TypeKind (..), - TypeName, - TypeRef (..), - UnionTag (..), - VALID, - getOperationDataType, - getOperationName, - mkTypeRef, - msg, - toAny, - ) -import qualified Data.Text as T -import Relude hiding (empty, show) -import Prelude (show) - -clientConfig :: Config -clientConfig = - Config - { debug = False, - validationMode = WITHOUT_VARIABLES - } - -toLocalDefinitions :: (Text, ExecutableDocument) -> Schema VALID -> GQLResult [ClientDeclaration] -toLocalDefinitions (query, request) schema = do - validOperation <- validateRequest clientConfig schema request - flip runReaderT (schema, operationArguments $ operation request) $ runConverter $ genLocalDeclarations query validOperation - -genLocalDeclarations :: Text -> Operation VALID -> Converter [ClientDeclaration] -genLocalDeclarations query op@Operation {operationName, operationSelection, operationType} = do - (schema, varDefs) <- asks id - datatype <- getOperationDataType op schema - let argumentsType = toArgumentsType (fromTypeName $ getOperationName operationName <> "Args") varDefs - (rootType :| localTypes) <- - genLocalTypes - [] - (getOperationName operationName) - (toAny datatype) - operationSelection - pure - ( RequestTypeClass - RequestTypeDefinition - { requestArgs = maybe "()" (typename . clientTypeName) argumentsType, - requestName = typename (clientTypeName rootType), - requestType = operationType, - requestQuery = T.unpack query - } - : concatMap toClientDeclarations (rootType : (localTypes <> maybeToList argumentsType)) - ) - -------------------------------------------------------------------------- --- generates selection Object Types -genLocalTypes :: - [FieldName] -> - TypeName -> - TypeDefinition ANY VALID -> - SelectionSet VALID -> - Converter (NonEmpty ClientTypeDefinition) -genLocalTypes namespace tName dataType recordSelSet = do - let clientTypeName = CodeGenTypeName {namespace, typeParameters = [], typename = tName} - (con, subTypes) <- toConstructorDefinition (if null namespace then [coerce tName] else namespace) clientTypeName dataType recordSelSet - pure $ - ClientTypeDefinition - { clientTypeName, - clientCons = [con], - clientKind = KindObject Nothing - } - :| subTypes - -toConstructorDefinition :: - [FieldName] -> - CodeGenTypeName -> - TypeDefinition ANY VALID -> - SelectionSet VALID -> - Converter (CodeGenConstructor, [ClientTypeDefinition]) -toConstructorDefinition path name datatype selSet = do - (fields, subTypes) <- unzip <$> traverse genField (toList selSet) - pure (CodeGenConstructor {constructorName = name, constructorFields = map toCodeGenField fields}, concat subTypes) - where - genField :: Selection VALID -> Converter (FieldDefinition ANY VALID, [ClientTypeDefinition]) - genField sel = do - let fieldName = keyOf sel - let fieldPath = path <> [fieldName] - (fieldDataType, fieldType) <- getFieldType fieldPath datatype sel - subTypes <- subTypesBySelection fieldPath fieldDataType sel - pure - ( FieldDefinition - { fieldName, - fieldType, - fieldContent = Nothing, - fieldDescription = Nothing, - fieldDirectives = empty - }, - subTypes - ) - ------------------------------------------- -subTypesBySelection :: - [FieldName] -> - TypeDefinition ANY VALID -> - Selection VALID -> - Converter [ClientTypeDefinition] -subTypesBySelection _ _ Selection {selectionContent = SelectionField} = pure [] -subTypesBySelection path dType Selection {selectionContent = SelectionSet selectionSet} = - toList <$> genLocalTypes path (typeFrom [] dType) dType selectionSet -subTypesBySelection namespace dType Selection {selectionContent = UnionSelection interface unionSelections} = - do - let variants = UnionTag (typeName dType) interface : toList unionSelections - (clientCons, subTypes) <- unzip <$> traverse (getVariantType namespace) variants - pure - ( ClientTypeDefinition - { clientTypeName = CodeGenTypeName {namespace, typeParameters = [], typename = typeFrom [] dType}, - clientCons, - clientKind = KindUnion - } - : concat subTypes - ) - -getVariantType :: [FieldName] -> UnionTag -> Converter (CodeGenConstructor, [ClientTypeDefinition]) -getVariantType path (UnionTag selectedTyName selectionVariant) = do - conDatatype <- getType selectedTyName - toConstructorDefinition path (CodeGenTypeName path [] selectedTyName) conDatatype selectionVariant - -getFieldType :: - [FieldName] -> - TypeDefinition ANY VALID -> - Selection VALID -> - Converter (TypeDefinition ANY VALID, TypeRef) -getFieldType - path - TypeDefinition {typeContent, typeName} - Selection - { selectionName, - selectionPosition - } = toFieldDef typeContent >>= processFieldDefinition - where - toFieldDef :: TypeContent TRUE ANY VALID -> Converter (FieldDefinition OUT VALID) - toFieldDef _ - | selectionName == "__typename" = - pure - FieldDefinition - { fieldName = "__typename", - fieldDescription = Nothing, - fieldType = mkTypeRef "String", - fieldDirectives = empty, - fieldContent = Nothing - } - toFieldDef DataObject {objectFields} = selectBy selError selectionName objectFields - toFieldDef DataInterface {interfaceFields} = selectBy selError selectionName interfaceFields - toFieldDef dt = throwError (compileError $ "Type should be output Object \"" <> msg (show dt)) - selError = compileError $ "can't find field " <> msg selectionName <> " on type: " <> msg (show typeContent) - -- - processFieldDefinition - FieldDefinition - { fieldType = TypeRef {..}, - fieldDirectives - } = - checkDeprecated *> (trans <$> getType typeConName) - where - trans x = (x, TypeRef {typeConName = typeFrom path x, ..}) - ------------------------------------------------------------------ - checkDeprecated :: Converter () - checkDeprecated = deprecationWarning fieldDirectives (coerce typeName, Ref selectionName selectionPosition)