morpheus-graphql-client 0.19.3 → 0.20.0

raw patch · 67 files changed

+1910/−2126 lines, 67 filesdep +containersdep +file-embeddep ~aesondep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, file-embed

Dependency ranges changed: aeson, base, bytestring, directory, morpheus-graphql-code-gen, morpheus-graphql-core, mtl, relude, tasty, tasty-hunit, template-haskell, text, transformers, unordered-containers

API changes (from Hackage documentation)

- Data.Morpheus.Client: defineQuery :: IO (GQLResult (Schema VALID)) -> (ExecutableDocument, String) -> Q [Dec]

+ Data.Morpheus.Client: clientTypeDeclarations :: SchemaSource -> Maybe ExecutableSource -> Q [Dec]

+ Data.Morpheus.Client: declareGlobalTypes :: FilePath -> Q [Dec]

+ Data.Morpheus.Client: declareGlobalTypesByName :: FilePath -> [TypeName] -> Q [Dec]

+ Data.Morpheus.Client: declareLocalTypes :: FilePath -> FilePath -> Q [Dec]

+ Data.Morpheus.Client: declareLocalTypesInline :: FilePath -> ExecutableSource -> Q [Dec]

+ Data.Morpheus.Client: raw :: QuasiQuoter

- Data.Morpheus.Client: defineByDocument :: IO ByteString -> (ExecutableDocument, String) -> Q [Dec]

+ Data.Morpheus.Client: defineByDocument :: IO ByteString -> ExecutableSource -> Q [Dec]

- Data.Morpheus.Client: defineByDocumentFile :: FilePath -> (ExecutableDocument, String) -> Q [Dec]

+ Data.Morpheus.Client: defineByDocumentFile :: FilePath -> ExecutableSource -> Q [Dec]

- Data.Morpheus.Client: defineByDocumentFile' :: Q FilePath -> (ExecutableDocument, String) -> Q [Dec]

+ Data.Morpheus.Client: defineByDocumentFile' :: Q FilePath -> ExecutableSource -> Q [Dec]

- Data.Morpheus.Client: defineByIntrospection :: IO ByteString -> (ExecutableDocument, String) -> Q [Dec]

+ Data.Morpheus.Client: defineByIntrospection :: IO ByteString -> ExecutableSource -> Q [Dec]

- Data.Morpheus.Client: defineByIntrospectionFile :: FilePath -> (ExecutableDocument, String) -> Q [Dec]

+ Data.Morpheus.Client: defineByIntrospectionFile :: FilePath -> ExecutableSource -> Q [Dec]

- Data.Morpheus.Client: defineByIntrospectionFile' :: Q FilePath -> (ExecutableDocument, String) -> Q [Dec]

+ Data.Morpheus.Client: defineByIntrospectionFile' :: Q FilePath -> ExecutableSource -> Q [Dec]

- Data.Morpheus.Client: type family Args a :: *;

+ Data.Morpheus.Client: type family Args a :: Type;

Files

morpheus-graphql-client.cabal +60/−48
src/Data/Morpheus/Client.hs +56/−39
src/Data/Morpheus/Client/Build.hs +0/−64
src/Data/Morpheus/Client/Declare.hs +157/−0
src/Data/Morpheus/Client/Declare/Client.hs +8/−40
src/Data/Morpheus/Client/Declare/Fetch.hs +52/−0
src/Data/Morpheus/Client/Fetch.hs +3/−24
src/Data/Morpheus/Client/Internal/Types.hs +17/−7
src/Data/Morpheus/Client/Internal/Utils.hs +40/−0
src/Data/Morpheus/Client/JSONSchema/Parse.hs +0/−169
src/Data/Morpheus/Client/JSONSchema/TypeKind.hs +0/−24
src/Data/Morpheus/Client/JSONSchema/TypeRef.hs +0/−17
src/Data/Morpheus/Client/JSONSchema/Types.hs +0/−106
src/Data/Morpheus/Client/QuasiQuoter.hs +32/−0
src/Data/Morpheus/Client/Schema/JSON/Parse.hs +169/−0
src/Data/Morpheus/Client/Schema/JSON/TypeKind.hs +24/−0
src/Data/Morpheus/Client/Schema/JSON/TypeRef.hs +17/−0
src/Data/Morpheus/Client/Schema/JSON/Types.hs +106/−0
src/Data/Morpheus/Client/Schema/Parse.hs +18/−0
src/Data/Morpheus/Client/Transform.hs +10/−0
src/Data/Morpheus/Client/Transform/Core.hs +1/−28
src/Data/Morpheus/Client/Transform/Global.hs +105/−0
src/Data/Morpheus/Client/Transform/Inputs.hs +0/−170
src/Data/Morpheus/Client/Transform/Local.hs +211/−0
src/Data/Morpheus/Client/Transform/Selection.hs +0/−233
test/Case/Enum/Test.hs +26/−43
test/Case/Github/Test.hs +49/−100
test/Case/Github/query.gql +24/−0
test/Case/Github/response.json +18/−47
test/Case/Interface/Test.hs +66/−118
test/Case/Interface/query.gql +29/−0
test/Case/JSON/Custom/Errors.hs +0/−89
test/Case/JSON/Custom/Errors/response.json +0/−17
test/Case/JSON/Custom/ErrorsWithType.hs +0/−90
test/Case/JSON/Custom/ErrorsWithType/response.json +0/−20
test/Case/JSON/Custom/Mutation.hs +0/−70
test/Case/JSON/Custom/Mutation/response.json +0/−5
test/Case/JSON/Custom/NoResponseOrError.hs +0/−76
test/Case/JSON/Custom/NoResponseOrError/response.json +0/−1
test/Case/JSON/Custom/PartialResponse.hs +0/−78
test/Case/JSON/Custom/PartialResponse/response.json +0/−6
test/Case/JSON/Custom/Query.hs +0/−82
test/Case/JSON/Custom/Query/response.json +0/−5
test/Case/JSON/Custom/Subscription.hs +0/−71
test/Case/JSON/Custom/Subscription/response.json +0/−5
test/Case/JSON/Custom/schema.json +0/−70
test/Case/LocalGlobal/Api.hs +20/−0
test/Case/LocalGlobal/Test.hs +116/−0
test/Case/LocalGlobal/cities.json +6/−0
test/Case/LocalGlobal/schema.gql +23/−0
test/Case/LocalGlobal/users1.gql +6/−0
test/Case/LocalGlobal/users1.json +8/−0
test/Case/LocalGlobal/users2.gql +5/−0
test/Case/LocalGlobal/users2.json +7/−0
test/Case/LowercaseTypeName/Test.hs +24/−46
test/Case/ResponseTypes/Test.hs +202/−0
test/Case/ResponseTypes/errors.json +17/−0
test/Case/ResponseTypes/errorsWithType.json +20/−0
test/Case/ResponseTypes/mutation.json +5/−0
test/Case/ResponseTypes/noResponseOrError.json +1/−0
test/Case/ResponseTypes/partialResponse.json +6/−0
test/Case/ResponseTypes/query.json +5/−0
test/Case/ResponseTypes/schema.json +70/−0
test/Case/ResponseTypes/subscription.json +5/−0
test/Case/Scalar/Test.hs +19/−46
test/Spec.hs +13/−23
test/Spec/Utils.hs +34/−49

morpheus-graphql-client.cabal view

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           morpheus-graphql-client-version:        0.19.3+version:        0.20.0 synopsis:       Morpheus GraphQL Client description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql, client@@ -22,22 +22,30 @@     changelog.md data-files:     test/Case/Enum/schema.gql+    test/Case/Github/query.gql     test/Case/Github/schema.gql+    test/Case/Interface/query.gql     test/Case/Interface/schema.gql+    test/Case/LocalGlobal/schema.gql+    test/Case/LocalGlobal/users1.gql+    test/Case/LocalGlobal/users2.gql     test/Case/LowercaseTypeName/schema.gql     test/Case/Scalar/schema.gql     test/Case/Enum/response.json     test/Case/Github/response.json     test/Case/Interface/response.json-    test/Case/JSON/Custom/Errors/response.json-    test/Case/JSON/Custom/ErrorsWithType/response.json-    test/Case/JSON/Custom/Mutation/response.json-    test/Case/JSON/Custom/NoResponseOrError/response.json-    test/Case/JSON/Custom/PartialResponse/response.json-    test/Case/JSON/Custom/Query/response.json-    test/Case/JSON/Custom/schema.json-    test/Case/JSON/Custom/Subscription/response.json+    test/Case/LocalGlobal/cities.json+    test/Case/LocalGlobal/users1.json+    test/Case/LocalGlobal/users2.json     test/Case/LowercaseTypeName/response.json+    test/Case/ResponseTypes/errors.json+    test/Case/ResponseTypes/errorsWithType.json+    test/Case/ResponseTypes/mutation.json+    test/Case/ResponseTypes/noResponseOrError.json+    test/Case/ResponseTypes/partialResponse.json+    test/Case/ResponseTypes/query.json+    test/Case/ResponseTypes/schema.json+    test/Case/ResponseTypes/subscription.json     test/Case/Scalar/response.json  source-repository head@@ -48,37 +56,43 @@   exposed-modules:       Data.Morpheus.Client   other-modules:-      Data.Morpheus.Client.Build+      Data.Morpheus.Client.Declare       Data.Morpheus.Client.Declare.Aeson       Data.Morpheus.Client.Declare.Client+      Data.Morpheus.Client.Declare.Fetch       Data.Morpheus.Client.Declare.Type       Data.Morpheus.Client.Fetch       Data.Morpheus.Client.Internal.TH       Data.Morpheus.Client.Internal.Types       Data.Morpheus.Client.Internal.Utils-      Data.Morpheus.Client.JSONSchema.Parse-      Data.Morpheus.Client.JSONSchema.TypeKind-      Data.Morpheus.Client.JSONSchema.TypeRef-      Data.Morpheus.Client.JSONSchema.Types+      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.Inputs-      Data.Morpheus.Client.Transform.Selection+      Data.Morpheus.Client.Transform.Global+      Data.Morpheus.Client.Transform.Local       Paths_morpheus_graphql_client   hs-source-dirs:       src   ghc-options: -Wall   build-depends:-      aeson >=1.4.4.0 && <3-    , base >=4.7 && <5-    , bytestring >=0.10.4 && <0.11-    , morpheus-graphql-code-gen >=0.19.0 && <0.20.0-    , morpheus-graphql-core >=0.19.0 && <0.20.0-    , mtl >=2.0 && <3.0-    , relude >=0.3.0 && <2.0-    , template-haskell >=2.0 && <3.0-    , text >=1.2.3.0 && <1.3-    , transformers >=0.3 && <0.6-    , unordered-containers >=0.2.8.0 && <0.3+      aeson >=1.4.4 && <3.0.0+    , base >=4.7.0 && <5.0.0+    , bytestring >=0.10.4 && <0.12.0+    , containers >=0.4.2.1 && <0.7.0+    , file-embed >=0.0.10 && <1.0.0+    , morpheus-graphql-code-gen >=0.20.0 && <0.21.0+    , morpheus-graphql-core >=0.20.0 && <0.21.0+    , mtl >=2.0.0 && <3.0.0+    , relude >=0.3.0 && <2.0.0+    , template-haskell >=2.0.0 && <3.0.0+    , text >=1.2.3 && <1.3.0+    , transformers >=0.3.0 && <0.6.0+    , unordered-containers >=0.2.8 && <0.3.0   default-language: Haskell2010  test-suite morpheus-graphql-client-test@@ -88,14 +102,10 @@       Case.Enum.Test       Case.Github.Test       Case.Interface.Test-      Case.JSON.Custom.Errors-      Case.JSON.Custom.ErrorsWithType-      Case.JSON.Custom.Mutation-      Case.JSON.Custom.NoResponseOrError-      Case.JSON.Custom.PartialResponse-      Case.JSON.Custom.Query-      Case.JSON.Custom.Subscription+      Case.LocalGlobal.Api+      Case.LocalGlobal.Test       Case.LowercaseTypeName.Test+      Case.ResponseTypes.Test       Case.Scalar.Test       Spec.Utils       Paths_morpheus_graphql_client@@ -103,19 +113,21 @@       test   ghc-options: -Wall   build-depends:-      aeson >=1.4.4.0 && <3-    , base >=4.7 && <5-    , bytestring >=0.10.4 && <0.11-    , directory >=1.0 && <2.0+      aeson >=1.4.4 && <3.0.0+    , base >=4.7.0 && <5.0.0+    , bytestring >=0.10.4 && <0.12.0+    , containers >=0.4.2.1 && <0.7.0+    , directory >=1.0.0 && <2.0.0+    , file-embed >=0.0.10 && <1.0.0     , morpheus-graphql-client-    , morpheus-graphql-code-gen >=0.19.0 && <0.20.0-    , morpheus-graphql-core >=0.19.0 && <0.20.0-    , mtl >=2.0 && <3.0-    , relude >=0.3.0 && <2.0-    , tasty >=0.1 && <1.5-    , tasty-hunit >=0.1 && <1.0-    , template-haskell >=2.0 && <3.0-    , text >=1.2.3.0 && <1.3-    , transformers >=0.3 && <0.6-    , unordered-containers >=0.2.8.0 && <0.3+    , morpheus-graphql-code-gen >=0.20.0 && <0.21.0+    , morpheus-graphql-core >=0.20.0 && <0.21.0+    , mtl >=2.0.0 && <3.0.0+    , relude >=0.3.0 && <2.0.0+    , tasty >=0.1.0 && <1.5.0+    , tasty-hunit >=0.1.0 && <1.0.0+    , template-haskell >=2.0.0 && <3.0.0+    , text >=1.2.3 && <1.3.0+    , transformers >=0.3.0 && <0.6.0+    , unordered-containers >=0.2.8 && <0.3.0   default-language: Haskell2010

src/Data/Morpheus/Client.hs view

