diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -67,11 +67,11 @@ | PowerOmniscience data GetHeroArgs = GetHeroArgs { - getHeroArgsCharacter: Character + character: Character } data Character = Character { - characterName: Person + name: Person } ``` @@ -83,7 +83,7 @@ fetchHero :: Args GetHero -> m (Either String GetHero) fetchHero = fetch jsonRes args where - args = GetHeroArgs {getHeroArgsCharacter = Person {characterName = "Zeus"}} + args = GetHeroArgs {character = Person {name = "Zeus"}} jsonRes :: ByteString -> m ByteString jsonRes = ``` diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,15 @@ # Changelog +## 0.13.0 - unreleased changes + +### breaking changes + +- from now you should provide for every custom graphql scalar definition coresponoding haskell type definition and `GQLScalar` implementation fot it. for details see [`examples-client`](https://github.com/morpheusgraphql/morpheus-graphql/tree/master/examples-client) + +- input fields and query arguments are imported without namespacing + +### new features + +- exposed: `ScalarValues`,`GQLScalar`, `ID` + ## 0.12.0 - 21.05.2020 diff --git a/morpheus-graphql-client.cabal b/morpheus-graphql-client.cabal --- a/morpheus-graphql-client.cabal +++ b/morpheus-graphql-client.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 8749fc28a63b46eed778a0eb7cfcb2e6f184c7e9c49a7f3a2847b7b735e2599e +-- hash: 7197b378712c75bda382590d65bb12695851254973a9d957be9bf41539618227 name: morpheus-graphql-client -version: 0.12.0 +version: 0.13.0 synopsis: Morpheus GraphQL Client description: Build GraphQL APIs with your favourite functional language! category: web, graphql, client @@ -31,9 +31,12 @@ exposed-modules: Data.Morpheus.Client other-modules: - Data.Morpheus.Client.Aeson Data.Morpheus.Client.Build + Data.Morpheus.Client.Declare.Aeson + Data.Morpheus.Client.Declare.Client + Data.Morpheus.Client.Declare.Type Data.Morpheus.Client.Fetch + Data.Morpheus.Client.Internal.Types Data.Morpheus.Client.Transform.Core Data.Morpheus.Client.Transform.Inputs Data.Morpheus.Client.Transform.Selection @@ -45,7 +48,7 @@ aeson >=1.4.4.0 && <=1.6 , base >=4.7 && <5 , bytestring >=0.10.4 && <0.11 - , morpheus-graphql-core >=0.12.0 + , morpheus-graphql-core >=0.13.0 , mtl >=2.0 && <=3.0 , template-haskell >=2.0 && <=3.0 , text >=1.2.3.0 && <1.3 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 @@ -8,6 +8,9 @@ defineByDocumentFile, defineByIntrospection, defineByIntrospectionFile, + ScalarValue (..), + GQLScalar (..), + ID (..), ) where @@ -28,8 +31,11 @@ parseFullGQLDocument, ) import Data.Morpheus.QuasiQuoter (gql) +import Data.Morpheus.Types.GQLScalar (GQLScalar (..)) +import Data.Morpheus.Types.ID (ID (..)) import Data.Morpheus.Types.Internal.AST ( GQLQuery, + ScalarValue (..), Schema, ) import Data.Morpheus.Types.Internal.Resolving diff --git a/src/Data/Morpheus/Client/Aeson.hs b/src/Data/Morpheus/Client/Aeson.hs deleted file mode 100644 --- a/src/Data/Morpheus/Client/Aeson.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE ConstrainedClassMethods #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -module Data.Morpheus.Client.Aeson - ( deriveFromJSON, - deriveToJSON, - takeValueType, - ) -where - -import Data.Aeson -import Data.Aeson.Types -import qualified Data.HashMap.Lazy as H - ( lookup, - ) --- --- MORPHEUS -import Data.Morpheus.Internal.TH - ( destructRecord, - instanceFunD, - instanceHeadT, - mkTypeName, - nameConE, - nameLitP, - nameStringL, - nameVarE, - nameVarP, - ) -import Data.Morpheus.Internal.Utils - ( nameSpaceType, - ) -import Data.Morpheus.Types.Internal.AST - ( ConsD (..), - FieldDefinition (..), - FieldName, - Message, - TypeD (..), - TypeName (..), - isEnum, - isFieldNullable, - msg, - toFieldName, - ) -import Data.Semigroup ((<>)) -import Data.Text - ( unpack, - ) -import Language.Haskell.TH - -failure :: Message -> Q a -failure = fail . show - --- FromJSON -deriveFromJSON :: TypeD -> Q Dec -deriveFromJSON TypeD {tCons = [], tName} = - failure $ "Type " <> msg tName <> " Should Have at least one Constructor" -deriveFromJSON TypeD {tName, tNamespace, tCons = [cons]} = - defineFromJSON - name - (aesonObject tNamespace) - cons - where - name = nameSpaceType tNamespace tName -deriveFromJSON typeD@TypeD {tName, tCons, tNamespace} - | isEnum tCons = defineFromJSON name (aesonFromJSONEnumBody tName) tCons - | otherwise = defineFromJSON name (aesonUnionObject tNamespace) typeD - where - name = nameSpaceType tNamespace tName - -aesonObject :: [FieldName] -> ConsD -> ExpQ -aesonObject tNamespace con@ConsD {cName} = - appE - [|withObject name|] - (lamE [nameVarP "o"] (aesonObjectBody tNamespace con)) - where - name = nameSpaceType tNamespace cName - -aesonObjectBody :: [FieldName] -> ConsD -> ExpQ -aesonObjectBody namespace ConsD {cName, cFields} = handleFields cFields - where - consName = nameConE (nameSpaceType namespace cName) - ---------------------------------------------------------- - handleFields [] = - failure $ - "Type \"" - <> msg cName - <> "\" is Empty Object" - handleFields fields = startExp fields - where - ---------------------------------------------------------- - - defField field@FieldDefinition {fieldName} - | isFieldNullable field = [|o .:? fieldName|] - | otherwise = [|o .: fieldName|] - -------------------------------------------------------- - startExp fNames = - uInfixE - consName - (varE '(<$>)) - (applyFields fNames) - where - applyFields [] = fail "No Empty fields" - applyFields [x] = defField x - applyFields (x : xs) = - uInfixE (defField x) (varE '(<*>)) (applyFields xs) - -aesonUnionObject :: [FieldName] -> TypeD -> ExpQ -aesonUnionObject namespace TypeD {tCons} = - appE - (varE 'takeValueType) - (lamCaseE (map buildMatch tCons <> [elseCaseEXP])) - where - buildMatch cons@ConsD {cName} = match objectPattern body [] - where - objectPattern = tupP [nameLitP cName, nameVarP "o"] - body = normalB $ aesonObjectBody namespace cons - -takeValueType :: ((String, Object) -> Parser a) -> Value -> Parser a -takeValueType f (Object hMap) = case H.lookup "__typename" hMap of - Nothing -> fail "key \"__typename\" not found on object" - Just (String x) -> pure (unpack x, hMap) >>= f - Just val -> - fail $ "key \"__typename\" should be string but found: " <> show val -takeValueType _ _ = fail "expected Object" - -defineFromJSON :: TypeName -> (t -> ExpQ) -> t -> DecQ -defineFromJSON tName parseJ cFields = instanceD (cxt []) iHead [method] - where - iHead = instanceHeadT ''FromJSON tName [] - ----------------------------------------- - method = instanceFunD 'parseJSON [] (parseJ cFields) - -aesonFromJSONEnumBody :: TypeName -> [ConsD] -> ExpQ -aesonFromJSONEnumBody tName cons = lamCaseE handlers - where - handlers = map buildMatch cons <> [elseCaseEXP] - where - buildMatch ConsD {cName} = match enumPat body [] - where - enumPat = nameLitP cName - body = - normalB $ - appE - (varE 'pure) - (nameConE $ nameSpaceType [toFieldName tName] cName) - -elseCaseEXP :: MatchQ -elseCaseEXP = match (nameVarP varName) body [] - where - varName = "invalidValue" - body = - normalB $ - appE - (nameVarE "fail") - ( uInfixE - (appE (varE 'show) (nameVarE varName)) - (varE '(<>)) - (stringE " is Not Valid Union Constructor") - ) - -aesonToJSONEnumBody :: TypeName -> [ConsD] -> ExpQ -aesonToJSONEnumBody tName cons = lamCaseE handlers - where - handlers = map buildMatch cons - where - buildMatch ConsD {cName} = match enumPat body [] - where - enumPat = conP (mkTypeName $ nameSpaceType [toFieldName tName] cName) [] - body = normalB $ litE (nameStringL cName) - --- ToJSON -deriveToJSON :: TypeD -> Q [Dec] -deriveToJSON TypeD {tCons = []} = - fail "Type Should Have at least one Constructor" -deriveToJSON TypeD {tName, tCons = [ConsD {cFields}]} = - pure <$> instanceD (cxt []) appHead methods - where - appHead = instanceHeadT ''ToJSON tName [] - ------------------------------------------------------------------ - -- defines: toJSON (User field1 field2 ...)= object ["name" .= name, "age" .= age, ...] - methods = [funD 'toJSON [clause argsE (normalB body) []]] - where - argsE = [destructRecord tName varNames] - body = appE (varE 'object) (listE $ map decodeVar varNames) - decodeVar name = [|name .= $(varName)|] where varName = nameVarE name - varNames = map fieldName cFields -deriveToJSON TypeD {tName, tCons} - | isEnum tCons = - let methods = [funD 'toJSON clauses] - clauses = [clause [] (normalB $ aesonToJSONEnumBody tName tCons) []] - in pure <$> instanceD (cxt []) (instanceHeadT ''ToJSON tName []) methods - | otherwise = - fail "Input Unions are not yet supported" diff --git a/src/Data/Morpheus/Client/Build.hs b/src/Data/Morpheus/Client/Build.hs --- a/src/Data/Morpheus/Client/Build.hs +++ b/src/Data/Morpheus/Client/Build.hs @@ -1,8 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} module Data.Morpheus.Client.Build ( defineQuery, @@ -12,16 +10,14 @@ -- -- MORPHEUS -import Data.Morpheus.Client.Aeson - ( deriveFromJSON, - deriveToJSON, +import Data.Morpheus.Client.Declare.Client + ( declareClient, ) -import Data.Morpheus.Client.Fetch - ( deriveFetch, +import Data.Morpheus.Client.Internal.Types + ( ClientDefinition (..), ) import Data.Morpheus.Client.Transform.Selection - ( ClientDefinition (..), - toClientDefinition, + ( toClientDefinition, ) import Data.Morpheus.Core ( validateRequest, @@ -30,29 +26,16 @@ ( gqlWarnings, renderGQLErrors, ) -import Data.Morpheus.Internal.TH - ( Scope (..), - declareType, - nameConType, - nameConType, - ) -import qualified Data.Morpheus.Types.Internal.AST as O - ( Operation (..), - ) import Data.Morpheus.Types.Internal.AST - ( DataTypeKind (..), - GQLQuery (..), + ( GQLQuery (..), + Operation (..), Schema, - TypeD (..), - TypeD (..), VALIDATION_MODE (..), - isOutputObject, ) import Data.Morpheus.Types.Internal.Resolving ( Eventless, Result (..), ) -import Data.Semigroup ((<>)) import Language.Haskell.TH defineQuery :: IO (Eventless Schema) -> (GQLQuery, String) -> Q [Dec] @@ -60,59 +43,19 @@ schema <- runIO ioSchema case schema >>= (`validateWith` query) of Failure errors -> fail (renderGQLErrors errors) - Success {result, warnings} -> gqlWarnings warnings >> defineQueryD src result - -defineQueryD :: String -> ClientDefinition -> Q [Dec] -defineQueryD _ ClientDefinition {clientTypes = []} = return [] -defineQueryD src ClientDefinition {clientArguments, clientTypes = rootType : subTypes} = - do - rootDeclaration <- - defineOperationType - (queryArgumentType clientArguments) - src - rootType - typeDeclarations <- concat <$> traverse declareT subTypes - pure (rootDeclaration <> typeDeclarations) - where - declareT clientType@TypeD {tKind} - | isOutputObject tKind || tKind == KindUnion = - withToJSON - declareOutputType - clientType - | tKind == KindEnum = withToJSON declareInputType clientType - | otherwise = declareInputType clientType - -declareOutputType :: TypeD -> Q [Dec] -declareOutputType typeD = pure [declareType CLIENT False Nothing [''Show] typeD] - -declareInputType :: TypeD -> Q [Dec] -declareInputType typeD = do - toJSONDec <- deriveToJSON typeD - pure $ declareType CLIENT True Nothing [''Show] typeD : toJSONDec - -withToJSON :: (TypeD -> Q [Dec]) -> TypeD -> Q [Dec] -withToJSON f datatype = do - toJson <- deriveFromJSON datatype - dec <- f datatype - pure (toJson : dec) - -queryArgumentType :: Maybe TypeD -> (Type, Q [Dec]) -queryArgumentType Nothing = (nameConType "()", pure []) -queryArgumentType (Just rootType@TypeD {tName}) = - (nameConType tName, declareInputType rootType) - -defineOperationType :: (Type, Q [Dec]) -> String -> TypeD -> Q [Dec] -defineOperationType (argType, argumentTypes) query clientType = - do - rootType <- withToJSON declareOutputType clientType - typeClassFetch <- deriveFetch argType (tName clientType) query - argsT <- argumentTypes - pure $ rootType <> typeClassFetch <> argsT + Success + { result, + warnings + } -> gqlWarnings warnings >> declareClient src result validateWith :: Schema -> GQLQuery -> Eventless ClientDefinition -validateWith schema rawRequest@GQLQuery {operation} = do - validOperation <- validateRequest schema WITHOUT_VARIABLES rawRequest - toClientDefinition - schema - (O.operationArguments operation) - validOperation +validateWith + schema + rawRequest@GQLQuery + { operation = Operation {operationArguments} + } = do + validOperation <- validateRequest schema WITHOUT_VARIABLES rawRequest + toClientDefinition + schema + operationArguments + validOperation diff --git a/src/Data/Morpheus/Client/Declare/Aeson.hs b/src/Data/Morpheus/Client/Declare/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Declare/Aeson.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Morpheus.Client.Declare.Aeson + ( aesonDeclarations, + ) +where + +-- +-- MORPHEUS +import Data.Aeson +import Data.Aeson.Types +import qualified Data.HashMap.Lazy as H + ( lookup, + ) +import Data.Morpheus.Client.Internal.Types + ( ClientTypeDefinition (..), + TypeNameTH (..), + ) +import Data.Morpheus.Internal.TH + ( destructRecord, + instanceFunD, + instanceHeadT, + mkTypeName, + nameConE, + nameLitP, + nameStringL, + nameVarE, + nameVarP, + ) +import Data.Morpheus.Internal.Utils + ( nameSpaceType, + ) +import Data.Morpheus.Types.GQLScalar + ( scalarFromJSON, + scalarToJSON, + ) +import Data.Morpheus.Types.Internal.AST + ( ConsD (..), + FieldDefinition (..), + FieldName, + Message, + TypeKind (..), + TypeName (..), + isEnum, + isFieldNullable, + isOutputObject, + msg, + toFieldName, + ) +import Data.Semigroup ((<>)) +import Data.Text + ( unpack, + ) +import Language.Haskell.TH + +aesonDeclarations :: TypeKind -> [ClientTypeDefinition -> Q Dec] +aesonDeclarations KindEnum = [deriveFromJSON, deriveToJSON] +aesonDeclarations KindScalar = deriveScalarJSON +aesonDeclarations kind + | isOutputObject kind || kind == KindUnion = [deriveFromJSON] + | otherwise = [deriveToJSON] + +failure :: Message -> Q a +failure = fail . show + +deriveScalarJSON :: [ClientTypeDefinition -> Q Dec] +deriveScalarJSON = [deriveScalarFromJSON, deriveScalarToJSON] + +deriveScalarFromJSON :: ClientTypeDefinition -> Q Dec +deriveScalarFromJSON ClientTypeDefinition {clientTypeName} = + defineFromJSON + clientTypeName + (const $ varE 'scalarFromJSON) + clientTypeName + +deriveScalarToJSON :: ClientTypeDefinition -> Q Dec +deriveScalarToJSON + ClientTypeDefinition + { clientTypeName = TypeNameTH {typename} + } = + let methods = [funD 'toJSON clauses] + clauses = [clause [] (normalB $ varE 'scalarToJSON) []] + in instanceD (cxt []) (instanceHeadT ''ToJSON typename []) methods + +-- FromJSON +deriveFromJSON :: ClientTypeDefinition -> Q Dec +deriveFromJSON ClientTypeDefinition {clientCons = [], clientTypeName} = + failure $ + "Type " + <> msg (typename clientTypeName) + <> " Should Have at least one Constructor" +deriveFromJSON + ClientTypeDefinition + { clientTypeName = clientTypeName@TypeNameTH {namespace}, + clientCons = [cons] + } = + defineFromJSON + clientTypeName + (aesonObject namespace) + cons +deriveFromJSON typeD@ClientTypeDefinition {clientTypeName, clientCons} + | isEnum clientCons = + defineFromJSON + clientTypeName + (aesonFromJSONEnumBody clientTypeName) + clientCons + | otherwise = + defineFromJSON + clientTypeName + aesonUnionObject + typeD + +aesonObject :: [FieldName] -> ConsD cat -> ExpQ +aesonObject tNamespace con@ConsD {cName} = + appE + [|withObject name|] + (lamE [nameVarP "o"] (aesonObjectBody tNamespace con)) + where + name = nameSpaceType tNamespace cName + +aesonObjectBody :: [FieldName] -> ConsD cat -> ExpQ +aesonObjectBody namespace ConsD {cName, cFields} = handleFields cFields + where + consName = nameConE (nameSpaceType namespace cName) + ---------------------------------------------------------- + handleFields [] = + failure $ + "Type \"" + <> msg cName + <> "\" is Empty Object" + handleFields fields = startExp fields + where + ---------------------------------------------------------- + + defField field@FieldDefinition {fieldName} + | isFieldNullable field = [|o .:? fieldName|] + | otherwise = [|o .: fieldName|] + -------------------------------------------------------- + startExp fNames = + uInfixE + consName + (varE '(<$>)) + (applyFields fNames) + where + applyFields [] = fail "No Empty fields" + applyFields [x] = defField x + applyFields (x : xs) = + uInfixE (defField x) (varE '(<*>)) (applyFields xs) + +aesonUnionObject :: ClientTypeDefinition -> ExpQ +aesonUnionObject + ClientTypeDefinition + { clientCons, + clientTypeName = TypeNameTH {namespace} + } = + appE + (varE 'takeValueType) + (lamCaseE (map buildMatch clientCons <> [elseCaseEXP])) + where + buildMatch cons@ConsD {cName} = match objectPattern body [] + where + objectPattern = tupP [nameLitP cName, nameVarP "o"] + body = normalB $ aesonObjectBody namespace cons + +takeValueType :: ((String, Object) -> Parser a) -> Value -> Parser a +takeValueType f (Object hMap) = case H.lookup "__typename" hMap of + Nothing -> fail "key \"__typename\" not found on object" + Just (String x) -> pure (unpack x, hMap) >>= f + Just val -> + fail $ "key \"__typename\" should be string but found: " <> show val +takeValueType _ _ = fail "expected Object" + +namespaced :: TypeNameTH -> TypeName +namespaced TypeNameTH {namespace, typename} = + nameSpaceType namespace typename + +defineFromJSON :: TypeNameTH -> (t -> ExpQ) -> t -> Q Dec +defineFromJSON name parseJ cFields = instanceD (cxt []) iHead [method] + where + iHead = instanceHeadT ''FromJSON (namespaced name) [] + ----------------------------------------- + method = instanceFunD 'parseJSON [] (parseJ cFields) + +aesonFromJSONEnumBody :: TypeNameTH -> [ConsD cat] -> ExpQ +aesonFromJSONEnumBody TypeNameTH {typename} cons = lamCaseE handlers + where + handlers = map buildMatch cons <> [elseCaseEXP] + where + buildMatch ConsD {cName} = match enumPat body [] + where + enumPat = nameLitP cName + body = + normalB $ + appE + (varE 'pure) + (nameConE $ nameSpaceType [toFieldName typename] cName) + +elseCaseEXP :: MatchQ +elseCaseEXP = match (nameVarP varName) body [] + where + varName = "invalidValue" + body = + normalB $ + appE + (nameVarE "fail") + ( uInfixE + (appE (varE 'show) (nameVarE varName)) + (varE '(<>)) + (stringE " is Not Valid Union Constructor") + ) + +aesonToJSONEnumBody :: TypeNameTH -> [ConsD cat] -> ExpQ +aesonToJSONEnumBody TypeNameTH {typename} cons = lamCaseE handlers + where + handlers = map buildMatch cons + where + buildMatch ConsD {cName} = match enumPat body [] + where + enumPat = conP (mkTypeName $ nameSpaceType [toFieldName typename] cName) [] + body = normalB $ litE (nameStringL cName) + +-- ToJSON +deriveToJSON :: ClientTypeDefinition -> Q Dec +deriveToJSON + ClientTypeDefinition + { clientCons = [] + } = + fail "Type Should Have at least one Constructor" +deriveToJSON + ClientTypeDefinition + { clientTypeName = TypeNameTH {typename}, + clientCons = [ConsD {cFields}] + } = + instanceD (cxt []) appHead methods + where + appHead = instanceHeadT ''ToJSON typename [] + ------------------------------------------------------------------ + -- defines: toJSON (User field1 field2 ...)= object ["name" .= name, "age" .= age, ...] + methods = [funD 'toJSON [clause argsE (normalB body) []]] + where + argsE = [destructRecord typename varNames] + body = appE (varE 'object) (listE $ map decodeVar varNames) + decodeVar name = [|name .= $(varName)|] where varName = nameVarE name + varNames = map fieldName cFields +deriveToJSON + ClientTypeDefinition + { clientTypeName = clientTypeName@TypeNameTH {typename}, + clientCons + } + | isEnum clientCons = + let methods = [funD 'toJSON clauses] + clauses = + [ clause + [] + (normalB $ aesonToJSONEnumBody clientTypeName clientCons) + [] + ] + in instanceD (cxt []) (instanceHeadT ''ToJSON typename []) methods + | otherwise = + fail "Input Unions are not yet supported" diff --git a/src/Data/Morpheus/Client/Declare/Client.hs b/src/Data/Morpheus/Client/Declare/Client.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Declare/Client.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Morpheus.Client.Declare.Client + ( declareClient, + ) +where + +import Data.Morpheus.Client.Declare.Aeson + ( aesonDeclarations, + ) +import Data.Morpheus.Client.Declare.Type (typeDeclarations) +import Data.Morpheus.Client.Fetch + ( deriveFetch, + ) +import Data.Morpheus.Client.Internal.Types + ( ClientDefinition (..), + ClientTypeDefinition (..), + TypeNameTH (..), + ) +import Data.Morpheus.Internal.TH + ( nameConType, + ) +import Data.Semigroup ((<>)) +import Language.Haskell.TH + +declareClient :: String -> ClientDefinition -> Q [Dec] +declareClient _ ClientDefinition {clientTypes = []} = return [] +declareClient src ClientDefinition {clientArguments, clientTypes = rootType : subTypes} = + do + root <- + defineOperationType + (queryArgumentType clientArguments) + src + rootType + types <- concat <$> traverse declareType subTypes + pure (root <> types) + +declareType :: ClientTypeDefinition -> Q [Dec] +declareType clientType@ClientTypeDefinition {clientKind} = + apply clientType (typeDeclarations clientKind <> aesonDeclarations clientKind) + +apply :: Applicative f => a -> [a -> f b] -> f [b] +apply a = traverse (\f -> f a) + +queryArgumentType :: Maybe ClientTypeDefinition -> (Type, Q [Dec]) +queryArgumentType Nothing = (nameConType "()", pure []) +queryArgumentType (Just client@ClientTypeDefinition {clientTypeName}) = + (nameConType (typename clientTypeName), declareType client) + +defineOperationType :: (Type, Q [Dec]) -> String -> ClientTypeDefinition -> Q [Dec] +defineOperationType + (argType, argumentTypes) + query + clientType@ClientTypeDefinition + { clientTypeName = TypeNameTH {typename} + } = + do + rootType <- declareType clientType + typeClassFetch <- deriveFetch argType typename query + argsT <- argumentTypes + pure $ rootType <> typeClassFetch <> argsT diff --git a/src/Data/Morpheus/Client/Declare/Type.hs b/src/Data/Morpheus/Client/Declare/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Declare/Type.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Morpheus.Client.Declare.Type + ( typeDeclarations, + ) +where + +-- +-- MORPHEUS +import Data.Morpheus.Client.Internal.Types + ( ClientTypeDefinition (..), + TypeNameTH (..), + ) +import Data.Morpheus.Internal.TH + ( declareTypeRef, + isEnum, + mkFieldName, + mkTypeName, + nameSpaceType, + ) +import Data.Morpheus.Types.Internal.AST + ( ANY, + ConsD (..), + FieldDefinition (..), + FieldName, + TypeKind (..), + TypeName, + ) +import Data.Semigroup ((<>)) +import GHC.Generics (Generic) +import Language.Haskell.TH + +typeDeclarations :: TypeKind -> [ClientTypeDefinition -> Q Dec] +typeDeclarations KindScalar = [] +typeDeclarations _ = [pure . declareType] + +declareType :: ClientTypeDefinition -> Dec +declareType + ClientTypeDefinition + { clientTypeName = thName@TypeNameTH {namespace, typename}, + clientCons + } = + DataD + [] + (mkConName namespace typename) + [] + Nothing + (declareCons thName clientCons) + (map derive [''Generic, ''Show]) + where + derive className = DerivClause Nothing [ConT className] + +declareCons :: TypeNameTH -> [ConsD ANY] -> [Con] +declareCons TypeNameTH {namespace, typename} clientCons + | isEnum clientCons = map consE clientCons + | otherwise = map consR clientCons + where + consE ConsD {cName} = NormalC (mkConName namespace (typename <> cName)) [] + consR ConsD {cName, cFields} = + RecC + (mkConName namespace cName) + (map declareField cFields) + +declareField :: FieldDefinition ANY -> (Name, Bang, Type) +declareField FieldDefinition {fieldName, fieldType} = + ( mkFieldName fieldName, + Bang NoSourceUnpackedness NoSourceStrictness, + declareTypeRef False fieldType + ) + +mkConName :: [FieldName] -> TypeName -> Name +mkConName namespace = mkTypeName . nameSpaceType namespace diff --git a/src/Data/Morpheus/Client/Internal/Types.hs b/src/Data/Morpheus/Client/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Internal/Types.hs @@ -0,0 +1,26 @@ +module Data.Morpheus.Client.Internal.Types + ( ClientTypeDefinition (..), + TypeNameTH (..), + ClientDefinition (..), + ) +where + +import Data.Morpheus.Types.Internal.AST + ( ANY, + ConsD (..), + TypeKind, + TypeNameTH (..), + ) + +data ClientTypeDefinition = ClientTypeDefinition + { clientTypeName :: TypeNameTH, + clientCons :: [ConsD ANY], + clientKind :: TypeKind + } + deriving (Show) + +data ClientDefinition = ClientDefinition + { clientArguments :: Maybe ClientTypeDefinition, + clientTypes :: [ClientTypeDefinition] + } + deriving (Show) diff --git a/src/Data/Morpheus/Client/Transform/Core.hs b/src/Data/Morpheus/Client/Transform/Core.hs --- a/src/Data/Morpheus/Client/Transform/Core.hs +++ b/src/Data/Morpheus/Client/Transform/Core.hs @@ -14,6 +14,7 @@ leafType, typeFrom, deprecationWarning, + customScalarTypes, ) where @@ -24,6 +25,9 @@ import Control.Monad.Trans.Reader ( ReaderT (..), ) +import Data.Morpheus.Client.Internal.Types + ( ClientTypeDefinition (..), + ) import Data.Morpheus.Error ( deprecatedField, globalErrorMessage, @@ -35,23 +39,24 @@ ) import Data.Morpheus.Types.Internal.AST ( ANY, + Directives, FieldName, GQLErrors, Message, - Meta, RAW, Ref (..), Schema (..), TRUE, TypeContent (..), - TypeD, TypeDefinition (..), TypeName, + VALID, VariableDefinitions, + hsTypeName, + isSystemTypeName, lookupDeprecated, lookupDeprecatedReason, msg, - typeFromScalar, ) import Data.Morpheus.Types.Internal.Resolving ( Eventless, @@ -80,24 +85,29 @@ getType :: TypeName -> Converter (TypeDefinition ANY) getType typename = asks fst >>= selectBy (compileError $ " cant find Type" <> msg typename) typename -leafType :: TypeDefinition a -> Converter ([TypeD], [TypeName]) +customScalarTypes :: TypeName -> [TypeName] +customScalarTypes typeName + | not (isSystemTypeName typeName) = [typeName] + | otherwise = [] + +leafType :: TypeDefinition a -> Converter ([ClientTypeDefinition], [TypeName]) leafType TypeDefinition {typeName, typeContent} = fromKind typeContent where - fromKind :: TypeContent TRUE a -> Converter ([TypeD], [TypeName]) + fromKind :: TypeContent TRUE a -> Converter ([ClientTypeDefinition], [TypeName]) fromKind DataEnum {} = pure ([], [typeName]) - fromKind DataScalar {} = pure ([], []) + fromKind DataScalar {} = pure ([], customScalarTypes typeName) fromKind _ = failure $ compileError "Invalid schema Expected scalar" typeFrom :: [FieldName] -> TypeDefinition a -> TypeName typeFrom path TypeDefinition {typeName, typeContent} = __typeFrom typeContent where - __typeFrom DataScalar {} = typeFromScalar typeName + __typeFrom DataScalar {} = hsTypeName typeName __typeFrom DataObject {} = nameSpaceType path typeName __typeFrom DataUnion {} = nameSpaceType path typeName __typeFrom _ = typeName -deprecationWarning :: Maybe Meta -> (FieldName, Ref) -> Converter () -deprecationWarning meta (typename, ref) = case meta >>= lookupDeprecated of +deprecationWarning :: Directives VALID -> (FieldName, Ref) -> Converter () +deprecationWarning dirs (typename, ref) = case lookupDeprecated dirs of Just deprecation -> Converter $ lift $ Success {result = (), warnings, events = []} where warnings = diff --git a/src/Data/Morpheus/Client/Transform/Inputs.hs b/src/Data/Morpheus/Client/Transform/Inputs.hs --- a/src/Data/Morpheus/Client/Transform/Inputs.hs +++ b/src/Data/Morpheus/Client/Transform/Inputs.hs @@ -2,6 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} @@ -14,23 +15,31 @@ -- -- MORPHEUS import Control.Monad.Reader (asks) -import Data.Morpheus.Client.Transform.Core (Converter (..), getType, typeFrom) +import Data.Morpheus.Client.Internal.Types + ( ClientTypeDefinition (..), + TypeNameTH (..), + ) +import Data.Morpheus.Client.Transform.Core + ( Converter (..), + customScalarTypes, + getType, + typeFrom, + ) import Data.Morpheus.Internal.Utils ( elems, + empty, ) import Data.Morpheus.Types.Internal.AST ( ANY, - ArgumentsDefinition (..), ConsD (..), - DataTypeKind (..), FieldDefinition (..), IN, Operation (..), RAW, TRUE, TypeContent (..), - TypeD (..), TypeDefinition (..), + TypeKind (..), TypeName, TypeRef (..), VALID, @@ -39,47 +48,59 @@ getOperationName, mkConsEnum, removeDuplicates, + toAny, ) import Data.Morpheus.Types.Internal.Resolving ( resolveUpdates, ) import Data.Semigroup ((<>)) -renderArguments :: VariableDefinitions RAW -> TypeName -> Maybe TypeD -renderArguments variables argsName +renderArguments :: + VariableDefinitions RAW -> + TypeName -> + Maybe ClientTypeDefinition +renderArguments variables cName | null variables = Nothing | otherwise = Just rootArgumentsType where - rootArgumentsType :: TypeD + rootArgumentsType :: ClientTypeDefinition rootArgumentsType = - TypeD - { tName = argsName, - tNamespace = [], - tCons = [ConsD {cName = argsName, cFields = map fieldD (elems variables)}], - tMeta = Nothing, - tKind = KindInputObject + ClientTypeDefinition + { clientTypeName = TypeNameTH [] cName, + clientKind = KindInputObject, + clientCons = + [ ConsD + { cName, + cFields = map fieldD (elems variables) + } + ] } where fieldD :: Variable RAW -> FieldDefinition ANY fieldD Variable {variableName, variableType} = FieldDefinition { fieldName = variableName, - fieldArgs = NoArguments, + fieldContent = Nothing, fieldType = variableType, - fieldMeta = Nothing + fieldDescription = Nothing, + fieldDirectives = empty } -renderOperationArguments :: Operation VALID -> Converter (Maybe TypeD) +renderOperationArguments :: + Operation VALID -> + Converter (Maybe ClientTypeDefinition) renderOperationArguments Operation {operationName} = do variables <- asks snd pure $ renderArguments variables (getOperationName operationName <> "Args") -- INPUTS -renderNonOutputTypes :: [TypeName] -> Converter [TypeD] -renderNonOutputTypes enums = do +renderNonOutputTypes :: + [TypeName] -> + Converter [ClientTypeDefinition] +renderNonOutputTypes leafTypes = do variables <- elems <$> asks snd inputTypeRequests <- resolveUpdates [] $ map (exploreInputTypeNames . typeConName . variableType) variables - concat <$> traverse buildInputType (removeDuplicates $ inputTypeRequests <> enums) + concat <$> traverse buildInputType (removeDuplicates $ inputTypeRequests <> leafTypes) exploreInputTypeNames :: TypeName -> [TypeName] -> Converter [TypeName] exploreInputTypeNames name collected @@ -97,23 +118,26 @@ toInputTypeD FieldDefinition {fieldType = TypeRef {typeConName}} = exploreInputTypeNames typeConName scanType (DataEnum _) = pure (collected <> [typeName]) + scanType (DataScalar _) = pure (collected <> customScalarTypes typeName) scanType _ = pure collected -buildInputType :: TypeName -> Converter [TypeD] +buildInputType :: + TypeName -> + Converter [ClientTypeDefinition] buildInputType name = getType name >>= generateTypes where generateTypes TypeDefinition {typeName, typeContent} = subTypes typeContent where - subTypes :: TypeContent TRUE ANY -> Converter [TypeD] + subTypes :: TypeContent TRUE ANY -> Converter [ClientTypeDefinition] subTypes (DataInputObject inputFields) = do - fields <- traverse toFieldD (elems inputFields) + fields <- traverse toClientFieldDefinition (elems inputFields) pure [ mkInputType typeName KindInputObject [ ConsD { cName = typeName, - cFields = fields + cFields = fmap toAny fields } ] ] @@ -124,19 +148,24 @@ KindEnum (map mkConsEnum enumTags) ] + subTypes DataScalar {} = + pure + [ mkInputType + typeName + KindScalar + [] + ] subTypes _ = pure [] -mkInputType :: TypeName -> DataTypeKind -> [ConsD] -> TypeD -mkInputType tName tKind tCons = - TypeD - { tName, - tNamespace = [], - tCons, - tKind, - tMeta = Nothing +mkInputType :: TypeName -> TypeKind -> [ConsD ANY] -> ClientTypeDefinition +mkInputType typename clientKind clientCons = + ClientTypeDefinition + { clientTypeName = TypeNameTH [] typename, + clientKind, + clientCons } -toFieldD :: FieldDefinition cat -> Converter (FieldDefinition ANY) -toFieldD field@FieldDefinition {fieldType} = do +toClientFieldDefinition :: FieldDefinition IN -> Converter (FieldDefinition IN) +toClientFieldDefinition FieldDefinition {fieldType, ..} = do typeConName <- typeFrom [] <$> getType (typeConName fieldType) - pure $ field {fieldType = fieldType {typeConName}} + pure FieldDefinition {fieldType = fieldType {typeConName}, ..} diff --git a/src/Data/Morpheus/Client/Transform/Selection.hs b/src/Data/Morpheus/Client/Transform/Selection.hs --- a/src/Data/Morpheus/Client/Transform/Selection.hs +++ b/src/Data/Morpheus/Client/Transform/Selection.hs @@ -15,19 +15,23 @@ -- -- MORPHEUS import Control.Monad.Reader (asks, runReaderT) +import Data.Morpheus.Client.Internal.Types + ( ClientDefinition (..), + ClientTypeDefinition (..), + TypeNameTH (..), + ) import Data.Morpheus.Client.Transform.Core (Converter (..), compileError, deprecationWarning, getType, leafType, typeFrom) import Data.Morpheus.Client.Transform.Inputs (renderNonOutputTypes, renderOperationArguments) import Data.Morpheus.Internal.Utils ( Failure (..), elems, + empty, keyOf, selectBy, ) import Data.Morpheus.Types.Internal.AST ( ANY, - ArgumentsDefinition (..), ConsD (..), - DataTypeKind (..), FieldDefinition (..), FieldName, Operation (..), @@ -38,8 +42,8 @@ SelectionContent (..), SelectionSet, TypeContent (..), - TypeD (..), TypeDefinition (..), + TypeKind (..), TypeName, TypeRef (..), UnionTag (..), @@ -56,12 +60,6 @@ ) import Data.Semigroup ((<>)) -data ClientDefinition = ClientDefinition - { clientArguments :: Maybe TypeD, - clientTypes :: [TypeD] - } - deriving (Show) - toClientDefinition :: Schema -> VariableDefinitions RAW -> @@ -75,7 +73,13 @@ nonOutputTypes <- renderNonOutputTypes enums pure ClientDefinition {clientArguments, clientTypes = outputTypes <> nonOutputTypes} -renderOperationType :: Operation VALID -> Converter (Maybe TypeD, [TypeD], [TypeName]) +renderOperationType :: + Operation VALID -> + Converter + ( Maybe ClientTypeDefinition, + [ClientTypeDefinition], + [TypeName] + ) renderOperationType op@Operation {operationName, operationSelection} = do datatype <- asks fst >>= getOperationDataType op arguments <- renderOperationArguments op @@ -94,16 +98,14 @@ TypeName -> TypeDefinition ANY -> SelectionSet VALID -> - Converter ([TypeD], [TypeName]) + Converter ([ClientTypeDefinition], [TypeName]) genRecordType path tName dataType recordSelSet = do (con, subTypes, requests) <- genConsD path tName dataType recordSelSet pure - ( TypeD - { tName, - tNamespace = path, - tCons = [con], - tKind = KindObject Nothing, - tMeta = Nothing + ( ClientTypeDefinition + { clientTypeName = TypeNameTH path tName, + clientCons = [con], + clientKind = KindObject Nothing } : subTypes, requests @@ -114,14 +116,18 @@ TypeName -> TypeDefinition ANY -> SelectionSet VALID -> - Converter (ConsD, [TypeD], [TypeName]) + Converter + ( ConsD ANY, + [ClientTypeDefinition], + [TypeName] + ) genConsD path cName datatype selSet = do (cFields, subTypes, requests) <- unzip3 <$> traverse genField (elems selSet) pure (ConsD {cName, cFields}, concat subTypes, concat requests) where genField :: Selection VALID -> - Converter (FieldDefinition ANY, [TypeD], [TypeName]) + Converter (FieldDefinition ANY, [ClientTypeDefinition], [TypeName]) genField sel = do (fieldDataType, fieldType) <- @@ -134,8 +140,9 @@ ( FieldDefinition { fieldName, fieldType, - fieldArgs = NoArguments, - fieldMeta = Nothing + fieldContent = Nothing, + fieldDescription = Nothing, + fieldDirectives = empty }, subTypes, requests @@ -150,22 +157,23 @@ [FieldName] -> TypeDefinition ANY -> Selection VALID -> - Converter ([TypeD], [TypeName]) + Converter + ( [ClientTypeDefinition], + [TypeName] + ) subTypesBySelection _ dType Selection {selectionContent = SelectionField} = leafType dType subTypesBySelection path dType Selection {selectionContent = SelectionSet selectionSet} = genRecordType path (typeFrom [] dType) dType selectionSet subTypesBySelection path dType Selection {selectionContent = UnionSelection unionSelections} = do - (tCons, subTypes, requests) <- + (clientCons, subTypes, requests) <- unzip3 <$> traverse getUnionType (elems unionSelections) pure - ( TypeD - { tNamespace = path, - tName = typeFrom [] dType, - tCons, - tKind = KindUnion, - tMeta = Nothing + ( ClientTypeDefinition + { clientTypeName = TypeNameTH path (typeFrom [] dType), + clientCons, + clientKind = KindUnion } : concat subTypes, concat requests @@ -190,16 +198,20 @@ selectBy selError selectionName objectFields >>= processDeprecation where selError = compileError $ "cant find field " <> msg (show objectFields) - processDeprecation FieldDefinition {fieldType = alias@TypeRef {typeConName}, fieldMeta} = - checkDeprecated >> (trans <$> getType typeConName) - where - trans x = - (x, alias {typeConName = typeFrom path x, typeArgs = Nothing}) - ------------------------------------------------------------------ - checkDeprecated :: Converter () - checkDeprecated = - deprecationWarning - fieldMeta - (toFieldName typeName, Ref {refName = selectionName, refPosition = selectionPosition}) + processDeprecation + FieldDefinition + { fieldType = alias@TypeRef {typeConName}, + fieldDirectives + } = + checkDeprecated >> (trans <$> getType typeConName) + where + trans x = + (x, alias {typeConName = typeFrom path x, typeArgs = Nothing}) + ------------------------------------------------------------------ + checkDeprecated :: Converter () + checkDeprecated = + deprecationWarning + fieldDirectives + (toFieldName typeName, Ref {refName = selectionName, refPosition = selectionPosition}) getFieldType _ dt _ = failure (compileError $ "Type should be output Object \"" <> msg (show dt))