@@ -2,20 +2,26 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Client-  ( gql,+  ( raw,     Fetch (..),-    FetchError(..),-    defineQuery,+    FetchError (..),+    ScalarValue (..),+    DecodeScalar (..),+    EncodeScalar (..),+    ID (..),+    declareGlobalTypes,+    declareGlobalTypesByName,+    declareLocalTypes,+    declareLocalTypesInline,+    clientTypeDeclarations,+    -- DEPRECATED EXPORTS+    gql,     defineByDocument,     defineByDocumentFile,     defineByDocumentFile',     defineByIntrospection,     defineByIntrospectionFile,     defineByIntrospectionFile',-    ScalarValue (..),-    DecodeScalar (..),-    EncodeScalar (..),-    ID (..),   ) where @@ -23,65 +29,76 @@ import qualified Data.ByteString.Lazy as L   ( readFile,   )-import Data.Morpheus.Client.Build-  ( defineQuery,+import Data.Morpheus.Client.Declare+  ( clientTypeDeclarations,+    declareGlobalTypes,+    declareGlobalTypesByName,+    declareLocalTypes,+    declareLocalTypesInline,+    internalLegacyLocalDeclareTypes,+    raw,   ) import Data.Morpheus.Client.Fetch   ( Fetch (..),   )-import Data.Morpheus.Client.JSONSchema.Parse-  ( decodeIntrospection,-  ) import Data.Morpheus.Client.Internal.Types-  ( FetchError(..),-  )-import Data.Morpheus.Core-  ( parseFullSchema,-  )-import Data.Morpheus.Internal.Ext-  ( GQLResult,+  ( ExecutableSource,+    FetchError (..),+    SchemaSource (..),   )-import Data.Morpheus.QuasiQuoter (gql) import Data.Morpheus.Types.GQLScalar   ( DecodeScalar (..),     EncodeScalar (..),   ) import Data.Morpheus.Types.ID (ID (..)) import Data.Morpheus.Types.Internal.AST-  ( ExecutableDocument,-    ScalarValue (..),-    Schema,-    VALID,+  ( ScalarValue (..),   ) import Language.Haskell.TH+import Language.Haskell.TH.Quote (QuasiQuoter) import Language.Haskell.TH.Syntax   ( qAddDependentFile,   ) import Relude hiding (ByteString) -defineByDocumentFile :: FilePath -> (ExecutableDocument, String) -> Q [Dec]-defineByDocumentFile filePath args = do-  qAddDependentFile filePath-  defineByDocument (L.readFile filePath) args+{-# DEPRECATED gql "use raw" #-}+gql :: QuasiQuoter+gql = raw +-- DEPRECATED: Legacy Code Exports++{-# DEPRECATED defineByDocumentFile' "use declareLocalTypes" #-}+ -- | This variant exposes 'Q FilePath' enabling the use of TH to generate the 'FilePath'. For example, https://hackage.haskell.org/package/file-embed-0.0.13.0/docs/Data-FileEmbed.html#v:makeRelativeToProject can be used to handle multi package projects more reliably.-defineByDocumentFile' :: Q FilePath -> (ExecutableDocument, String) -> Q [Dec]+defineByDocumentFile' :: Q FilePath -> ExecutableSource -> Q [Dec] defineByDocumentFile' qFilePath args = qFilePath >>= flip defineByDocumentFile args -defineByIntrospectionFile :: FilePath -> (ExecutableDocument, String) -> Q [Dec]+{-# DEPRECATED defineByIntrospectionFile' "use declareLocalTypes" #-}++-- | This variant exposes 'Q FilePath' enabling the use of TH to generate the 'FilePath'. For example, https://hackage.haskell.org/package/file-embed-0.0.13.0/docs/Data-FileEmbed.html#v:makeRelativeToProject can be used to handle multi package projects more reliably.+defineByIntrospectionFile' :: Q FilePath -> ExecutableSource -> Q [Dec]+defineByIntrospectionFile' path args = path >>= flip defineByIntrospectionFile args++-- with file++{-# DEPRECATED defineByIntrospectionFile "use declareLocalTypes" #-}+defineByIntrospectionFile :: FilePath -> ExecutableSource -> Q [Dec] defineByIntrospectionFile filePath args = do   qAddDependentFile filePath   defineByIntrospection (L.readFile filePath) args --- | This variant exposes 'Q FilePath' enabling the use of TH to generate the 'FilePath'. For example, https://hackage.haskell.org/package/file-embed-0.0.13.0/docs/Data-FileEmbed.html#v:makeRelativeToProject can be used to handle multi package projects more reliably.-defineByIntrospectionFile' :: Q FilePath -> (ExecutableDocument, String) -> Q [Dec]-defineByIntrospectionFile' qFilePath args = qFilePath >>= flip defineByIntrospectionFile args+{-# DEPRECATED defineByDocumentFile "use declareLocalTypes" #-}+defineByDocumentFile :: FilePath -> ExecutableSource -> Q [Dec]+defineByDocumentFile filePath args = do+  qAddDependentFile filePath+  defineByDocument (L.readFile filePath) args -defineByDocument :: IO ByteString -> (ExecutableDocument, String) -> Q [Dec]-defineByDocument doc = defineQuery (schemaByDocument doc)+-- direct -schemaByDocument :: IO ByteString -> IO (GQLResult (Schema VALID))-schemaByDocument = fmap parseFullSchema+{-# DEPRECATED defineByDocument "use clientTypeDeclarations" #-}+defineByDocument :: IO ByteString -> ExecutableSource -> Q [Dec]+defineByDocument doc = internalLegacyLocalDeclareTypes (GQL <$> doc) -defineByIntrospection :: IO ByteString -> (ExecutableDocument, String) -> Q [Dec]-defineByIntrospection json = defineQuery (decodeIntrospection <$> json)+{-# DEPRECATED defineByIntrospection "use clientTypeDeclarations" #-}+defineByIntrospection :: IO ByteString -> ExecutableSource -> Q [Dec]+defineByIntrospection doc = internalLegacyLocalDeclareTypes (JSON <$> doc)

− src/Data/Morpheus/Client/Build.hs

@@ -1,64 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Client.Build-  ( defineQuery,-  )-where------- MORPHEUS-import Data.Morpheus.Client.Declare.Client-  ( declareClient,-  )-import Data.Morpheus.Client.Internal.Types-  ( ClientDefinition (..),-  )-import Data.Morpheus.Client.Transform.Selection-  ( toClientDefinition,-  )-import Data.Morpheus.Core-  ( Config (..),-    VALIDATION_MODE (..),-    validateRequest,-  )-import Data.Morpheus.Error-  ( gqlWarnings,-    renderGQLErrors,-  )-import Data.Morpheus.Internal.Ext-  ( GQLResult,-    Result (..),-  )-import Data.Morpheus.Types.Internal.AST-  ( ExecutableDocument (..),-    Operation (..),-    Schema,-    VALID,-  )-import Language.Haskell.TH-import Relude--defineQuery :: IO (GQLResult (Schema VALID)) -> (ExecutableDocument, String) -> Q [Dec]-defineQuery ioSchema (query, src) = do-  schema <- runIO ioSchema-  case schema >>= (`validateWith` query) of-    Failure errors -> fail (renderGQLErrors errors)-    Success-      { result,-        warnings-      } -> gqlWarnings warnings >> declareClient src result--validateWith :: Schema VALID -> ExecutableDocument -> GQLResult ClientDefinition-validateWith-  schema-  rawRequest@ExecutableDocument-    { operation = Operation {operationArguments}-    } = do-    validOperation <- validateRequest Config {debug = False, validationMode = WITHOUT_VARIABLES} schema rawRequest-    toClientDefinition-      schema-      operationArguments-      validOperation

+ src/Data/Morpheus/Client/Declare.hs view

@@ -0,0 +1,157 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Client.Declare+  ( declareGlobalTypes,+    declareGlobalTypesByName,+    declareLocalTypes,+    declareLocalTypesInline,+    internalLegacyLocalDeclareTypes,+    clientTypeDeclarations,+    raw,+  )+where++import Data.Morpheus.Client.Declare.Client+  ( declareTypes,+  )+import Data.Morpheus.Client.Declare.Fetch+import Data.Morpheus.Client.Internal.Types+  ( ExecutableSource,+    SchemaSource,+  )+import Data.Morpheus.Client.Internal.Utils (getFile, getSource, handleResult)+import Data.Morpheus.Client.QuasiQuoter (raw)+import Data.Morpheus.Client.Schema.Parse (parseSchema)+import Data.Morpheus.Client.Transform+  ( toGlobalDefinitions,+    toLocalDefinitions,+  )+import Data.Morpheus.CodeGen.Internal.AST+import Data.Morpheus.Core (parseRequest)+import Data.Morpheus.Types.IO (GQLRequest (..))+import Data.Set+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 executableDoc schemaDoc+    )+    ( \(fetch, types) ->+        (<>)+          <$> declareFetch query fetch+          <*> declareTypes types+    )++globalTypeDeclarations :: SchemaSource -> (TypeName -> Bool) -> Q [Dec]+globalTypeDeclarations src f = handleResult (toGlobalDefinitions f <$> parseSchema src) declareTypes++-- | 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 (`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

src/Data/Morpheus/Client/Declare/Client.hs view

@@ -1,11 +1,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Client.Declare.Client-  ( declareClient,+  ( declareTypes,   ) where @@ -15,48 +14,17 @@ import Data.Morpheus.Client.Declare.Type   ( typeDeclarations,   )-import Data.Morpheus.Client.Fetch-  ( deriveFetch,-  ) import Data.Morpheus.Client.Internal.Types-  ( ClientDefinition (..),-    ClientTypeDefinition (..),-    TypeNameTH (..),+  ( ClientTypeDefinition (..),   )-import Data.Morpheus.CodeGen.Internal.TH (toCon) import Language.Haskell.TH import Relude hiding (Type) -declareClient :: String -> ClientDefinition -> Q [Dec]-declareClient _ ClientDefinition {clientTypes = []} = pure []-declareClient src ClientDefinition {clientArguments, clientTypes = rootType : subTypes} =-  (<>)-    <$> defineOperationType-      (queryArgumentType clientArguments)-      src-      rootType-    <*> (concat <$> traverse declareType subTypes)+declareTypes :: [ClientTypeDefinition] -> Q [Dec]+declareTypes subTypes = concat <$> traverse declareType subTypes  declareType :: ClientTypeDefinition -> Q [Dec]-declareType clientType@ClientTypeDefinition{clientKind} = do-    types <- typeDeclarations clientKind clientType-    instances <- aesonDeclarations clientKind clientType-    pure (types <> instances)--queryArgumentType :: Maybe ClientTypeDefinition -> (Type, Q [Dec])-queryArgumentType Nothing = (toCon ("()" :: String), pure [])-queryArgumentType (Just client@ClientTypeDefinition {clientTypeName}) =-  (toCon (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+declareType clientType@ClientTypeDefinition {clientKind} = do+  types <- typeDeclarations clientKind clientType+  instances <- aesonDeclarations clientKind clientType+  pure (types <> instances)

+ src/Data/Morpheus/Client/Declare/Fetch.hs view

@@ -0,0 +1,52 @@+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Client.Declare.Fetch+  ( declareFetch,+  )+where++import Data.Morpheus.Client.Fetch (Fetch (..))+import Data.Morpheus.Client.Internal.Types+  ( FetchDefinition (..),+    TypeNameTH (..),+  )+import Data.Morpheus.CodeGen.Internal.TH+  ( applyCons,+    toCon,+    typeInstanceDec,+  )+import qualified Data.Text as T+import Language.Haskell.TH+  ( Dec,+    Q,+    Type,+    clause,+    cxt,+    funD,+    instanceD,+    normalB,+  )+import Relude hiding (ByteString, Type)++declareFetch :: Text -> FetchDefinition -> Q [Dec]+declareFetch query FetchDefinition {clientArgumentsTypeName, rootTypeName} =+  pure <$> instanceD (cxt []) iHead methods+  where+    queryString = T.unpack query+    typeName = typename rootTypeName+    iHead = applyCons ''Fetch [typeName]+    methods =+      [ funD 'fetch [clause [] (normalB [|__fetch queryString typeName|]) []],+        pure $ typeInstanceDec ''Args (toCon typeName) (argumentType clientArgumentsTypeName)+      ]++argumentType :: Maybe TypeNameTH -> Type+argumentType Nothing = toCon ("()" :: String)+argumentType (Just clientTypeName) = toCon (typename clientTypeName)

src/Data/Morpheus/Client/Fetch.hs view

@@ -1,14 +1,10 @@ {-# LANGUAGE ConstrainedClassMethods #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Client.Fetch   ( Fetch (..),-    deriveFetch,   ) where @@ -24,26 +20,19 @@ import Data.Morpheus.Client.Internal.Types   ( FetchError (..),   )-import Data.Morpheus.Client.JSONSchema.Types+import Data.Morpheus.Client.Schema.JSON.Types   ( JSONResponse (..),   )-import Data.Morpheus.CodeGen.Internal.TH-  ( applyCons,-    toCon,-    typeInstanceDec,-  ) import Data.Morpheus.Types.IO   ( GQLRequest (..),   ) import Data.Morpheus.Types.Internal.AST   ( FieldName,-    TypeName,   ) import Data.Text   ( pack,   )-import Language.Haskell.TH-import Relude hiding (ByteString, Type)+import Relude hiding (ByteString)  fixVars :: A.Value -> Maybe A.Value fixVars x@@ -51,7 +40,7 @@   | otherwise = Just x  class Fetch a where-  type Args a :: *+  type Args a :: Type   __fetch ::     (Monad m, Show a, ToJSON (Args a), FromJSON a) =>     String ->@@ -67,13 +56,3 @@       processResponse JSONResponse {responseData = Nothing, responseErrors = []} = Left FetchErrorNoResult       processResponse JSONResponse {responseData = result, responseErrors = (x : xs)} = Left $ FetchErrorProducedErrors (x :| xs) result   fetch :: (Monad m, FromJSON a) => (ByteString -> m ByteString) -> Args a -> m (Either (FetchError a) a)--deriveFetch :: Type -> TypeName -> String -> Q [Dec]-deriveFetch resultType typeName queryString =-  pure <$> instanceD (cxt []) iHead methods-  where-    iHead = applyCons ''Fetch [typeName]-    methods =-      [ funD 'fetch [clause [] (normalB [|__fetch queryString typeName|]) []],-        pure $ typeInstanceDec ''Args (toCon typeName) resultType-      ]

src/Data/Morpheus/Client/Internal/Types.hs view

@@ -1,15 +1,18 @@-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Client.Internal.Types   ( ClientTypeDefinition (..),     TypeNameTH (..),-    ClientDefinition (..),+    FetchDefinition (..),     ClientConstructorDefinition (..),-    FetchError (..)+    FetchError (..),+    SchemaSource (..),+    ExecutableSource,   ) where +import Data.ByteString.Lazy (ByteString) import Data.Morpheus.Types.Internal.AST   ( ANY,     FieldDefinition,@@ -19,7 +22,7 @@     TypeName,     VALID,   )-import Relude+import Relude hiding (ByteString)  data TypeNameTH = TypeNameTH   { namespace :: [FieldName],@@ -40,9 +43,9 @@   }   deriving (Show) -data ClientDefinition = ClientDefinition-  { clientArguments :: Maybe ClientTypeDefinition,-    clientTypes :: [ClientTypeDefinition]+data FetchDefinition = FetchDefinition+  { rootTypeName :: TypeNameTH,+    clientArgumentsTypeName :: Maybe TypeNameTH   }   deriving (Show) @@ -51,3 +54,10 @@   | FetchErrorProducedErrors GQLErrors (Maybe a)   | FetchErrorNoResult   deriving (Show, Eq, Generic)++data SchemaSource+  = JSON ByteString+  | GQL ByteString+  deriving (Show, Eq)++type ExecutableSource = Text

src/Data/Morpheus/Client/Internal/Utils.hs view

@@ -1,14 +1,28 @@+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Client.Internal.Utils   ( removeDuplicates,     isEnum,+    getSource,+    handleResult,+    getFile,   ) 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.Internal.Types   ( ClientConstructorDefinition (cFields),+    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  removeDuplicates :: Eq a => [a] -> [a]@@ -25,3 +39,29 @@  isEnum :: [ClientConstructorDefinition] -> Bool isEnum = all (null . cFields)++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

− src/Data/Morpheus/Client/JSONSchema/Parse.hs

@@ -1,169 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Client.JSONSchema.Parse-  ( decodeIntrospection,-  )-where--import Control.Monad.Except (MonadError (throwError))-import Data.Aeson-import Data.ByteString.Lazy (ByteString)-import Data.Morpheus.Client.JSONSchema.TypeKind (TypeKind (..))-import qualified Data.Morpheus.Client.JSONSchema.TypeRef as Ref-import Data.Morpheus.Client.JSONSchema.Types-  ( EnumValue (..),-    Field (..),-    InputValue (..),-    Introspection (..),-    JSONResponse (..),-    Schema (..),-    Type (..),-  )-import Data.Morpheus.Core-  ( defaultConfig,-    validateSchema,-  )-import Data.Morpheus.Internal.Ext-  ( GQLResult,-  )-import Data.Morpheus.Internal.Utils-  ( empty,-    fromElems,-  )-import qualified Data.Morpheus.Types.Internal.AST as AST-  ( Schema,-  )-import Data.Morpheus.Types.Internal.AST-  ( ANY,-    ArgumentDefinition (..),-    CONST,-    FieldDefinition,-    GQLError,-    IN,-    OUT,-    OperationType (..),-    RootOperationTypeDefinition (..),-    SchemaDefinition (..),-    TypeContent (..),-    TypeDefinition (..),-    TypeRef (..),-    TypeWrapper (..),-    VALID,-    buildSchema,-    createScalarType,-    mkEnumContent,-    mkField,-    mkMaybeType,-    mkObjectField,-    mkType,-    mkUnionContent,-    msg,-    toAny,-  )-import Relude hiding-  ( ByteString,-    Type,-    empty,-    fromList,-    show,-  )-import Prelude (show)--decoderError :: GQLError -> GQLResult a-decoderError = throwError--decodeIntrospection :: ByteString -> GQLResult (AST.Schema VALID)-decodeIntrospection jsonDoc = case jsonSchema of-  Left errors -> decoderError $ msg errors-  Right-    JSONResponse-      { responseData =-          Just-            Introspection-              { __schema =-                  schema@Schema {types}-              }-      } -> do-      schemaDef <- mkSchemaDef schema-      gqlTypes <- concat <$> traverse parse types-      buildSchema (Just schemaDef, gqlTypes, empty) >>= validate-  Right res -> decoderError (msg $ show res)-  where-    validate :: AST.Schema CONST -> GQLResult (AST.Schema VALID)-    validate = validateSchema False defaultConfig-    jsonSchema :: Either String (JSONResponse Introspection)-    jsonSchema = eitherDecode jsonDoc--mkSchemaDef ::-  (Monad m, MonadError GQLError m) =>-  Schema ->-  m SchemaDefinition-mkSchemaDef-  Schema-    { queryType,-      mutationType,-      subscriptionType-    } =-    SchemaDefinition empty-      <$> fromElems-        ( catMaybes-            [ Just (RootOperationTypeDefinition Query $ Ref.name queryType),-              RootOperationTypeDefinition Mutation . Ref.name <$> mutationType,-              RootOperationTypeDefinition Subscription . Ref.name <$> subscriptionType-            ]-        )--class ParseJSONSchema a b where-  parse :: a -> GQLResult b--instance ParseJSONSchema Type [TypeDefinition ANY CONST] where-  parse Type {name = Just typeName, kind = SCALAR} =-    pure [createScalarType typeName]-  parse Type {name = Just typeName, kind = ENUM, enumValues = Just enums} =-    pure [mkType typeName $ mkEnumContent (fmap enumName enums)]-  parse Type {name = Just typeName, kind = UNION, possibleTypes = Just unions} =-    case traverse name unions of-      Nothing -> decoderError "ERROR: GQL ERROR"-      Just uni -> pure [toAny $ mkType typeName $ mkUnionContent uni]-  parse Type {name = Just typeName, kind = INPUT_OBJECT, inputFields = Just iFields} =-    do-      (fields :: [FieldDefinition IN CONST]) <- traverse parse iFields-      fs <- fromElems fields-      pure [mkType typeName $ DataInputObject fs]-  parse Type {name = Just typeName, kind = OBJECT, fields = Just oFields} =-    do-      (fields :: [FieldDefinition OUT CONST]) <- traverse parse oFields-      fs <- fromElems fields-      pure [mkType typeName $ DataObject [] fs]-  parse _ = pure []--instance ParseJSONSchema Field (FieldDefinition OUT CONST) where-  parse Field {fieldName, fieldArgs, fieldType} = do-    TypeRef typename wrappers <- fieldTypeFromJSON fieldType-    args <- traverse genArg fieldArgs >>= fromElems-    pure $ mkObjectField args fieldName wrappers typename-    where-      genArg InputValue {inputName = argName, inputType = argType} =-        ArgumentDefinition . mkField Nothing argName <$> fieldTypeFromJSON argType--instance ParseJSONSchema InputValue (FieldDefinition IN CONST) where-  parse InputValue {inputName, inputType} = mkField Nothing inputName <$> fieldTypeFromJSON inputType--fieldTypeFromJSON :: Type -> GQLResult TypeRef-fieldTypeFromJSON Type {kind = NON_NULL, ofType = Just ofType} = withListNonNull <$> fieldTypeFromJSON ofType-fieldTypeFromJSON Type {kind = LIST, ofType = Just ofType} = withList <$> fieldTypeFromJSON ofType-fieldTypeFromJSON Type {name = Just name} = pure (TypeRef name mkMaybeType)-fieldTypeFromJSON x = decoderError $ "Unsupported Field" <> msg (show x)--withList :: TypeRef -> TypeRef-withList (TypeRef name x) = TypeRef name (TypeList x False)--withListNonNull :: TypeRef -> TypeRef-withListNonNull (TypeRef name (TypeList y _)) = TypeRef name (TypeList y True)-withListNonNull (TypeRef name (BaseType _)) = TypeRef name (BaseType True)

− src/Data/Morpheus/Client/JSONSchema/TypeKind.hs

@@ -1,24 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Client.JSONSchema.TypeKind-  ( TypeKind (..),-  )-where--import Data.Aeson (FromJSON (..))-import GHC.Generics-import Relude--data TypeKind-  = SCALAR-  | OBJECT-  | INTERFACE-  | UNION-  | ENUM-  | INPUT_OBJECT-  | LIST-  | NON_NULL-  deriving (Eq, Generic, FromJSON, Show)

− src/Data/Morpheus/Client/JSONSchema/TypeRef.hs

@@ -1,17 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Client.JSONSchema.TypeRef-  ( TypeRef (..),-  )-where--import Data.Aeson (FromJSON)-import Data.Morpheus.Types.Internal.AST-  ( TypeName,-  )-import Relude--newtype TypeRef = TypeRef {name :: TypeName}-  deriving (Generic, Show, FromJSON)

− src/Data/Morpheus/Client/JSONSchema/Types.hs

@@ -1,106 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Client.JSONSchema.Types-  ( Introspection (..),-    Schema (..),-    Type (..),-    Field (..),-    InputValue (..),-    EnumValue (..),-    JSONResponse (..),-  )-where--import Data.Aeson------ MORPHEUS-import Data.Morpheus.Client.JSONSchema.TypeKind (TypeKind)-import Data.Morpheus.Client.JSONSchema.TypeRef (TypeRef)-import Data.Morpheus.Types.Internal.AST-  ( FieldName,-    GQLError,-    TypeName,-  )-import Relude hiding (Type)---- TYPES FOR DECODING JSON INTROSPECTION----newtype Introspection = Introspection-  { __schema :: Schema-  }-  deriving (Generic, Show, FromJSON)--data Schema = Schema-  { types :: [Type],-    queryType :: TypeRef,-    mutationType :: Maybe TypeRef,-    subscriptionType :: Maybe TypeRef-    -- TODO: directives-    --directives: [__Directive]-  }-  deriving (Generic, Show, FromJSON)--data Type = Type-  { kind :: TypeKind,-    name :: Maybe TypeName,-    fields :: Maybe [Field],-    interfaces :: Maybe [Type],-    possibleTypes :: Maybe [Type],-    enumValues :: Maybe [EnumValue],-    inputFields :: Maybe [InputValue],-    ofType :: Maybe Type-  }-  deriving (Generic, Show, FromJSON)---- FIELD-data Field = Field-  { fieldName :: FieldName,-    fieldArgs :: [InputValue],-    fieldType :: Type-  }-  deriving (Show, Generic)--instance FromJSON Field where-  parseJSON = withObject "Field" objectParser-    where-      objectParser o = Field <$> o .: "name" <*> o .: "args" <*> o .: "type"---- INPUT-data InputValue = InputValue-  { inputName :: FieldName,-    inputType :: Type-  }-  deriving (Show, Generic)--instance FromJSON InputValue where-  parseJSON = withObject "InputValue" objectParser-    where-      objectParser o = InputValue <$> o .: "name" <*> o .: "type"---- ENUM-newtype EnumValue = EnumValue-  { enumName :: TypeName-  }-  deriving (Generic, Show)--instance FromJSON EnumValue where-  parseJSON = withObject "EnumValue" objectParser-    where-      objectParser o = EnumValue <$> o .: "name"--instance FromJSON a => FromJSON (JSONResponse a) where-  parseJSON = withObject "JSONResponse" objectParser-    where-      objectParser o =-        JSONResponse <$> o .:? "data" <*> o .:? "errors" .!= []--data JSONResponse a = JSONResponse-  { responseData :: Maybe a,-    responseErrors :: [GQLError]-  }-  deriving (Generic, Show, ToJSON)

+ src/Data/Morpheus/Client/QuasiQuoter.hs view

@@ -0,0 +1,32 @@+{-# 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"+    }

+ src/Data/Morpheus/Client/Schema/JSON/Parse.hs view

@@ -0,0 +1,169 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Client.Schema.JSON.Parse+  ( decodeIntrospection,+  )+where++import Control.Monad.Except (MonadError (throwError))+import Data.Aeson+import Data.ByteString.Lazy (ByteString)+import Data.Morpheus.Client.Schema.JSON.TypeKind (TypeKind (..))+import qualified Data.Morpheus.Client.Schema.JSON.TypeRef as Ref+import Data.Morpheus.Client.Schema.JSON.Types+  ( EnumValue (..),+    Field (..),+    InputValue (..),+    Introspection (..),+    JSONResponse (..),+    Schema (..),+    Type (..),+  )+import Data.Morpheus.Core+  ( defaultConfig,+    validateSchema,+  )+import Data.Morpheus.Internal.Ext+  ( GQLResult,+  )+import Data.Morpheus.Internal.Utils+  ( empty,+    fromElems,+  )+import qualified Data.Morpheus.Types.Internal.AST as AST+  ( Schema,+  )+import Data.Morpheus.Types.Internal.AST+  ( ANY,+    ArgumentDefinition (..),+    CONST,+    FieldDefinition,+    GQLError,+    IN,+    OUT,+    OperationType (..),+    RootOperationTypeDefinition (..),+    SchemaDefinition (..),+    TypeContent (..),+    TypeDefinition (..),+    TypeRef (..),+    TypeWrapper (..),+    VALID,+    buildSchema,+    createScalarType,+    mkEnumContent,+    mkField,+    mkMaybeType,+    mkObjectField,+    mkType,+    mkUnionContent,+    msg,+    toAny,+  )+import Relude hiding+  ( ByteString,+    Type,+    empty,+    fromList,+    show,+  )+import Prelude (show)++decoderError :: GQLError -> GQLResult a+decoderError = throwError++decodeIntrospection :: ByteString -> GQLResult (AST.Schema VALID)+decodeIntrospection jsonDoc = case jsonSchema of+  Left errors -> decoderError $ msg errors+  Right+    JSONResponse+      { responseData =+          Just+            Introspection+              { __schema =+                  schema@Schema {types}+              }+      } -> do+      schemaDef <- mkSchemaDef schema+      gqlTypes <- concat <$> traverse parse types+      buildSchema (Just schemaDef, gqlTypes, empty) >>= validate+  Right res -> decoderError (msg $ show res)+  where+    validate :: AST.Schema CONST -> GQLResult (AST.Schema VALID)+    validate = validateSchema False defaultConfig+    jsonSchema :: Either String (JSONResponse Introspection)+    jsonSchema = eitherDecode jsonDoc++mkSchemaDef ::+  (Monad m, MonadError GQLError m) =>+  Schema ->+  m SchemaDefinition+mkSchemaDef+  Schema+    { queryType,+      mutationType,+      subscriptionType+    } =+    SchemaDefinition empty+      <$> fromElems+        ( catMaybes+            [ Just (RootOperationTypeDefinition Query $ Ref.name queryType),+              RootOperationTypeDefinition Mutation . Ref.name <$> mutationType,+              RootOperationTypeDefinition Subscription . Ref.name <$> subscriptionType+            ]+        )++class ParseJSONSchema a b where+  parse :: a -> GQLResult b++instance ParseJSONSchema Type [TypeDefinition ANY CONST] where+  parse Type {name = Just typeName, kind = SCALAR} =+    pure [createScalarType typeName]+  parse Type {name = Just typeName, kind = ENUM, enumValues = Just enums} =+    pure [mkType typeName $ mkEnumContent (fmap enumName enums)]+  parse Type {name = Just typeName, kind = UNION, possibleTypes = Just unions} =+    case traverse name unions of+      Nothing -> decoderError "ERROR: GQL ERROR"+      Just uni -> pure [toAny $ mkType typeName $ mkUnionContent uni]+  parse Type {name = Just typeName, kind = INPUT_OBJECT, inputFields = Just iFields} =+    do+      (fields :: [FieldDefinition IN CONST]) <- traverse parse iFields+      fs <- fromElems fields+      pure [mkType typeName $ DataInputObject fs]+  parse Type {name = Just typeName, kind = OBJECT, fields = Just oFields} =+    do+      (fields :: [FieldDefinition OUT CONST]) <- traverse parse oFields+      fs <- fromElems fields+      pure [mkType typeName $ DataObject [] fs]+  parse _ = pure []++instance ParseJSONSchema Field (FieldDefinition OUT CONST) where+  parse Field {fieldName, fieldArgs, fieldType} = do+    TypeRef typename wrappers <- fieldTypeFromJSON fieldType+    args <- traverse genArg fieldArgs >>= fromElems+    pure $ mkObjectField args fieldName wrappers typename+    where+      genArg InputValue {inputName = argName, inputType = argType} =+        ArgumentDefinition . mkField Nothing argName <$> fieldTypeFromJSON argType++instance ParseJSONSchema InputValue (FieldDefinition IN CONST) where+  parse InputValue {inputName, inputType} = mkField Nothing inputName <$> fieldTypeFromJSON inputType++fieldTypeFromJSON :: Type -> GQLResult TypeRef+fieldTypeFromJSON Type {kind = NON_NULL, ofType = Just ofType} = withListNonNull <$> fieldTypeFromJSON ofType+fieldTypeFromJSON Type {kind = LIST, ofType = Just ofType} = withList <$> fieldTypeFromJSON ofType+fieldTypeFromJSON Type {name = Just name} = pure (TypeRef name mkMaybeType)+fieldTypeFromJSON x = decoderError $ "Unsupported Field" <> msg (show x)++withList :: TypeRef -> TypeRef+withList (TypeRef name x) = TypeRef name (TypeList x False)++withListNonNull :: TypeRef -> TypeRef+withListNonNull (TypeRef name (TypeList y _)) = TypeRef name (TypeList y True)+withListNonNull (TypeRef name (BaseType _)) = TypeRef name (BaseType True)

+ src/Data/Morpheus/Client/Schema/JSON/TypeKind.hs view

@@ -0,0 +1,24 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Client.Schema.JSON.TypeKind+  ( TypeKind (..),+  )+where++import Data.Aeson (FromJSON (..))+import GHC.Generics+import Relude++data TypeKind+  = SCALAR+  | OBJECT+  | INTERFACE+  | UNION+  | ENUM+  | INPUT_OBJECT+  | LIST+  | NON_NULL+  deriving (Eq, Generic, FromJSON, Show)

+ src/Data/Morpheus/Client/Schema/JSON/TypeRef.hs view

@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Client.Schema.JSON.TypeRef+  ( TypeRef (..),+  )+where++import Data.Aeson (FromJSON)+import Data.Morpheus.Types.Internal.AST+  ( TypeName,+  )+import Relude++newtype TypeRef = TypeRef {name :: TypeName}+  deriving (Generic, Show, FromJSON)

+ src/Data/Morpheus/Client/Schema/JSON/Types.hs view

@@ -0,0 +1,106 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Client.Schema.JSON.Types+  ( Introspection (..),+    Schema (..),+    Type (..),+    Field (..),+    InputValue (..),+    EnumValue (..),+    JSONResponse (..),+  )+where++import Data.Aeson+--+-- MORPHEUS+import Data.Morpheus.Client.Schema.JSON.TypeKind (TypeKind)+import Data.Morpheus.Client.Schema.JSON.TypeRef (TypeRef)+import Data.Morpheus.Types.Internal.AST+  ( FieldName,+    GQLError,+    TypeName,+  )+import Relude hiding (Type)++-- TYPES FOR DECODING JSON INTROSPECTION+--+newtype Introspection = Introspection+  { __schema :: Schema+  }+  deriving (Generic, Show, FromJSON)++data Schema = Schema+  { types :: [Type],+    queryType :: TypeRef,+    mutationType :: Maybe TypeRef,+    subscriptionType :: Maybe TypeRef+    -- TODO: directives+    --directives: [__Directive]+  }+  deriving (Generic, Show, FromJSON)++data Type = Type+  { kind :: TypeKind,+    name :: Maybe TypeName,+    fields :: Maybe [Field],+    interfaces :: Maybe [Type],+    possibleTypes :: Maybe [Type],+    enumValues :: Maybe [EnumValue],+    inputFields :: Maybe [InputValue],+    ofType :: Maybe Type+  }+  deriving (Generic, Show, FromJSON)++-- FIELD+data Field = Field+  { fieldName :: FieldName,+    fieldArgs :: [InputValue],+    fieldType :: Type+  }+  deriving (Show, Generic)++instance FromJSON Field where+  parseJSON = withObject "Field" objectParser+    where+      objectParser o = Field <$> o .: "name" <*> o .: "args" <*> o .: "type"++-- INPUT+data InputValue = InputValue+  { inputName :: FieldName,+    inputType :: Type+  }+  deriving (Show, Generic)++instance FromJSON InputValue where+  parseJSON = withObject "InputValue" objectParser+    where+      objectParser o = InputValue <$> o .: "name" <*> o .: "type"++-- ENUM+newtype EnumValue = EnumValue+  { enumName :: TypeName+  }+  deriving (Generic, Show)++instance FromJSON EnumValue where+  parseJSON = withObject "EnumValue" objectParser+    where+      objectParser o = EnumValue <$> o .: "name"++instance FromJSON a => FromJSON (JSONResponse a) where+  parseJSON = withObject "JSONResponse" objectParser+    where+      objectParser o =+        JSONResponse <$> o .:? "data" <*> o .:? "errors" .!= []++data JSONResponse a = JSONResponse+  { responseData :: Maybe a,+    responseErrors :: [GQLError]+  }+  deriving (Generic, Show, ToJSON)

+ src/Data/Morpheus/Client/Schema/Parse.hs view

@@ -0,0 +1,18 @@+module Data.Morpheus.Client.Schema.Parse+  ( parseSchema,+  )+where++import Data.Morpheus.Client.Internal.Types (SchemaSource (..))+import Data.Morpheus.Client.Schema.JSON.Parse+  ( decodeIntrospection,+  )+import Data.Morpheus.Core+  ( parseFullSchema,+  )+import Data.Morpheus.Internal.Ext (GQLResult)+import Data.Morpheus.Types.Internal.AST (Schema, VALID)++parseSchema :: SchemaSource -> GQLResult (Schema VALID)+parseSchema (JSON doc) = decodeIntrospection doc+parseSchema (GQL doc) = parseFullSchema doc

+ src/Data/Morpheus/Client/Transform.hs view

@@ -0,0 +1,10 @@+module Data.Morpheus.Client.Transform+  ( toGlobalDefinitions,+    toLocalDefinitions,+  )+where++import Data.Morpheus.Client.Transform.Global (toGlobalDefinitions)+import Data.Morpheus.Client.Transform.Local+  ( toLocalDefinitions,+  )

src/Data/Morpheus/Client/Transform/Core.hs view

@@ -11,19 +11,12 @@   ( Converter (..),     compileError,     getType,-    leafType,     typeFrom,     deprecationWarning,-    customScalarTypes,-    UpdateT (..),-    resolveUpdates,   ) where -import Control.Monad.Except (MonadError (throwError))-import Data.Morpheus.Client.Internal.Types-  ( ClientTypeDefinition (..),-  )+import Control.Monad.Except (MonadError) import Data.Morpheus.CodeGen.Internal.TH   ( camelCaseTypeName,   )@@ -45,14 +38,12 @@     RAW,     Ref (..),     Schema (..),-    TRUE,     TypeContent (..),     TypeDefinition (..),     TypeName,     VALID,     VariableDefinitions,     internal,-    isNotSystemTypeName,     lookupDeprecated,     lookupDeprecatedReason,     msg,@@ -77,11 +68,6 @@       MonadError GQLError     ) -newtype UpdateT m a = UpdateT {updateTState :: a -> m a}--resolveUpdates :: Monad m => a -> [UpdateT m a] -> m a-resolveUpdates a = foldlM (&) a . fmap updateTState- compileError :: GQLError -> GQLError compileError x = internal $ "Unhandled Compile Time Error: \"" <> x <> "\" ;" @@ -89,19 +75,6 @@ getType typename =   asks (typeDefinitions . fst)     >>= selectBy (compileError $ " can't find Type" <> msg typename) typename--customScalarTypes :: TypeName -> [TypeName]-customScalarTypes typeName-  | isNotSystemTypeName typeName = [typeName]-  | otherwise = []--leafType :: TypeDefinition a VALID -> Converter ([ClientTypeDefinition], [TypeName])-leafType TypeDefinition {typeName, typeContent} = fromKind typeContent-  where-    fromKind :: TypeContent TRUE a VALID -> Converter ([ClientTypeDefinition], [TypeName])-    fromKind DataEnum {} = pure ([], [typeName])-    fromKind DataScalar {} = pure ([], customScalarTypes typeName)-    fromKind _ = throwError $ compileError "Invalid schema Expected scalar"  typeFrom :: [FieldName] -> TypeDefinition a VALID -> TypeName typeFrom path TypeDefinition {typeName, typeContent} = __typeFrom typeContent

+ src/Data/Morpheus/Client/Transform/Global.hs view

@@ -0,0 +1,105 @@+{-# 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+  ( ClientConstructorDefinition (..),+    ClientTypeDefinition (..),+    TypeNameTH (..),+  )+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,+    toAny,+  )+import Relude hiding (empty)++toArgumentsType ::+  TypeName ->+  VariableDefinitions RAW ->+  Maybe ClientTypeDefinition+toArgumentsType cName variables+  | null variables = Nothing+  | otherwise =+    Just+      ClientTypeDefinition+        { clientTypeName = TypeNameTH [] cName,+          clientKind = KindInputObject,+          clientCons =+            [ ClientConstructorDefinition+                { cName,+                  cFields = 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 -> [ClientTypeDefinition]+toGlobalDefinitions f Schema {types} =+  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 = TypeNameTH [] typeName,+        clientKind,+        clientCons+      }+  where+    genContent :: TypeContent TRUE ANY VALID -> Maybe (TypeKind, [ClientConstructorDefinition])+    genContent (DataInputObject inputFields) = do+      pure+        ( KindInputObject,+          [ ClientConstructorDefinition+              { cName = typeName,+                cFields = toAny <$> toList inputFields+              }+          ]+        )+    genContent (DataEnum enumTags) = pure (KindEnum, mkConsEnum <$> enumTags)+    genContent DataScalar {} = pure (KindScalar, [])+    genContent _ = Nothing++mkConsEnum :: DataEnumValue s -> ClientConstructorDefinition+mkConsEnum DataEnumValue {enumName} = ClientConstructorDefinition enumName []

− src/Data/Morpheus/Client/Transform/Inputs.hs

@@ -1,170 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Client.Transform.Inputs-  ( renderNonOutputTypes,-    renderOperationArguments,-  )-where--import Data.Morpheus.Client.Internal.Types-  ( ClientConstructorDefinition (..),-    ClientTypeDefinition (..),-    TypeNameTH (..),-  )-import Data.Morpheus.Client.Internal.Utils-  ( removeDuplicates,-  )-import Data.Morpheus.Client.Transform.Core-  ( Converter (..),-    UpdateT (..),-    customScalarTypes,-    getType,-    resolveUpdates,-    typeFrom,-  )-import Data.Morpheus.Internal.Utils-  ( empty,-  )-import Data.Morpheus.Types.Internal.AST-  ( ANY,-    DataEnumValue (DataEnumValue, enumName),-    FieldDefinition (..),-    IN,-    Operation (..),-    RAW,-    TRUE,-    TypeContent (..),-    TypeDefinition (..),-    TypeKind (..),-    TypeName,-    TypeRef (..),-    VALID,-    Variable (..),-    VariableDefinitions,-    getOperationName,-    toAny,-  )-import Relude hiding (empty)--renderArguments ::-  VariableDefinitions RAW ->-  TypeName ->-  Maybe ClientTypeDefinition-renderArguments variables cName-  | null variables = Nothing-  | otherwise = Just rootArgumentsType-  where-    rootArgumentsType :: ClientTypeDefinition-    rootArgumentsType =-      ClientTypeDefinition-        { clientTypeName = TypeNameTH [] cName,-          clientKind = KindInputObject,-          clientCons =-            [ ClientConstructorDefinition-                { cName,-                  cFields = fieldD <$> toList variables-                }-            ]-        }-      where-        fieldD :: Variable RAW -> FieldDefinition ANY VALID-        fieldD Variable {variableName, variableType} =-          FieldDefinition-            { fieldName = variableName,-              fieldContent = Nothing,-              fieldType = variableType,-              fieldDescription = Nothing,-              fieldDirectives = empty-            }--renderOperationArguments ::-  Operation VALID ->-  Converter (Maybe ClientTypeDefinition)-renderOperationArguments Operation {operationName} =-  asks ((`renderArguments` (getOperationName operationName <> "Args")) . snd)---- INPUTS-renderNonOutputTypes ::-  [TypeName] ->-  Converter [ClientTypeDefinition]-renderNonOutputTypes leafTypes = do-  variables <- asks (toList . snd)-  inputTypeRequests <- resolveUpdates [] $ fmap (UpdateT . exploreInputTypeNames . typeConName . variableType) variables-  concat <$> traverse buildInputType (removeDuplicates $ inputTypeRequests <> leafTypes)--exploreInputTypeNames :: TypeName -> [TypeName] -> Converter [TypeName]-exploreInputTypeNames name collected-  | name `elem` collected = pure collected-  | otherwise = getType name >>= scanInpType-  where-    scanInpType TypeDefinition {typeContent, typeName} = scanType typeContent-      where-        scanType (DataInputObject fields) =-          resolveUpdates-            (name : collected)-            (toInputTypeD <$> toList fields)-          where-            toInputTypeD :: FieldDefinition IN VALID -> UpdateT Converter [TypeName]-            toInputTypeD FieldDefinition {fieldType = TypeRef {typeConName}} =-              UpdateT (exploreInputTypeNames typeConName)-        scanType (DataEnum _) = pure (collected <> [typeName])-        scanType (DataScalar _) = pure (collected <> customScalarTypes typeName)-        scanType _ = pure collected--buildInputType ::-  TypeName ->-  Converter [ClientTypeDefinition]-buildInputType name = getType name >>= generateTypes-  where-    generateTypes TypeDefinition {typeName, typeContent} = subTypes typeContent-      where-        subTypes :: TypeContent TRUE ANY VALID -> Converter [ClientTypeDefinition]-        subTypes (DataInputObject inputFields) = do-          fields <- traverse toClientFieldDefinition (toList inputFields)-          pure-            [ mkInputType-                typeName-                KindInputObject-                [ ClientConstructorDefinition-                    { cName = typeName,-                      cFields = fmap toAny fields-                    }-                ]-            ]-        subTypes (DataEnum enumTags) =-          pure-            [ mkInputType-                typeName-                KindEnum-                (fmap mkConsEnum enumTags)-            ]-        subTypes DataScalar {} =-          pure-            [ mkInputType-                typeName-                KindScalar-                []-            ]-        subTypes _ = pure []--mkConsEnum :: DataEnumValue s -> ClientConstructorDefinition-mkConsEnum DataEnumValue {enumName} = ClientConstructorDefinition enumName []--mkInputType :: TypeName -> TypeKind -> [ClientConstructorDefinition] -> ClientTypeDefinition-mkInputType typename clientKind clientCons =-  ClientTypeDefinition-    { clientTypeName = TypeNameTH [] typename,-      clientKind,-      clientCons-    }--toClientFieldDefinition :: FieldDefinition IN VALID -> Converter (FieldDefinition IN VALID)-toClientFieldDefinition FieldDefinition {fieldType, ..} = do-  typeConName <- typeFrom [] <$> getType (typeConName fieldType)-  pure FieldDefinition {fieldType = fieldType {typeConName}, ..}

+ src/Data/Morpheus/Client/Transform/Local.hs view

@@ -0,0 +1,211 @@+{-# 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+  ( ClientConstructorDefinition (..),+    ClientTypeDefinition (..),+    FetchDefinition (..),+    TypeNameTH (..),+  )+import Data.Morpheus.Client.Transform.Core (Converter (..), compileError, deprecationWarning, getType, typeFrom)+import Data.Morpheus.Client.Transform.Global (toArgumentsType)+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 Relude hiding (empty, show)+import Prelude (show)++clientConfig :: Config+clientConfig =+  Config+    { debug = False,+      validationMode = WITHOUT_VARIABLES+    }++toLocalDefinitions ::+  ExecutableDocument ->+  Schema VALID ->+  GQLResult+    ( FetchDefinition,+      [ClientTypeDefinition]+    )+toLocalDefinitions request schema = do+  validOperation <- validateRequest clientConfig schema request+  flip runReaderT (schema, operationArguments $ operation request) $+    runConverter $ genOperation validOperation++genOperation :: Operation VALID -> Converter (FetchDefinition, [ClientTypeDefinition])+genOperation op@Operation {operationName, operationSelection} = do+  (schema, varDefs) <- asks id+  datatype <- getOperationDataType op schema+  let argumentsType = toArgumentsType (getOperationName operationName <> "Args") varDefs+  (rootType :| localTypes) <-+    genLocalTypes+      []+      (getOperationName operationName)+      (toAny datatype)+      operationSelection+  pure+    ( FetchDefinition+        { clientArgumentsTypeName = fmap clientTypeName argumentsType,+          rootTypeName = clientTypeName rootType+        },+      rootType : (localTypes <> maybeToList argumentsType)+    )++-------------------------------------------------------------------------+-- generates selection Object Types+genLocalTypes ::+  [FieldName] ->+  TypeName ->+  TypeDefinition ANY VALID ->+  SelectionSet VALID ->+  Converter (NonEmpty ClientTypeDefinition)+genLocalTypes path tName dataType recordSelSet = do+  (con, subTypes) <- toConstructorDefinition (if null path then [coerce tName] else path) tName dataType recordSelSet+  pure $+    ClientTypeDefinition+      { clientTypeName = TypeNameTH path tName,+        clientCons = [con],+        clientKind = KindObject Nothing+      }+      :| subTypes++toConstructorDefinition ::+  [FieldName] ->+  TypeName ->+  TypeDefinition ANY VALID ->+  SelectionSet VALID ->+  Converter (ClientConstructorDefinition, [ClientTypeDefinition])+toConstructorDefinition path cName datatype selSet = do+  (cFields, subTypes) <- unzip <$> traverse genField (toList selSet)+  pure (ClientConstructorDefinition {cName, cFields}, 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} = do+  toList <$> genLocalTypes path (typeFrom [] dType) dType selectionSet+subTypesBySelection path dType Selection {selectionContent = UnionSelection interface unionSelections} =+  do+    let variants = UnionTag (typeName dType) interface : toList unionSelections+    (clientCons, subTypes) <- unzip <$> traverse (getVariantType path) variants+    pure+      ( ClientTypeDefinition+          { clientTypeName = TypeNameTH path (typeFrom [] dType),+            clientCons,+            clientKind = KindUnion+          } :+        concat subTypes+      )++getVariantType :: [FieldName] -> UnionTag -> Converter (ClientConstructorDefinition, [ClientTypeDefinition])+getVariantType path (UnionTag selectedTyName selectionVariant) = do+  conDatatype <- getType selectedTyName+  toConstructorDefinition 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)

− src/Data/Morpheus/Client/Transform/Selection.hs

@@ -1,233 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Client.Transform.Selection-  ( toClientDefinition,-    ClientDefinition (..),-  )-where--import Control.Monad.Except (MonadError (throwError))-import Data.Morpheus.Client.Internal.Types-  ( ClientConstructorDefinition (..),-    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.Ext-  ( GQLResult,-  )-import Data.Morpheus.Internal.Utils-  ( empty,-    keyOf,-    selectBy,-  )-import Data.Morpheus.Types.Internal.AST-  ( ANY,-    FieldDefinition (..),-    FieldName,-    Operation (..),-    RAW,-    Ref (..),-    Schema (..),-    Selection (..),-    SelectionContent (..),-    SelectionSet,-    TypeContent (..),-    TypeDefinition (..),-    TypeKind (..),-    TypeName,-    TypeRef (..),-    UnionTag (..),-    VALID,-    VariableDefinitions,-    getOperationDataType,-    getOperationName,-    mkTypeRef,-    msg,-    toAny,-  )-import Relude hiding (empty, show)-import Prelude (show)--toClientDefinition ::-  Schema VALID ->-  VariableDefinitions RAW ->-  Operation VALID ->-  GQLResult ClientDefinition-toClientDefinition schema vars = flip runReaderT (schema, vars) . runConverter . genOperation--genOperation :: Operation VALID -> Converter ClientDefinition-genOperation operation = do-  (clientArguments, outputTypes, enums) <- renderOperationType operation-  nonOutputTypes <- renderNonOutputTypes enums-  pure ClientDefinition {clientArguments, clientTypes = outputTypes <> nonOutputTypes}--renderOperationType ::-  Operation VALID ->-  Converter-    ( Maybe ClientTypeDefinition,-      [ClientTypeDefinition],-      [TypeName]-    )-renderOperationType op@Operation {operationName, operationSelection} = do-  datatype <- asks fst >>= getOperationDataType op-  arguments <- renderOperationArguments op-  (outputTypes, enums) <--    genRecordType-      []-      (getOperationName operationName)-      (toAny datatype)-      operationSelection-  pure (arguments, outputTypes, enums)------------------------------------------------------------------------------ generates selection Object Types-genRecordType ::-  [FieldName] ->-  TypeName ->-  TypeDefinition ANY VALID ->-  SelectionSet VALID ->-  Converter ([ClientTypeDefinition], [TypeName])-genRecordType path tName dataType recordSelSet = do-  (con, subTypes, requests) <- genConsD path tName dataType recordSelSet-  pure-    ( ClientTypeDefinition-        { clientTypeName = TypeNameTH path tName,-          clientCons = [con],-          clientKind = KindObject Nothing-        }-        : subTypes,-      requests-    )--genConsD ::-  [FieldName] ->-  TypeName ->-  TypeDefinition ANY VALID ->-  SelectionSet VALID ->-  Converter-    ( ClientConstructorDefinition,-      [ClientTypeDefinition],-      [TypeName]-    )-genConsD path cName datatype selSet = do-  (cFields, subTypes, requests) <- unzip3 <$> traverse genField (toList selSet)-  pure (ClientConstructorDefinition {cName, cFields}, concat subTypes, concat requests)-  where-    genField ::-      Selection VALID ->-      Converter (FieldDefinition ANY VALID, [ClientTypeDefinition], [TypeName])-    genField sel =-      do-        (fieldDataType, fieldType) <--          getFieldType-            fieldPath-            datatype-            sel-        (subTypes, requests) <- subTypesBySelection fieldPath fieldDataType sel-        pure-          ( FieldDefinition-              { fieldName,-                fieldType,-                fieldContent = Nothing,-                fieldDescription = Nothing,-                fieldDirectives = empty-              },-            subTypes,-            requests-          )-      where-        fieldPath = path <> [fieldName]-        --------------------------------        fieldName = keyOf sel---------------------------------------------subTypesBySelection ::-  [FieldName] ->-  TypeDefinition ANY VALID ->-  Selection VALID ->-  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 interface unionSelections} =-  do-    (clientCons, subTypes, requests) <--      unzip3-        <$> traverse-          getUnionType-          ( UnionTag (typeName dType) interface : toList unionSelections-          )-    pure-      ( ClientTypeDefinition-          { clientTypeName = TypeNameTH path (typeFrom [] dType),-            clientCons,-            clientKind = KindUnion-          }-          : concat subTypes,-        concat requests-      )-  where-    getUnionType (UnionTag selectedTyName selectionVariant) = do-      conDatatype <- getType selectedTyName-      genConsD path selectedTyName conDatatype selectionVariant--getFieldType ::-  [FieldName] ->-  TypeDefinition ANY VALID ->-  Selection VALID ->-  Converter (TypeDefinition ANY VALID, TypeRef)-getFieldType-  path-  TypeDefinition {typeContent, typeName}-  Selection-    { selectionName,-      selectionPosition-    }-    | selectionName == "__typename" =-      processDeprecation-        FieldDefinition-          { fieldName = "__typename",-            fieldDescription = Nothing,-            fieldType = mkTypeRef "String",-            fieldDirectives = empty,-            fieldContent = Nothing-          }-    | otherwise = withTypeContent typeContent-    where-      withTypeContent DataObject {objectFields} =-        selectBy selError selectionName objectFields >>= processDeprecation-      withTypeContent DataInterface {interfaceFields} =-        selectBy selError selectionName interfaceFields >>= processDeprecation-      withTypeContent dt =-        throwError (compileError $ "Type should be output Object \"" <> msg (show dt))-      selError = compileError $ "can't find field " <> msg selectionName <> " on type: " <> msg (show typeContent)-      processDeprecation-        FieldDefinition-          { fieldType = alias@TypeRef {typeConName},-            fieldDirectives-          } =-          checkDeprecated *> (trans <$> getType typeConName)-          where-            trans x =-              (x, alias {typeConName = typeFrom path x})-            -------------------------------------------------------------------            checkDeprecated :: Converter ()-            checkDeprecated =-              deprecationWarning-                fieldDirectives-                ( coerce typeName,-                  Ref {refName = selectionName, refPosition = selectionPosition}-                )

test/Case/Enum/Test.hs view

@@ -11,63 +11,46 @@   ) where -import Data.ByteString.Lazy.Char8-  ( ByteString,-  ) import Data.Morpheus.Client-  ( Fetch (..),-    FetchError,-    gql,+  ( declareGlobalTypes,+    declareLocalTypesInline,+    raw,   )+import Relude import Spec.Utils-  ( defineClientWith,-    mockApi,+  ( assertFetch,+    path,   ) import Test.Tasty   ( TestTree,   )-import Test.Tasty.HUnit-  ( assertEqual,-    testCase,-  )-import Prelude-  ( ($),-    Either (..),-    IO,-    String,-  ) -defineClientWith-  "Enum"-  [gql|+declareGlobalTypes (path "Enum/schema.gql")++declareLocalTypesInline+  (path "Enum/schema.gql")+  [raw|     query MyQuery( $inputCity: City!) {       city(city:$inputCity)       cities     }   |] -resolver :: ByteString -> IO ByteString-resolver = mockApi "Enum"--client :: IO (Either (FetchError MyQuery) MyQuery)-client = fetch resolver MyQueryArgs {inputCity = CityAthens}- test :: TestTree-test = testCase "test Enum" $ do-  value <- client-  assertEqual-    "test Enum"+test =+  assertFetch+    "Enum"+    Nothing+    MyQueryArgs {inputCity = CityAthens}     ( Right-        ( MyQuery-            { city = CityAthens,-              cities =-                [ CityAthens,-                  CitySparta,-                  CityCorinth,-                  CityDelphi,-                  CityArgos-                ]-            }-        )+        MyQuery+          { city = CityAthens,+            cities =+              [ CityAthens,+                CitySparta,+                CityCorinth,+                CityDelphi,+                CityArgos+              ]+          }     )-    value

test/Case/Github/Test.hs view

@@ -9,44 +9,25 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Case.Github.Test-  ( testInterface,+  ( test,   ) where -import Data.ByteString.Lazy.Char8-  ( ByteString,-  ) import Data.Morpheus.Client   ( DecodeScalar (..),     EncodeScalar (..),-    Fetch (..),-    FetchError,     ScalarValue (..),-    gql,+    declareGlobalTypesByName,+    declareLocalTypes,   )-import Data.Text (Text)+import Relude import Spec.Utils-  ( defineClientWith,-    mockApi,+  ( assertFetch,+    path,   ) import Test.Tasty   ( TestTree,   )-import Test.Tasty.HUnit-  ( assertEqual,-    testCase,-  )-import Prelude-  ( ($),-    Applicative (..),-    Bool (..),-    Either (..),-    Eq (..),-    IO,-    Maybe (..),-    Show,-    String,-  )  newtype GitTimestamp = GitTimestamp   { unGitTimestamp :: Text@@ -60,86 +41,54 @@ instance EncodeScalar GitTimestamp where   encodeScalar (GitTimestamp x) = String x -defineClientWith-  "Github"-  [gql|-    query GetTags ($user: String!, $repo: String!)-      {-        repository(owner: $user, name: $repo) {-          refs(refPrefix: "refs/tags/", first: 100) {-            pageInfo {-              endCursor-              hasNextPage-            }-            edges {-              cursor-              node {-                name-                target {-                  __typename-                  ... on Tag {-                    tagger {-                      date-                    }-                  }-                }-              }-            }-          }-        }-      }-  |]+declareGlobalTypesByName+  (path "Github/schema.gql")+  ["GitTimestamp"] -resolver :: ByteString -> IO ByteString-resolver = mockApi "Interface"+declareLocalTypes+  (path "Github/schema.gql")+  (path "Github/query.gql") -client :: IO (Either (FetchError GetTags) GetTags)-client =-  fetch-    resolver+test :: TestTree+test =+  assertFetch+    "Github"+    Nothing     GetTagsArgs       { user = "UserName",         repo = "repoName"       }--testInterface :: TestTree-testInterface = testCase "test Github interfaces" $ do-  value <- client-  assertEqual-    "test Github interface"     ( Right-        ( GetTags-            { repository =-                Just-                  RepositoryRepository-                    { refs =-                        Just-                          RepositoryRefsRefConnection-                            { pageInfo =-                                RepositoryRefsPageInfoPageInfo-                                  { endCursor = Just "",-                                    hasNextPage = False-                                  },-                              edges =-                                Just-                                  [ Just-                                      RepositoryRefsEdgesRefEdge-                                        { cursor = "",-                                          node =-                                            Just-                                              RepositoryRefsEdgesNodeRef-                                                { name = "",-                                                  target =-                                                    Just-                                                      RepositoryRefsEdgesNodeTargetGitObject-                                                        { __typename = ""-                                                        }-                                                }-                                        }-                                  ]-                            }-                    }-            }-        )+        GetTags+          { repository =+              Just+                GetTagsRepositoryRepository+                  { refs =+                      Just+                        GetTagsRepositoryRefsRefConnection+                          { pageInfo =+                              GetTagsRepositoryRefsPageInfoPageInfo+                                { endCursor = Just "test value 1",+                                  hasNextPage = False+                                },+                            edges =+                              Just+                                [ Just+                                    GetTagsRepositoryRefsEdgesRefEdge+                                      { cursor = "test cursor",+                                        node =+                                          Just+                                            GetTagsRepositoryRefsEdgesNodeRef+                                              { name = "test name",+                                                target =+                                                  Just+                                                    GetTagsRepositoryRefsEdgesNodeTargetGitObject+                                                      { __typename = "GitObject"+                                                      }+                                              }+                                      }+                                ]+                          }+                  }+          }     )-    value

+ test/Case/Github/query.gql view

@@ -0,0 +1,24 @@+query GetTags($user: String!, $repo: String!) {+  repository(owner: $user, name: $repo) {+    refs(refPrefix: "refs/tags/", first: 100) {+      pageInfo {+        endCursor+        hasNextPage+      }+      edges {+        cursor+        node {+          name+          target {+            __typename+            ... on Tag {+              tagger {+                date+              }+            }+          }+        }+      }+    }+  }+}

test/Case/Github/response.json view

@@ -1,52 +1,23 @@ {   "data": {-    "character": [-      {-        "__typename": "Deity",-        "name": "Deity Name",-        "power": "Deity Power"-      },-      {-        "__typename": "Character",-        "name": "Character Name"-      },-      {-        "__typename": "Hero",-        "name": "Hero Name",-        "hobby": "Deity Power"-      }-    ],-    "character2": [-      {-        "name1": "test name",-        "name": "test name"-      }-    ],-    "character3": [-      {-        "__typename": "Hero",-        "hobby": "Hero Hobby",-        "name2": "Hero name2"-      },-      {-        "__typename": "Deity",-        "name2": "Hero name2"-      },-      {-        "__typename": "Character",-        "name2": "Character name2"-      }-    ],-    "character4": [-      {-        "__typename": "Character",-        "name2": "Character name2"-      },-      {-        "__typename": "Hero",-        "hobby": "Hero Hobby",-        "name2": "Hero name2"+    "repository": {+      "refs": {+        "pageInfo": {+          "endCursor": "test value 1",+          "hasNextPage": false+        },+        "edges": [+          {+            "cursor": "test cursor",+            "node": {+              "name": "test name",+              "target": {+                "__typename": "GitObject"+              }+            }+          }+        ]       }-    ]+    }   } }

test/Case/Interface/Test.hs view

@@ -9,135 +9,83 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Case.Interface.Test-  ( testInterface,+  ( test,   ) where -import Data.ByteString.Lazy.Char8-  ( ByteString,-  ) import Data.Morpheus.Client-  ( Fetch (..),-    FetchError,-    gql,+  ( declareLocalTypes,   )-import Data.Text (Text)+import Relude import Spec.Utils-  ( defineClientWith,-    mockApi,+  ( assertFetch,+    path,   ) import Test.Tasty   ( TestTree,   )-import Test.Tasty.HUnit-  ( assertEqual,-    testCase,-  )-import Prelude-  ( ($),-    Either (..),-    IO,-    String,-  ) -defineClientWith-  "Interface"-  [gql|-    query MyQuery {-      character {-        name-        ... on Deity {-              power-        }--        ... on Hero {-              hobby-        }-      }-      character2: character {-        name1: name-        name-      }-      character3: character {-        ... on Hero {-              hobby-        }-        ... on Character {-              name2: name-        }-      }-      character4: character {-        ... on Hero {-          hobby-        }-      }-    }-  |]--resolver :: ByteString -> IO ByteString-resolver = mockApi "Interface"--client :: IO (Either (FetchError MyQuery) MyQuery)-client = fetch resolver ()+declareLocalTypes+  (path "Interface/schema.gql")+  (path "Interface/query.gql") -testInterface :: TestTree-testInterface = testCase "test interfaces" $ do-  value <- client-  assertEqual-    "test interface"+test :: TestTree+test =+  assertFetch+    "Interface"+    Nothing+    ()     ( Right-        ( MyQuery-            { character =-                [ CharacterDeity-                    { __typename = "Deity",-                      name = "Deity Name",-                      power = "Deity Power"-                    },-                  CharacterCharacter-                    { __typename = "Character",-                      name = "Character Name"-                    },-                  CharacterHero-                    { __typename = "Hero",-                      name = "Hero Name",-                      hobby = "Deity Power"-                    }-                ],-              character2 =-                [ Character2Character-                    { __typename = "Character",-                      name1 = "test name",-                      name = "test name"-                    }-                ],-              character3 =-                [ Character3Hero-                    { __typename = "Hero",-                      hobby = "Hero Hobby",-                      name2 = "Hero name2"-                    },-                  Character3Character-                    { __typename = "Deity",-                      name2 = "Hero name2"-                    },-                  Character3Character-                    { __typename = "Character",-                      name2 = "Character name2"-                    }-                ],-              character4 =-                [ Character4Character-                    { __typename = "Character"-                    },-                  Character4Hero-                    { __typename = "Hero",-                      hobby = "Hero Hobby"-                    },-                  Character4Character-                    { __typename = "Deity"-                    }-                ]-            }-        )+        MyQuery+          { character =+              [ MyQueryCharacterDeity+                  { __typename = "Deity",+                    name = "Deity Name",+                    power = "Deity Power"+                  },+                MyQueryCharacterCharacter+                  { __typename = "Character",+                    name = "Character Name"+                  },+                MyQueryCharacterHero+                  { __typename = "Hero",+                    name = "Hero Name",+                    hobby = "Deity Power"+                  }+              ],+            character2 =+              [ MyQueryCharacter2Character+                  { __typename = "Character",+                    name1 = "test name",+                    name = "test name"+                  }+              ],+            character3 =+              [ MyQueryCharacter3Hero+                  { __typename = "Hero",+                    hobby = "Hero Hobby",+                    name2 = "Hero name2"+                  },+                MyQueryCharacter3Character+                  { __typename = "Deity",+                    name2 = "Hero name2"+                  },+                MyQueryCharacter3Character+                  { __typename = "Character",+                    name2 = "Character name2"+                  }+              ],+            character4 =+              [ MyQueryCharacter4Character+                  { __typename = "Character"+                  },+                MyQueryCharacter4Hero+                  { __typename = "Hero",+                    hobby = "Hero Hobby"+                  },+                MyQueryCharacter4Character+                  { __typename = "Deity"+                  }+              ]+          }     )-    value

+ test/Case/Interface/query.gql view

@@ -0,0 +1,29 @@+query MyQuery {+  character {+    name+    ... on Deity {+      power+    }++    ... on Hero {+      hobby+    }+  }+  character2: character {+    name1: name+    name+  }+  character3: character {+    ... on Hero {+      hobby+    }+    ... on Character {+      name2: name+    }+  }+  character4: character {+    ... on Hero {+      hobby+    }+  }+}

− test/Case/JSON/Custom/Errors.hs

@@ -1,89 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Case.JSON.Custom.Errors-  ( test,-  )-where--import Data.ByteString.Lazy.Char8-  ( ByteString,-  )-import Data.List.NonEmpty-  ( NonEmpty (..),-  )-import Data.Morpheus.Client-  ( EncodeScalar (..),-    Fetch (..),-    FetchError (..),-    ScalarValue (..),-    gql,-  )-import Data.Morpheus.Types.Internal.AST-  ( Position (..),-    at,-    withPath, PropName (PropIndex),-  )-import Data.Text (Text)-import Spec.Utils-  ( defineClientWithJSON,-    mockApi,-  )-import Test.Tasty-  ( TestTree,-  )-import Test.Tasty.HUnit-  ( assertEqual,-    testCase,-  )-import Prelude-  ( Either (..),-    Eq (..),-    IO,-    Maybe (..),-    Show,-    ($),-  )--newtype GitTimestamp = GitTimestamp-  { unGitTimestamp :: Text-  }-  deriving (Eq, Show)--instance EncodeScalar GitTimestamp where-  encodeScalar (GitTimestamp x) = String x--defineClientWithJSON-  "JSON/Custom"-  [gql|-    query TestQuery-      {-        queryTypeName-      }-  |]--resolver :: ByteString -> IO ByteString-resolver = mockApi "JSON/Custom/Errors"--client :: IO (Either (FetchError TestQuery) TestQuery)-client = fetch resolver ()--test :: TestTree-test = testCase "test Errors" $ do-  value <- client-  assertEqual-    "test custom Errors"-    ( Left-        ( FetchErrorProducedErrors-            (("Failure" `at` Position {line = 3, column = 7}) `withPath` ["queryTypeName", PropIndex 0] :| [])-            (Just TestQuery {queryTypeName = Just "TestQuery"})-        )-    )-    value

− test/Case/JSON/Custom/Errors/response.json

@@ -1,17 +0,0 @@-{-  "data": {-    "queryTypeName": "TestQuery"-  },-  "errors": [-    {-      "locations": [-        {-          "line": 3,-          "column": 7-        }-      ],-      "path": ["queryTypeName", 0],-      "message": "Failure"-    }-  ]-}

− test/Case/JSON/Custom/ErrorsWithType.hs

@@ -1,90 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Case.JSON.Custom.ErrorsWithType-  ( test,-  )-where--import Data.ByteString.Lazy.Char8-  ( ByteString,-  )-import Data.List.NonEmpty-  ( NonEmpty (..),-  )-import Data.Morpheus.Client-  ( EncodeScalar (..),-    Fetch (..),-    FetchError (..),-    ScalarValue (..),-    gql,-  )-import Data.Morpheus.Types.Internal.AST-  ( Position (..),-    at,-    custom,-    withPath,-  )-import Data.Text (Text)-import Spec.Utils-  ( defineClientWithJSON,-    mockApi,-  )-import Test.Tasty-  ( TestTree,-  )-import Test.Tasty.HUnit-  ( assertEqual,-    testCase,-  )-import Prelude-  ( ($),-    Either (..),-    Eq (..),-    IO,-    Maybe (..),-    Show,-  )--newtype GitTimestamp = GitTimestamp-  { unGitTimestamp :: Text-  }-  deriving (Eq, Show)--instance EncodeScalar GitTimestamp where-  encodeScalar (GitTimestamp x) = String x--defineClientWithJSON-  "JSON/Custom"-  [gql|-    query TestQuery-      {-        queryTypeName-      }-  |]--resolver :: ByteString -> IO ByteString-resolver = mockApi "JSON/Custom/ErrorsWithType"--client :: IO (Either (FetchError TestQuery) TestQuery)-client = fetch resolver ()--test :: TestTree-test = testCase "test Errors With Type" $ do-  value <- client-  assertEqual-    "test custom Errors"-    ( Left-        ( FetchErrorProducedErrors-            (("Failure" `at` Position {line = 3, column = 7}) `withPath` ["queryTypeName"] `custom` "QUERY_BAD" :| [])-            (Just TestQuery {queryTypeName = Just "TestQuery"})-        )-    )-    value

− test/Case/JSON/Custom/ErrorsWithType/response.json

@@ -1,20 +0,0 @@-{-  "data": {-    "queryTypeName": "TestQuery"-  },-  "errors": [-    {-      "type": "QUERY_BAD",-      "locations": [-        {-          "line": 3,-          "column": 7-        }-      ],-      "path": [-        "queryTypeName"-      ],-      "message": "Failure"-    }-  ]-}

− test/Case/JSON/Custom/Mutation.hs

@@ -1,70 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Case.JSON.Custom.Mutation-  ( test,-  )-where--import Data.ByteString.Lazy.Char8-  ( ByteString,-  )-import Data.Morpheus.Client-  ( Fetch (..),-    FetchError,-    gql,-  )-import Data.Text (Text)-import Spec.Utils-  ( defineClientWithJSON,-    mockApi,-  )-import Test.Tasty-  ( TestTree,-  )-import Test.Tasty.HUnit-  ( assertEqual,-    testCase,-  )-import Prelude-  ( ($),-    Either (..),-    IO,-    Maybe (..),-    String,-  )--defineClientWithJSON-  "JSON/Custom"-  [gql|-    mutation TestMutation-      {-        mutationTypeName-      }-  |]--resolver :: ByteString -> IO ByteString-resolver = mockApi "JSON/Custom/Mutation"--client :: IO (Either (FetchError TestMutation) TestMutation)-client = fetch resolver ()--test :: TestTree-test = testCase "test Mutation" $ do-  value <- client-  assertEqual-    "test custom Mutation"-    ( Right-        ( TestMutation-            { mutationTypeName = Just "TestMutation"-            }-        )-    )-    value

− test/Case/JSON/Custom/Mutation/response.json

@@ -1,5 +0,0 @@-{-  "data": {-    "mutationTypeName": "TestMutation"-  }-}

− test/Case/JSON/Custom/NoResponseOrError.hs

@@ -1,76 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Case.JSON.Custom.NoResponseOrError-  ( test,-  )-where--import Data.ByteString.Lazy.Char8-  ( ByteString,-  )-import Data.Morpheus.Client-  ( EncodeScalar (..),-    Fetch (..),-    FetchError (..),-    ScalarValue (..),-    gql,-  )-import Data.Text (Text)-import Spec.Utils-  ( defineClientWithJSON,-    mockApi,-  )-import Test.Tasty-  ( TestTree,-  )-import Test.Tasty.HUnit-  ( assertEqual,-    testCase,-  )-import Prelude-  ( Either (..),-    Eq (..),-    IO,-    Show,-    ($),-  )--newtype GitTimestamp = GitTimestamp-  { unGitTimestamp :: Text-  }-  deriving (Eq, Show)--instance EncodeScalar GitTimestamp where-  encodeScalar (GitTimestamp x) = String x--defineClientWithJSON-  "JSON/Custom"-  [gql|-    query TestQuery-      {-        queryTypeName-      }-  |]--resolver :: ByteString -> IO ByteString-resolver = mockApi "JSON/Custom/NoResponseOrError"--client :: IO (Either (FetchError TestQuery) TestQuery)-client = fetch resolver ()--test :: TestTree-test = testCase "test NoResponseOrError" $ do-  value <- client-  assertEqual-    "test custom NoResponseOrError"-    ( Left FetchErrorNoResult-    )-    value

− test/Case/JSON/Custom/NoResponseOrError/response.json

@@ -1,1 +0,0 @@-{}

− test/Case/JSON/Custom/PartialResponse.hs

@@ -1,78 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Case.JSON.Custom.PartialResponse-  ( test,-  )-where--import Data.ByteString.Lazy.Char8-  ( ByteString,-  )-import Data.Morpheus.Client-  ( EncodeScalar (..),-    Fetch (..),-    FetchError (..),-    ScalarValue (..),-    gql,-  )-import Data.Text (Text)-import Spec.Utils-  ( defineClientWithJSON,-    mockApi,-  )-import Test.Tasty-  ( TestTree,-  )-import Test.Tasty.HUnit-  ( assertEqual,-    testCase,-  )-import Prelude-  ( Either (..),-    Eq (..),-    IO,-    Show,-    String,-    ($),-  )--newtype GitTimestamp = GitTimestamp-  { unGitTimestamp :: Text-  }-  deriving (Eq, Show)--instance EncodeScalar GitTimestamp where-  encodeScalar (GitTimestamp x) = String x--defineClientWithJSON-  "JSON/Custom"-  [gql|-    query TestQuery-      {-        queryTypeName-      }-  |]--resolver :: ByteString -> IO ByteString-resolver = mockApi "JSON/Custom/PartialResponse"--client :: IO (Either (FetchError TestQuery) TestQuery)-client = fetch resolver ()--test :: TestTree-test = testCase "test PartialResponse" $ do-  value <- client-  assertEqual-    "test custom PartialResponse"-    ( Left-        (FetchErrorParseFailure "Error in $.data.queryTypeName: parsing Text failed, expected String, but encountered Number")-    )-    value

− test/Case/JSON/Custom/PartialResponse/response.json

@@ -1,6 +0,0 @@-{-  "data": {-    "queryTypeName": 1-  },-  "errors": []-}

− test/Case/JSON/Custom/Query.hs

@@ -1,82 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Case.JSON.Custom.Query-  ( test,-  )-where--import Data.ByteString.Lazy.Char8-  ( ByteString,-  )-import Data.Morpheus.Client-  ( EncodeScalar (..),-    Fetch (..),-    FetchError,-    ScalarValue (..),-    gql,-  )-import Data.Text (Text)-import Spec.Utils-  ( defineClientWithJSON,-    mockApi,-  )-import Test.Tasty-  ( TestTree,-  )-import Test.Tasty.HUnit-  ( assertEqual,-    testCase,-  )-import Prelude-  ( ($),-    Either (..),-    Eq (..),-    IO,-    Maybe (..),-    Show,-    String,-  )--newtype GitTimestamp = GitTimestamp-  { unGitTimestamp :: Text-  }-  deriving (Eq, Show)--instance EncodeScalar GitTimestamp where-  encodeScalar (GitTimestamp x) = String x--defineClientWithJSON-  "JSON/Custom"-  [gql|-    query TestQuery-      {-        queryTypeName-      }-  |]--resolver :: ByteString -> IO ByteString-resolver = mockApi "JSON/Custom/Query"--client :: IO (Either (FetchError TestQuery) TestQuery)-client = fetch resolver ()--test :: TestTree-test = testCase "test Query" $ do-  value <- client-  assertEqual-    "test custom Query"-    ( Right-        ( TestQuery-            { queryTypeName = Just "TestQuery"-            }-        )-    )-    value

− test/Case/JSON/Custom/Query/response.json

@@ -1,5 +0,0 @@-{-  "data": {-    "queryTypeName": "TestQuery"-  }-}

− test/Case/JSON/Custom/Subscription.hs

@@ -1,71 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Case.JSON.Custom.Subscription-  ( test,-  )-where--import Data.ByteString.Lazy.Char8-  ( ByteString,-  )-import Data.Morpheus.Client-  ( Fetch (..),-    FetchError,-    gql,-  )-import Data.Text (Text)-import Spec.Utils-  ( defineClientWithJSON,-    mockApi,-  )-import Test.Tasty-  ( TestTree,-  )-import Test.Tasty.HUnit-  ( assertEqual,-    testCase,-  )-import Prelude-  ( ($),-    Either (..),-    IO,-    Maybe (..),-    String,-  )--defineClientWithJSON-  "JSON/Custom"-  [gql|-    subscription TestSubscription-      {-        subscriptionTypeName-      }-  |]--resolver :: ByteString -> IO ByteString-resolver = mockApi "JSON/Custom/Subscription"--client :: IO (Either (FetchError TestSubscription) TestSubscription)-client = fetch resolver ()--test :: TestTree-test = testCase "test Subscription" $ do-  value <- client-  assertEqual-    "test custom Subscription"-    ( Right-        ( TestSubscription-            { subscriptionTypeName =-                Just "TestSubscription"-            }-        )-    )-    value

− test/Case/JSON/Custom/Subscription/response.json

@@ -1,5 +0,0 @@-{-  "data": {-    "subscriptionTypeName": "TestSubscription"-  }-}

− test/Case/JSON/Custom/schema.json

@@ -1,70 +0,0 @@-{-  "data": {-    "__schema": {-      "queryType": {-        "name": "CustomQueryType"-      },-      "mutationType": {-        "name": "CustomMutationType"-      },-      "subscriptionType": {-        "name": "CustomSubscriptionType"-      },-      "types": [-        {-          "kind": "OBJECT",-          "name": "CustomQueryType",-          "fields": [-            {-              "name": "queryTypeName",-              "args": [],-              "type": {-                "kind": "SCALAR",-                "name": "String"-              },-              "isDeprecated": false-            }-          ],-          "interfaces": []-        },-        {-          "kind": "OBJECT",-          "name": "CustomMutationType",-          "fields": [-            {-              "name": "mutationTypeName",-              "args": [],-              "type": {-                "kind": "SCALAR",-                "name": "String"-              },-              "isDeprecated": false-            }-          ],-          "interfaces": []-        },-        {-          "kind": "OBJECT",-          "name": "CustomSubscriptionType",-          "fields": [-            {-              "name": "subscriptionTypeName",-              "args": [],-              "type": {-                "kind": "SCALAR",-                "name": "String"-              },-              "isDeprecated": false-            }-          ],-          "interfaces": []-        },-        {-          "kind": "SCALAR",-          "name": "String"-        }-      ],-      "directives": []-    }-  }-}

+ test/Case/LocalGlobal/Api.hs view

@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Case.LocalGlobal.Api+  ( schema,+    loc,+  )+where++import Relude+import Spec.Utils+  ( path,+  )++loc :: FilePath -> FilePath+loc x = path ("LocalGlobal/" <> x)++schema :: FilePath+schema = loc "schema.gql"

+ test/Case/LocalGlobal/Test.hs view

@@ -0,0 +1,116 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Case.LocalGlobal.Test+  ( test,+  )+where++import Case.LocalGlobal.Api+import Data.Aeson+import Data.Morpheus.Client+  ( Fetch (..),+    ID,+    declareGlobalTypes,+    declareLocalTypes,+    declareLocalTypesInline,+    raw,+  )+import Relude+import Spec.Utils+  ( assertFetch,+  )+import Test.Tasty+  ( TestTree,+    testGroup,+  )++declareGlobalTypes schema++declareLocalTypesInline+  schema+  [raw|+    query GetCities ( $inputCity: City!) {+      city(city:$inputCity)+      cities+    }+  |]++declareLocalTypes schema (loc "users1.gql")+declareLocalTypes schema (loc "users2.gql")++checkQuery ::+  ( Fetch a,+    FromJSON a,+    Eq a,+    Show a+  ) =>+  FilePath ->+  Args a ->+  a ->+  TestTree+checkQuery x args v =+  assertFetch+    "LocalGlobal"+    (Just x)+    args+    (Right v)++checkCities :: TestTree+checkCities =+  checkQuery+    "cities"+    GetCitiesArgs {inputCity = CityAthens}+    GetCities+      { city = CityAthens,+        cities =+          [ CityAthens,+            CitySparta,+            CityCorinth,+            CityDelphi+          ]+      }++checkUsers1 :: TestTree+checkUsers1 =+  checkQuery+    "users1"+    GetUsers1Args {user = UserInput {name = "odysseus"}}+    GetUsers1+      { user =+          Just+            ( GetUsers1UserUser+                { name = "Odysseus",+                  home = Just CityIthaca+                }+            )+      }++checkUsers2 :: TestTree+checkUsers2 =+  checkQuery+    "users2"+    GetUsers2Args {user = UserInput {name = "odysseus"}}+    GetUsers2+      { user =+          Just+            ( GetUsers2UserUser+                { name = "Morpheus"+                }+            )+      }++test :: TestTree+test =+  testGroup+    "Local/Global"+    [ checkCities,+      checkUsers1,+      checkUsers2+    ]

+ test/Case/LocalGlobal/cities.json view

@@ -0,0 +1,6 @@+{+  "data": {+    "city": "Athens",+    "cities": ["Athens", "Sparta", "Corinth", "delphi"]+  }+}

+ test/Case/LocalGlobal/schema.gql view

@@ -0,0 +1,23 @@+enum City {+  Athens+  Sparta+  Corinth+  delphi+  Argos+  Ithaca+}++input UserInput {+  name: ID!+}++type User {+  name: String!+  home: City+}++type Query {+  user(user: UserInput): User+  city(city: City!): City!+  cities: [City!]!+}

+ test/Case/LocalGlobal/users1.gql view

@@ -0,0 +1,6 @@+query GetUsers1($user: UserInput!) {+  user(user: $user) {+    name+    home+  }+}

+ test/Case/LocalGlobal/users1.json view

@@ -0,0 +1,8 @@+{+  "data": {+    "user": {+      "name": "Odysseus",+      "home": "Ithaca"+    }+  }+}

+ test/Case/LocalGlobal/users2.gql view

@@ -0,0 +1,5 @@+query GetUsers2($user: UserInput!) {+  user(user: $user) {+    name+  }+}

+ test/Case/LocalGlobal/users2.json view

@@ -0,0 +1,7 @@+{+  "data": {+    "user": {+      "name": "Morpheus"+    }+  }+}

test/Case/LowercaseTypeName/Test.hs view

@@ -9,43 +9,26 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Case.LowercaseTypeName.Test-  ( testLowercaseTypeName,+  ( test,   ) where -import Control.Applicative (pure)-import Data.ByteString.Lazy.Char8-  ( ByteString,-  ) import Data.Morpheus.Client   ( DecodeScalar (..),     EncodeScalar (..),-    Fetch (..),-    FetchError(..),     ScalarValue (..),-    gql,+    declareGlobalTypes,+    declareLocalTypesInline,+    raw,   )-import Data.Text (Text)+import Relude import Spec.Utils-  ( defineClientWith,-    mockApi,+  ( assertFetch,+    path,   ) import Test.Tasty   ( TestTree,   )-import Test.Tasty.HUnit-  ( assertEqual,-    testCase,-  )-import Prelude-  ( ($),-    (.),-    Either (..),-    Eq,-    IO,-    Show,-    String,-  )  newtype Uuid = Uuid   { uuid :: Text@@ -59,9 +42,11 @@   decodeScalar (String x) = pure (Uuid x)   decodeScalar _ = Left "not valid uid" -defineClientWith-  "LowercaseTypeName"-  [gql|+declareGlobalTypes (path "LowercaseTypeName/schema.gql")++declareLocalTypesInline+  (path "LowercaseTypeName/schema.gql")+  [raw|     query MyQuery {       user(id: "11343135") {         id@@ -69,24 +54,17 @@     }   |] -resolver :: ByteString -> IO ByteString-resolver = mockApi "LowercaseTypeName"--client :: IO (Either (FetchError MyQuery) MyQuery)-client = fetch resolver ()--testLowercaseTypeName :: TestTree-testLowercaseTypeName = testCase "test lowercase type names" $ do-  value <- client-  assertEqual-    "test interface"+test :: TestTree+test =+  assertFetch+    "LowercaseTypeName"+    Nothing+    ()     ( Right-        ( MyQuery-            { user =-                UserUser-                  { id = Uuid "11343135"-                  }-            }-        )+        MyQuery+          { user =+              MyQueryUserUser+                { id = Uuid "11343135"+                }+          }     )-    value

+ test/Case/ResponseTypes/Test.hs view

@@ -0,0 +1,202 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Case.ResponseTypes.Test+  ( test,+  )+where++import Data.Aeson (FromJSON)+import Data.Morpheus.Client+  ( EncodeScalar (..),+    Fetch (..),+    FetchError (..),+    ScalarValue (..),+    declareLocalTypesInline,+    raw,+  )+import Data.Morpheus.Types.Internal.AST+  ( Position (..),+    PropName (PropIndex),+    at,+    custom,+    withPath,+  )+import Relude+import Spec.Utils+  ( assertFetch,+    path,+  )+import Test.Tasty+  ( TestTree,+    testGroup,+  )++newtype GitTimestamp = GitTimestamp+  { unGitTimestamp :: Text+  }+  deriving (Eq, Show)++instance EncodeScalar GitTimestamp where+  encodeScalar (GitTimestamp x) = String x++type Res a = Either (FetchError a) a++declareLocalTypesInline+  (path "ResponseTypes/schema.json")+  [raw| +    query SimpleQuery +      { queryTypeName +      }+  |]++simpleQuery :: Res SimpleQuery+simpleQuery =+  Right+    SimpleQuery+      { queryTypeName = Just "TestQuery"+      }++declareLocalTypesInline+  (path "ResponseTypes/schema.json")+  [raw|+    query PartialResponse+      { queryTypeName+      }+  |]++partialResponse :: Res PartialResponse+partialResponse =+  Left+    ( FetchErrorParseFailure+        "Error in $.data.queryTypeName: parsing Text failed, expected String, but encountered Number"+    )++declareLocalTypesInline+  (path "ResponseTypes/schema.json")+  [raw|+    query NoResponseOrError+      {+        queryTypeName+      }+  |]++noResponseOrError :: Res NoResponseOrError+noResponseOrError = Left FetchErrorNoResult++declareLocalTypesInline+  (path "ResponseTypes/schema.json")+  [raw|+    mutation SimpleMutation+      {+        mutationTypeName+      }+  |]++simpleMutation :: Either a SimpleMutation+simpleMutation =+  Right+    ( SimpleMutation+        { mutationTypeName = Just "TestMutation"+        }+    )++declareLocalTypesInline+  (path "ResponseTypes/schema.json")+  [raw|+    subscription SimpleSubscription+      {+        subscriptionTypeName+      }+  |]++simpleSubscription :: Res SimpleSubscription+simpleSubscription =+  Right+    ( SimpleSubscription+        { subscriptionTypeName =+            Just "TestSubscription"+        }+    )++declareLocalTypesInline+  (path "ResponseTypes/schema.json")+  [raw|+    query ErrorsWithType+      {+        queryTypeName+      }+  |]++errorsWithType :: Res ErrorsWithType+errorsWithType =+  Left+    ( FetchErrorProducedErrors+        ( ("Failure" `at` Position {line = 3, column = 7})+            `withPath` ["queryTypeName"]+            `custom` "QUERY_BAD" :| []+        )+        (Just ErrorsWithType {queryTypeName = Just "TestQuery"})+    )++declareLocalTypesInline+  (path "ResponseTypes/schema.json")+  [raw|+    query TestErrorsQuery+      {+        queryTypeName+      }+  |]++testErrorsQuery :: Res TestErrorsQuery+testErrorsQuery =+  Left+    ( FetchErrorProducedErrors+        ( ("Failure" `at` Position {line = 3, column = 7})+            `withPath` [ "queryTypeName",+                         PropIndex 0+                       ]+              :| []+        )+        ( Just+            TestErrorsQuery+              { queryTypeName = Just "TestQuery"+              }+        )+    )++check ::+  ( Args a ~ (),+    Fetch a,+    FromJSON a,+    Eq a,+    Show a+  ) =>+  FilePath ->+  Res a ->+  TestTree+check name =+  assertFetch+    "ResponseTypes"+    (Just name)+    ()++test :: TestTree+test =+  testGroup+    "Response Types"+    [ check "query" simpleQuery,+      check "partialResponse" partialResponse,+      check "noResponseOrError" noResponseOrError,+      check "mutation" simpleMutation,+      check "subscription" simpleSubscription,+      check "errorsWithType" errorsWithType,+      check "errors" testErrorsQuery+    ]

+ test/Case/ResponseTypes/errors.json view

@@ -0,0 +1,17 @@+{+  "data": {+    "queryTypeName": "TestQuery"+  },+  "errors": [+    {+      "locations": [+        {+          "line": 3,+          "column": 7+        }+      ],+      "path": ["queryTypeName", 0],+      "message": "Failure"+    }+  ]+}

+ test/Case/ResponseTypes/errorsWithType.json view

@@ -0,0 +1,20 @@+{+  "data": {+    "queryTypeName": "TestQuery"+  },+  "errors": [+    {+      "type": "QUERY_BAD",+      "locations": [+        {+          "line": 3,+          "column": 7+        }+      ],+      "path": [+        "queryTypeName"+      ],+      "message": "Failure"+    }+  ]+}

+ test/Case/ResponseTypes/mutation.json view

@@ -0,0 +1,5 @@+{+  "data": {+    "mutationTypeName": "TestMutation"+  }+}

+ test/Case/ResponseTypes/noResponseOrError.json view

@@ -0,0 +1,1 @@+{}

+ test/Case/ResponseTypes/partialResponse.json view

@@ -0,0 +1,6 @@+{+  "data": {+    "queryTypeName": 1+  },+  "errors": []+}

+ test/Case/ResponseTypes/query.json view

@@ -0,0 +1,5 @@+{+  "data": {+    "queryTypeName": "TestQuery"+  }+}

+ test/Case/ResponseTypes/schema.json view

@@ -0,0 +1,70 @@+{+  "data": {+    "__schema": {+      "queryType": {+        "name": "CustomQueryType"+      },+      "mutationType": {+        "name": "CustomMutationType"+      },+      "subscriptionType": {+        "name": "CustomSubscriptionType"+      },+      "types": [+        {+          "kind": "OBJECT",+          "name": "CustomQueryType",+          "fields": [+            {+              "name": "queryTypeName",+              "args": [],+              "type": {+                "kind": "SCALAR",+                "name": "String"+              },+              "isDeprecated": false+            }+          ],+          "interfaces": []+        },+        {+          "kind": "OBJECT",+          "name": "CustomMutationType",+          "fields": [+            {+              "name": "mutationTypeName",+              "args": [],+              "type": {+                "kind": "SCALAR",+                "name": "String"+              },+              "isDeprecated": false+            }+          ],+          "interfaces": []+        },+        {+          "kind": "OBJECT",+          "name": "CustomSubscriptionType",+          "fields": [+            {+              "name": "subscriptionTypeName",+              "args": [],+              "type": {+                "kind": "SCALAR",+                "name": "String"+              },+              "isDeprecated": false+            }+          ],+          "interfaces": []+        },+        {+          "kind": "SCALAR",+          "name": "String"+        }+      ],+      "directives": []+    }+  }+}

+ test/Case/ResponseTypes/subscription.json view

@@ -0,0 +1,5 @@+{+  "data": {+    "subscriptionTypeName": "TestSubscription"+  }+}

test/Case/Scalar/Test.hs view

@@ -11,39 +11,22 @@   ) where -import Data.ByteString.Lazy.Char8-  ( ByteString,-  ) import Data.Morpheus.Client-  ( Fetch (..),-    FetchError (..),-    gql,+  ( declareLocalTypesInline,+    raw,   )-import Data.Text (Text)+import Relude import Spec.Utils-  ( defineClientWith,-    mockApi,+  ( assertFetch,+    path,   ) import Test.Tasty   ( TestTree,   )-import Test.Tasty.HUnit-  ( assertEqual,-    testCase,-  )-import Prelude-  ( ($),-    Bool (True),-    Double,-    Either (..),-    IO,-    Int,-    String,-  ) -defineClientWith-  "Scalar"-  [gql|+declareLocalTypesInline+  (path "Scalar/schema.gql")+  [raw|     query MyQuery(       $inputBoolean: Boolean!       $inputInt: Int!@@ -57,9 +40,6 @@     }   |] -resolver :: ByteString -> IO ByteString-resolver = mockApi "Scalar"- -- GraphQL Boolean types must be represented with Haskell Bool types testBoolean :: Bool testBoolean = True@@ -76,29 +56,22 @@ testText :: Text testText = "Athens" -client :: IO (Either (FetchError MyQuery) MyQuery)-client =-  fetch-    resolver+test :: TestTree+test =+  assertFetch+    "Scalar"+    Nothing     MyQueryArgs       { inputBoolean = testBoolean,         inputInt = testInt,         inputFloat = testFloat,         inputString = testText       }--test :: TestTree-test = testCase "test Scalar" $ do-  value <- client-  assertEqual-    "test Scalar"     ( Right-        ( MyQuery-            { booleanResolver = testBoolean,-              intResolver = testInt,-              floatResolver = testFloat,-              stringResolver = testText-            }-        )+        MyQuery+          { booleanResolver = testBoolean,+            intResolver = testInt,+            floatResolver = testFloat,+            stringResolver = testText+          }     )-    value

test/Spec.hs view

@@ -7,41 +7,31 @@ where  import qualified Case.Enum.Test as Enum-import Case.Interface.Test (testInterface)-import qualified Case.JSON.Custom.Errors as JSONCustomErrors-import qualified Case.JSON.Custom.ErrorsWithType as JSONCustomErrorsWithType-import qualified Case.JSON.Custom.NoResponseOrError as JSONNoResponseOrError-import qualified Case.JSON.Custom.Mutation as JSONCustomMutation-import qualified Case.JSON.Custom.PartialResponse as JSONCustomPartialResponse-import qualified Case.JSON.Custom.Query as JSONCustomQuery-import qualified Case.JSON.Custom.Subscription as JSONCustomSubscription-import Case.LowercaseTypeName.Test-  ( testLowercaseTypeName,-  )+import qualified Case.Github.Test as Github+import qualified Case.Interface.Test as Interface+import qualified Case.LocalGlobal.Test as LocalGlobal+import qualified Case.LowercaseTypeName.Test as LowercaseTypeName+import qualified Case.ResponseTypes.Test as ResponseTypes import qualified Case.Scalar.Test as Scalar import Test.Tasty   ( defaultMain,     testGroup,   ) import Prelude-  ( ($),-    IO,+  ( IO,+    ($),   )  main :: IO () main =   defaultMain $     testGroup-      "client tests"-      [ testInterface,-        testLowercaseTypeName,+      "Client tests"+      [ Interface.test,+        LowercaseTypeName.test,+        LocalGlobal.test,         Enum.test,         Scalar.test,-        JSONCustomErrors.test,-        JSONCustomErrorsWithType.test,-        JSONCustomMutation.test,-        JSONCustomPartialResponse.test,-        JSONCustomQuery.test,-        JSONCustomSubscription.test,-        JSONNoResponseOrError.test+        ResponseTypes.test,+        Github.test       ]

test/Spec/Utils.hs view

@@ -3,66 +3,51 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Spec.Utils-  ( mockApi,-    defineClientWith,-    defineClientWithJSON,+  ( path,+    assertFetch,   ) where +import Data.Aeson (FromJSON) import qualified Data.ByteString.Lazy as L (readFile) import Data.ByteString.Lazy.Char8 (ByteString)-import Data.Functor ((<$>)) import Data.Morpheus.Client-  ( defineByDocumentFile,-    defineByIntrospectionFile,-  )-import Data.Morpheus.Types.Internal.AST-  ( ExecutableDocument,-    FieldName,-    unpackName,+  ( Fetch (..),+    FetchError,   )-import Data.Semigroup ((<>))-import qualified Data.Text as T-import Language.Haskell.TH-  ( Dec,-    Q,-    runIO,+import Relude hiding (ByteString, exp)+import Test.Tasty+  ( TestTree,   )-import System.Directory (doesFileExist)-import Prelude-  ( Bool (..),-    FilePath,-    IO,-    String,+import Test.Tasty.HUnit+  ( assertEqual,+    testCase,   ) -path :: FieldName -> FilePath-path name = "test/Case/" <> T.unpack (unpackName name)+path :: FilePath -> FilePath+path name = "test/Case/" <> name -withProject :: FilePath -> FilePath-withProject = ("morpheus-graphql-client/" <>)+getFile :: FilePath -> IO ByteString+getFile p = L.readFile (path p) -mockApi :: FieldName -> ByteString -> IO ByteString-mockApi p _ = L.readFile (path p <> "/response.json")+mockJSON :: FilePath -> ByteString -> IO ByteString+mockJSON p _ = getFile (p <> ".json") -fixFilePath :: FilePath -> Q FilePath-fixFilePath x = prefix <$> runIO (doesFileExist x)+assertFetch ::+  ( Fetch a,+    FromJSON a,+    Eq a,+    Show a+  ) =>+  FilePath ->+  Maybe FilePath ->+  Args a ->+  Either (FetchError a) a ->+  TestTree+assertFetch folder file args v =+  testCase display $ do+    response <- fetch (mockJSON (folder <> "/" <> fileName)) args+    assertEqual ("Test " <> display) v response   where-    prefix True = x-    prefix False = withProject x--defineClientWith ::-  FieldName ->-  (ExecutableDocument, String) ->-  Q [Dec]-defineClientWith url exp = do-  p <- fixFilePath (path url <> "/schema.gql")-  defineByDocumentFile p exp--defineClientWithJSON ::-  FieldName ->-  (ExecutableDocument, String) ->-  Q [Dec]-defineClientWithJSON url exp = do-  p <- fixFilePath (path url <> "/schema.json")-  defineByIntrospectionFile p exp+    fileName = fromMaybe "response" file+    display = fromMaybe folder file