graphql 0.10.0.0 → 0.11.0.0

raw patch · 36 files changed

+3172/−1942 lines, 36 filesdep ~QuickCheckdep ~aesondep ~conduitPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: QuickCheck, aeson, conduit, containers, exceptions, hspec, hspec-expectations, hspec-megaparsec, megaparsec, parser-combinators, raw-strings-qq, scientific, text, transformers, unordered-containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +86/−19
• CONTRIBUTING.md +0/−31
• LICENSE.MPL +373/−0
• README.md +5/−119
• docs/tutorial/tutorial.lhs +0/−152
• graphql.cabal +36/−41
• src/Language/GraphQL.hs +12/−16
• src/Language/GraphQL/AST/DirectiveLocation.hs +33/−3
• src/Language/GraphQL/AST/Document.hs +60/−48
• src/Language/GraphQL/AST/Encoder.hs +106/−113
• src/Language/GraphQL/AST/Lexer.hs +4/−4
• src/Language/GraphQL/AST/Parser.hs +195/−171
• src/Language/GraphQL/Error.hs +18/−6
• src/Language/GraphQL/Execute.hs +2/−2
• src/Language/GraphQL/Execute/Execution.hs +11/−12
• src/Language/GraphQL/Execute/Transform.hs +61/−75
• src/Language/GraphQL/Type.hs +1/−1
• src/Language/GraphQL/Type/In.hs +15/−11
• src/Language/GraphQL/Type/Internal.hs +111/−65
• src/Language/GraphQL/Type/Out.hs +1/−1
• src/Language/GraphQL/Type/Schema.hs +141/−23
• src/Language/GraphQL/Validate.hs +475/−50
• src/Language/GraphQL/Validate/Rules.hs +869/−69
• src/Language/GraphQL/Validate/Validation.hs +14/−18
• tests/Language/GraphQL/AST/EncoderSpec.hs +33/−31
• tests/Language/GraphQL/AST/LexerSpec.hs +2/−2
• tests/Language/GraphQL/AST/ParserSpec.hs +1/−1
• tests/Language/GraphQL/ErrorSpec.hs +1/−1
• tests/Language/GraphQL/ExecuteSpec.hs +29/−10
• tests/Language/GraphQL/ValidateSpec.hs +452/−70
• tests/Test/DirectiveSpec.hs +3/−4
• tests/Test/FragmentSpec.hs +16/−41
• tests/Test/RootOperationSpec.hs +6/−8
• tests/Test/StarWars/Data.hs +0/−204
• tests/Test/StarWars/QuerySpec.hs +0/−366
• tests/Test/StarWars/Schema.hs +0/−154

@@ -6,28 +6,94 @@ and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [0.11.0.0] - 2020-11-07+### Changed+- `AST.Document.Selection` wraps additional new types: `Field`, `FragmentSpread`+  and  `InlineFragment`. Thus validation rules can be defined more concise.+- `AST.Document`: `Argument` and `Directive` contain token location.+- `AST.Document.Argument` contains the `Value` wrapped in the `Node`.+- `AST.Lexer.colon` and `AST.Lexer.at` ignore the result (it is always the+- same).+- `Validate.Validation`: `Validation.rules` was removed. `Validation.rules`+  contained the list of rules, but the executed rules shouldn't know about other+  rules. `rules` was a part of the `Validation` context to pass it easier+  around, but since the rules are traversed once now and applied to all nodes in+  the tree at the beginning, it isn't required anymore.+- `Validate.Validation.Error`: `path` is removed since it isn't possible to get+  the path without executing the query.+- `Error.Error`: `path` added. It is currently always empty.+- `Validate.Validation.Path` was moved to `Error`.+- `Type.Schema.Schema`: data constructor is hidden, fields are accessible with+  freestanding functions: `query`, `mutation`, `subscription`, `directives` and+  `types`.++### Added+- `Validate.Validation.Rule` constructors:+  - `SelectionRule`+  - `FragmentRule`+  - `FragmentSpreadRule`+  - `ArgumentsRule`+  - `DirectivesRule`+  - `VariablesRule`+  - `FieldRule`+- `Validate.Rules`:+  - `fragmentsOnCompositeTypesRule`+  - `fragmentSpreadTargetDefinedRule`+  - `fragmentSpreadTypeExistenceRule`+  - `noUnusedFragmentsRule`+  - `noFragmentCyclesRule`+  - `uniqueArgumentNamesRule`+  - `uniqueDirectiveNamesRule`+  - `uniqueVariableNamesRule`+  - `variablesAreInputTypesRule`+  - `noUndefinedVariablesRule`+  - `noUndefinedVariablesRule`+  - `noUnusedVariablesRule`+  - `uniqueInputFieldNamesRule`+  - `fieldsOnCorrectTypeRule`+  - `scalarLeafsRule`+  - `knownArgumentNamesRule`+  - `knownDirectiveNamesRule`+  - `directivesInValidLocationsRule`+  - `providedRequiredArgumentsRule`+  - `providedRequiredInputFieldsRule`+- `AST.Document.Field`.+- `AST.Document.FragmentSpread`.+- `AST.Document.InlineFragment`.+- `AST.Document.Node`.+- `Type.In.Arguments`: Type alias for an argument map.+- `Type.Schema.Directive` and `Type.Schema.Directives` are directive definition+  representation.+- `Type.Schema.schema`: Schema constructor.++### Fixed+- Collecting existing types from the schema considers subscriptions.++### Removed+- `AST.Document.Alias`. Use `AST.Document.Name` instead.+ ## [0.10.0.0] - 2020-08-29-## Changed+### Changed - `Test.Hspec.GraphQL.*`: replace `IO` in the resolver with any `MonadCatch`. - The `Location` argument of `AST.Document.Definition.ExecutableDefinition` was   moved to `OperationDefinition` and `FragmentDefinition` since these are the   actual elements that have a location in the document. - `Validate.Rules` get the whole validation context (AST and schema). -## Added+### Added - `Validate.Validation` contains data structures and functions used by the   validator and concretet rules. - `Validate.Rules`: operation validation rules.  ## [0.9.0.0] - 2020-07-24-## Fixed+### Fixed - Location of a parse error is returned in a singleton array with key   `locations`. - Parsing comments in the front of definitions. - Some missing labels were added to the parsers, some labels were fixed to   refer to the AST nodes being parsed.  -## Added+### Added - `AST` reexports `AST.Parser`. - `AST.Document.Location` is a token location as a line and column pair. - `Execute` reexports `Execute.Coerce`.@@ -43,7 +109,7 @@ - `Test.Hspec.GraphQL` contains some test helpers. - `Validate` contains the validator and standard rules. -## Changed+### Changed - `Type.Out.Resolver`: Interface fields don't have resolvers, object fields   have value resolvers, root subscription type resolvers need an additional   resolver that creates an event stream. `Resolver` represents these differences@@ -67,7 +133,7 @@ - The constraint of the base monad was changed to `MonadCatch` (and it implies   `MonadThrow`). -## Removed+### Removed - `Trans.ActionT` is an unneeded layer of complexity. `Type.Out.Resolver`   represents possible resolver configurations. - `Execute.executeWithName`. `Execute.execute` takes the operation name and@@ -334,16 +400,17 @@ ### Added - Data types for the GraphQL language. -[0.10.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.9.0.0...v0.10.0.0-[0.9.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.8.0.0...v0.9.0.0-[0.8.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.7.0.0...v0.8.0.0-[0.7.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...v0.7.0.0-[0.6.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.0.0...v0.6.1.0-[0.6.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.1.0...v0.6.0.0-[0.5.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.0.1...v0.5.1.0-[0.5.0.1]: https://github.com/caraus-ecms/graphql/compare/v0.5.0.0...v0.5.0.1-[0.5.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.4.0.0...v0.5.0.0-[0.4.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.3...v0.4.0.0-[0.3]: https://github.com/caraus-ecms/graphql/compare/v0.2.1...v0.3-[0.2.1]: https://github.com/caraus-ecms/graphql/compare/v0.2...v0.2.1-[0.2]: https://github.com/caraus-ecms/graphql/compare/v0.1...v0.2+[0.11.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.11.0.0&rev_to=v0.10.0.0+[0.10.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.10.0.0&rev_to=v0.9.0.0+[0.9.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.9.0.0&rev_to=v0.8.0.0+[0.8.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.8.0.0&rev_to=v0.7.0.0+[0.7.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.7.0.0&rev_to=v0.6.1.0+[0.6.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.6.1.0&rev_to=v0.6.0.0+[0.6.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.6.0.0&rev_to=v0.5.1.0+[0.5.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.5.1.0&rev_to=v0.5.0.1+[0.5.0.1]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.5.0.1&rev_to=v0.5.0.0+[0.5.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.5.0.0&rev_to=v0.4.0.0+[0.4.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.4.0.0&rev_to=v0.3+[0.3]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.3&rev_to=v0.2.1+[0.2.1]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.2.1&rev_to=v0.2+[0.2]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.2&rev_to=v0.1

@@ -1,31 +0,0 @@-# Contributing guidelines--## Testing--To ensure all code changes adhere to existing code quality standards, some-automatic checks can be run locally.--Ensure that the code builds without warnings and passes the tests:--```sh-stack test --pedantic-```--And also run the linter on your code:--```sh-stack build hlint-stack exec hlint -- src tests-```--Build the documentation and check if you get any warnings:--```sh-stack haddock-```--Validate that literate Haskell (tutorials) files compile without any warnings:--```sh-stack ghc -- -Wall -fno-code docs/tutorial/*.lhs-```

@@ -0,0 +1,373 @@+Mozilla Public License Version 2.0+==================================++1. Definitions+--------------++1.1. "Contributor"+    means each individual or legal entity that creates, contributes to+    the creation of, or owns Covered Software.++1.2. "Contributor Version"+    means the combination of the Contributions of others (if any) used+    by a Contributor and that particular Contributor's Contribution.++1.3. "Contribution"+    means Covered Software of a particular Contributor.++1.4. "Covered Software"+    means Source Code Form to which the initial Contributor has attached+    the notice in Exhibit A, the Executable Form of such Source Code+    Form, and Modifications of such Source Code Form, in each case+    including portions thereof.++1.5. "Incompatible With Secondary Licenses"+    means++    (a) that the initial Contributor has attached the notice described+        in Exhibit B to the Covered Software; or++    (b) that the Covered Software was made available under the terms of+        version 1.1 or earlier of the License, but not also under the+        terms of a Secondary License.++1.6. "Executable Form"+    means any form of the work other than Source Code Form.++1.7. "Larger Work"+    means a work that combines Covered Software with other material, in+    a separate file or files, that is not Covered Software.++1.8. "License"+    means this document.++1.9. "Licensable"+    means having the right to grant, to the maximum extent possible,+    whether at the time of the initial grant or subsequently, any and+    all of the rights conveyed by this License.++1.10. "Modifications"+    means any of the following:++    (a) any file in Source Code Form that results from an addition to,+        deletion from, or modification of the contents of Covered+        Software; or++    (b) any new file in Source Code Form that contains any Covered+        Software.++1.11. "Patent Claims" of a Contributor+    means any patent claim(s), including without limitation, method,+    process, and apparatus claims, in any patent Licensable by such+    Contributor that would be infringed, but for the grant of the+    License, by the making, using, selling, offering for sale, having+    made, import, or transfer of either its Contributions or its+    Contributor Version.++1.12. "Secondary License"+    means either the GNU General Public License, Version 2.0, the GNU+    Lesser General Public License, Version 2.1, the GNU Affero General+    Public License, Version 3.0, or any later versions of those+    licenses.++1.13. "Source Code Form"+    means the form of the work preferred for making modifications.++1.14. "You" (or "Your")+    means an individual or a legal entity exercising rights under this+    License. For legal entities, "You" includes any entity that+    controls, is controlled by, or is under common control with You. For+    purposes of this definition, "control" means (a) the power, direct+    or indirect, to cause the direction or management of such entity,+    whether by contract or otherwise, or (b) ownership of more than+    fifty percent (50%) of the outstanding shares or beneficial+    ownership of such entity.++2. License Grants and Conditions+--------------------------------++2.1. Grants++Each Contributor hereby grants You a world-wide, royalty-free,+non-exclusive license:++(a) under intellectual property rights (other than patent or trademark)+    Licensable by such Contributor to use, reproduce, make available,+    modify, display, perform, distribute, and otherwise exploit its+    Contributions, either on an unmodified basis, with Modifications, or+    as part of a Larger Work; and++(b) under Patent Claims of such Contributor to make, use, sell, offer+    for sale, have made, import, and otherwise transfer either its+    Contributions or its Contributor Version.++2.2. Effective Date++The licenses granted in Section 2.1 with respect to any Contribution+become effective for each Contribution on the date the Contributor first+distributes such Contribution.++2.3. Limitations on Grant Scope++The licenses granted in this Section 2 are the only rights granted under+this License. No additional rights or licenses will be implied from the+distribution or licensing of Covered Software under this License.+Notwithstanding Section 2.1(b) above, no patent license is granted by a+Contributor:++(a) for any code that a Contributor has removed from Covered Software;+    or++(b) for infringements caused by: (i) Your and any other third party's+    modifications of Covered Software, or (ii) the combination of its+    Contributions with other software (except as part of its Contributor+    Version); or++(c) under Patent Claims infringed by Covered Software in the absence of+    its Contributions.++This License does not grant any rights in the trademarks, service marks,+or logos of any Contributor (except as may be necessary to comply with+the notice requirements in Section 3.4).++2.4. Subsequent Licenses++No Contributor makes additional grants as a result of Your choice to+distribute the Covered Software under a subsequent version of this+License (see Section 10.2) or under the terms of a Secondary License (if+permitted under the terms of Section 3.3).++2.5. Representation++Each Contributor represents that the Contributor believes its+Contributions are its original creation(s) or it has sufficient rights+to grant the rights to its Contributions conveyed by this License.++2.6. Fair Use++This License is not intended to limit any rights You have under+applicable copyright doctrines of fair use, fair dealing, or other+equivalents.++2.7. Conditions++Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted+in Section 2.1.++3. Responsibilities+-------------------++3.1. Distribution of Source Form++All distribution of Covered Software in Source Code Form, including any+Modifications that You create or to which You contribute, must be under+the terms of this License. You must inform recipients that the Source+Code Form of the Covered Software is governed by the terms of this+License, and how they can obtain a copy of this License. You may not+attempt to alter or restrict the recipients' rights in the Source Code+Form.++3.2. Distribution of Executable Form++If You distribute Covered Software in Executable Form then:++(a) such Covered Software must also be made available in Source Code+    Form, as described in Section 3.1, and You must inform recipients of+    the Executable Form how they can obtain a copy of such Source Code+    Form by reasonable means in a timely manner, at a charge no more+    than the cost of distribution to the recipient; and++(b) You may distribute such Executable Form under the terms of this+    License, or sublicense it under different terms, provided that the+    license for the Executable Form does not attempt to limit or alter+    the recipients' rights in the Source Code Form under this License.++3.3. Distribution of a Larger Work++You may create and distribute a Larger Work under terms of Your choice,+provided that You also comply with the requirements of this License for+the Covered Software. If the Larger Work is a combination of Covered+Software with a work governed by one or more Secondary Licenses, and the+Covered Software is not Incompatible With Secondary Licenses, this+License permits You to additionally distribute such Covered Software+under the terms of such Secondary License(s), so that the recipient of+the Larger Work may, at their option, further distribute the Covered+Software under the terms of either this License or such Secondary+License(s).++3.4. Notices++You may not remove or alter the substance of any license notices+(including copyright notices, patent notices, disclaimers of warranty,+or limitations of liability) contained within the Source Code Form of+the Covered Software, except that You may alter any license notices to+the extent required to remedy known factual inaccuracies.++3.5. Application of Additional Terms++You may choose to offer, and to charge a fee for, warranty, support,+indemnity or liability obligations to one or more recipients of Covered+Software. However, You may do so only on Your own behalf, and not on+behalf of any Contributor. You must make it absolutely clear that any+such warranty, support, indemnity, or liability obligation is offered by+You alone, and You hereby agree to indemnify every Contributor for any+liability incurred by such Contributor as a result of warranty, support,+indemnity or liability terms You offer. You may include additional+disclaimers of warranty and limitations of liability specific to any+jurisdiction.++4. Inability to Comply Due to Statute or Regulation+---------------------------------------------------++If it is impossible for You to comply with any of the terms of this+License with respect to some or all of the Covered Software due to+statute, judicial order, or regulation then You must: (a) comply with+the terms of this License to the maximum extent possible; and (b)+describe the limitations and the code they affect. Such description must+be placed in a text file included with all distributions of the Covered+Software under this License. Except to the extent prohibited by statute+or regulation, such description must be sufficiently detailed for a+recipient of ordinary skill to be able to understand it.++5. Termination+--------------++5.1. The rights granted under this License will terminate automatically+if You fail to comply with any of its terms. However, if You become+compliant, then the rights granted under this License from a particular+Contributor are reinstated (a) provisionally, unless and until such+Contributor explicitly and finally terminates Your grants, and (b) on an+ongoing basis, if such Contributor fails to notify You of the+non-compliance by some reasonable means prior to 60 days after You have+come back into compliance. Moreover, Your grants from a particular+Contributor are reinstated on an ongoing basis if such Contributor+notifies You of the non-compliance by some reasonable means, this is the+first time You have received notice of non-compliance with this License+from such Contributor, and You become compliant prior to 30 days after+Your receipt of the notice.++5.2. If You initiate litigation against any entity by asserting a patent+infringement claim (excluding declaratory judgment actions,+counter-claims, and cross-claims) alleging that a Contributor Version+directly or indirectly infringes any patent, then the rights granted to+You by any and all Contributors for the Covered Software under Section+2.1 of this License shall terminate.++5.3. In the event of termination under Sections 5.1 or 5.2 above, all+end user license agreements (excluding distributors and resellers) which+have been validly granted by You or Your distributors under this License+prior to termination shall survive termination.++************************************************************************+*                                                                      *+*  6. Disclaimer of Warranty                                           *+*  -------------------------                                           *+*                                                                      *+*  Covered Software is provided under this License on an "as is"       *+*  basis, without warranty of any kind, either expressed, implied, or  *+*  statutory, including, without limitation, warranties that the       *+*  Covered Software is free of defects, merchantable, fit for a        *+*  particular purpose or non-infringing. The entire risk as to the     *+*  quality and performance of the Covered Software is with You.        *+*  Should any Covered Software prove defective in any respect, You     *+*  (not any Contributor) assume the cost of any necessary servicing,   *+*  repair, or correction. This disclaimer of warranty constitutes an   *+*  essential part of this License. No use of any Covered Software is   *+*  authorized under this License except under this disclaimer.         *+*                                                                      *+************************************************************************++************************************************************************+*                                                                      *+*  7. Limitation of Liability                                          *+*  --------------------------                                          *+*                                                                      *+*  Under no circumstances and under no legal theory, whether tort      *+*  (including negligence), contract, or otherwise, shall any           *+*  Contributor, or anyone who distributes Covered Software as          *+*  permitted above, be liable to You for any direct, indirect,         *+*  special, incidental, or consequential damages of any character      *+*  including, without limitation, damages for lost profits, loss of    *+*  goodwill, work stoppage, computer failure or malfunction, or any    *+*  and all other commercial damages or losses, even if such party      *+*  shall have been informed of the possibility of such damages. This   *+*  limitation of liability shall not apply to liability for death or   *+*  personal injury resulting from such party's negligence to the       *+*  extent applicable law prohibits such limitation. Some               *+*  jurisdictions do not allow the exclusion or limitation of           *+*  incidental or consequential damages, so this exclusion and          *+*  limitation may not apply to You.                                    *+*                                                                      *+************************************************************************++8. Litigation+-------------++Any litigation relating to this License may be brought only in the+courts of a jurisdiction where the defendant maintains its principal+place of business and such litigation shall be governed by laws of that+jurisdiction, without reference to its conflict-of-law provisions.+Nothing in this Section shall prevent a party's ability to bring+cross-claims or counter-claims.++9. Miscellaneous+----------------++This License represents the complete agreement concerning the subject+matter hereof. If any provision of this License is held to be+unenforceable, such provision shall be reformed only to the extent+necessary to make it enforceable. Any law or regulation which provides+that the language of a contract shall be construed against the drafter+shall not be used to construe this License against a Contributor.++10. Versions of the License+---------------------------++10.1. New Versions++Mozilla Foundation is the license steward. Except as provided in Section+10.3, no one other than the license steward has the right to modify or+publish new versions of this License. Each version will be given a+distinguishing version number.++10.2. Effect of New Versions++You may distribute the Covered Software under the terms of the version+of the License under which You originally received the Covered Software,+or under the terms of any subsequent version published by the license+steward.++10.3. Modified Versions++If you create software not governed by this License, and you want to+create a new license for such software, you may create and use a+modified version of this License if you rename the license and remove+any references to the name of the license steward (except to note that+such modified license differs from this License).++10.4. Distributing Source Code Form that is Incompatible With Secondary+Licenses++If You choose to distribute Source Code Form that is Incompatible With+Secondary Licenses under the terms of this version of the License, the+notice described in Exhibit B of this License must be attached.++Exhibit A - Source Code Form License Notice+-------------------------------------------++  This Source Code Form is subject to the terms of the Mozilla Public+  License, v. 2.0. If a copy of the MPL was not distributed with this+  file, You can obtain one at http://mozilla.org/MPL/2.0/.++If it is not possible or desirable to put the notice in a particular+file, then You may include the notice in a location (such as a LICENSE+file in a relevant directory) where a recipient would be likely to look+for such a notice.++You may add additional accurate notices of copyright ownership.++Exhibit B - "Incompatible With Secondary Licenses" Notice+---------------------------------------------------------++  This Source Code Form is "Incompatible With Secondary Licenses", as+  defined by the Mozilla Public License, v. 2.0.

@@ -1,9 +1,7 @@ # GraphQL implementation in Haskell -[![Hackage Version](https://img.shields.io/hackage/v/graphql.svg)](https://hackage.haskell.org/package/graphql)-[![Build Status](https://github.com/caraus-ecms/graphql/workflows/Haskell%20CI/badge.svg)](https://github.com/caraus-ecms/graphql/actions?query=workflow%3A%22Haskell+CI%22)-[![License](https://img.shields.io/badge/license-BSD--3--Clause-blue.svg)](https://raw.githubusercontent.com/caraus-ecms/graphql/master/LICENSE) [![Simple Haskell](https://www.simplehaskell.org/badges/badge.svg)](https://www.simplehaskell.org)+[![CI/CD](https://img.shields.io/badge/CI-CD-brightgreen)](https://build.caraus.tech/go/pipelines)  This implementation is relatively low-level by design, it doesn't provide any mappings between the GraphQL types and Haskell's type system and avoids@@ -24,125 +22,13 @@ But the idea is to be a Haskell port of [`graphql-js`](https://github.com/graphql/graphql-js). -For a more precise list of currently missing features see issues marked as-"[not implemented](https://github.com/caraus-ecms/graphql/labels/not%20implemented)".+For a more precise list of currently missing features see+[issues](https://www.caraus.tech/projects/pub-graphql/issues).  ## Documentation  API documentation is available through [Hackage](https://hackage.haskell.org/package/graphql). -You'll also find a small tutorial with some examples under-[docs/tutorial](https://github.com/caraus-ecms/graphql/tree/master/docs/tutorial).--### Getting started--We start with a simple GraphQL API that provides us with some famous and less-famous cites.--```graphql-"""-Root Query type.-"""-type Query {-  """-  Provides a cite.-  """-  cite: String!-}-```--This is called a GraphQL schema, it defines all queries supported by the API.-`Query` is the root query type. Every GraphQL API should define a query type.--`Query` has a single field `cite` that returns a `String`. The `!` after the-type denotes that the returned value cannot be `Null`. GraphQL fields are-nullable by default.--To be able to work with this schema, we are going to implement it in Haskell.--```haskell-{-# LANGUAGE OverloadedStrings #-}--import Control.Exception (SomeException)-import qualified Data.Aeson as Aeson-import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy.Char8-import qualified Data.HashMap.Strict as HashMap-import Language.GraphQL-import Language.GraphQL.Type-import qualified Language.GraphQL.Type.Out as Out---- GraphQL supports 3 kinds of operations: queries, mutations and subscriptions.--- Our first schema supports only queries.-schema :: Schema IO-schema = Schema-    { query = queryType, mutation = Nothing, subscription = Nothing }---- GraphQL distinguishes between input and output types. Input types are field--- argument types and they are defined in Language.GraphQL.Type.In. Output types--- are result types, they are defined in Language.GraphQL.Type.Out. Root types--- are always object types.------ Here we define a type "Query". The second argument is an optional--- description, the third one is the list of interfaces implemented by the--- object type. The last argument is a field map. Keys are field names, values--- are field definitions and resolvers. Resolvers are the functions, where the--- actual logic lives, they return values for the respective fields.-queryType :: Out.ObjectType IO-queryType = Out.ObjectType "Query" (Just "Root Query type.") []-    $ HashMap.singleton "cite" citeResolver-  where-    -- 'ValueResolver' is a 'Resolver' data constructor, it combines a field-    -- definition with its resolver function. This function resolves a value for-    -- a field (as opposed to the 'EventStreamResolver' used by subscriptions).-    -- Our resolver just returns a constant value.-    citeResolver = ValueResolver citeField-        $ pure "Piscis primum a capite foetat"-    -- The first argument is an optional field description. The second one is-    -- the field type and the third one is for arguments (we have none in this-    -- example).-    ---    -- GraphQL has named and wrapping types. String is a scalar, named type.-    -- Named types are nullable by default. To make our "cite" field-    -- non-nullable, we wrap it in the wrapping type, Non-Null.-    citeField = Out.Field-        (Just "Provides a cite.") (Out.NonNullScalarType string) HashMap.empty---- Now we can execute a query. Since our schema defines only one field,--- everything we can do is to ask to resolve it and give back the result.--- Since subscriptions don't return plain values, the 'graphql' function returns--- an 'Either'. 'Left' is for subscriptions, 'Right' is for queries and--- mutations.-main :: IO ()-main = do-    Right result <- graphql schema "{ cite }"-    ByteString.Lazy.Char8.putStrLn $ Aeson.encode result-```--Executing this query produces the following JSON:--```json-{-  "data": {-    "cite": "Piscis primum a capite foetat"-  }-}-```--## Further information--- [Contributing guidelines](CONTRIBUTING.md).-- [Changelog](CHANGELOG.md) – this one contains the most recent changes; -  individual changelogs for specific versions can be found on-  [Hackage](https://hackage.haskell.org/package/graphql).--## Contact--Suggestions, contributions and bug reports are welcome.--Should you have questions on usage, please open an issue and ask – this helps-to write useful documentation.--Feel free to contact on Slack in [#haskell on-GraphQL](https://graphql.slack.com/messages/haskell/). You can obtain an-invitation [here](https://graphql-slack.herokuapp.com/).+Further documentation will be made available in the+[Wiki](https://www.caraus.tech/projects/pub-graphql/wiki).

@@ -1,152 +0,0 @@-----title: GraphQL Haskell Tutorial-------== Getting started ==--Welcome to GraphQL!--We have written a small tutorial to help you (and ourselves) understand the-graphql package.--Since this file is a literate haskell file, we start by importing some-dependencies.--> {-# LANGUAGE OverloadedStrings #-}-> module Main where->-> import Control.Monad.IO.Class (liftIO)-> import Data.Aeson (encode)-> import Data.ByteString.Lazy.Char8 (putStrLn)-> import qualified Data.HashMap.Strict as HashMap-> import Data.Text (Text)-> import qualified Data.Text as Text-> import Data.Time (getCurrentTime)->-> import Language.GraphQL-> import Language.GraphQL.Type-> import qualified Language.GraphQL.Type.Out as Out->-> import Prelude hiding (putStrLn)---=== First example ===--Now, as our first example, we are going to look at the example from-[graphql.js](https://github.com/graphql/graphql-js).--First we build a GraphQL schema.--> schema1 :: Schema IO-> schema1 = Schema->   { query = queryType , mutation = Nothing , subscription = Nothing }->-> queryType :: ObjectType IO-> queryType = ObjectType "Query" Nothing []->   $ HashMap.singleton "hello"->   $ ValueResolver helloField hello->-> helloField :: Field IO-> helloField = Field Nothing (Out.NamedScalarType string) mempty->-> hello :: Resolve IO-> hello = pure $ String "it's me"--This defines a simple schema with one type and one field, that resolves to a-fixed value.--Next we define our query.--> query1 :: Text-> query1 = "{ hello }"--To run the query, we call the `graphql` with the schema and the query.--> main1 :: IO ()-> main1 = graphql schema1 query1->   >>= either (const $ pure ()) (putStrLn . encode)--This runs the query by fetching the one field defined, returning--```{"data" : {"hello":"it's me"}}```---=== Monadic actions ===--For this example, we're going to be using time.--> schema2 :: Schema IO-> schema2 = Schema->   { query = queryType2, mutation = Nothing, subscription = Nothing }->-> queryType2 :: ObjectType IO-> queryType2 = ObjectType "Query" Nothing []->   $ HashMap.singleton "time"->   $ ValueResolver timeField time->-> timeField :: Field IO-> timeField = Field Nothing (Out.NamedScalarType string) mempty->-> time :: Resolve IO-> time = do->   t <- liftIO getCurrentTime->   pure $ String $ Text.pack $ show t--This defines a simple schema with one type and one field, which resolves to the-current time.--Next we define our query.--> query2 :: Text-> query2 = "{ time }"->-> main2 :: IO ()-> main2 = graphql schema2 query2->   >>= either (const $ pure ()) (putStrLn . encode)--This runs the query, returning the current time--```{"data": {"time":"2016-03-08 23:28:14.546899 UTC"}}```---=== Combining resolvers ===--Now that we have two resolvers, we can define a schema which uses them both.--> schema3 :: Schema IO-> schema3 = Schema->   { query = queryType3, mutation = Nothing, subscription = Nothing }->-> queryType3 :: ObjectType IO-> queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList->   [ ("hello", ValueResolver helloField hello)->   , ("time", ValueResolver timeField time)->   ]->-> query3 :: Text-> query3 = "query timeAndHello { time hello }"->-> main3 :: IO ()-> main3 = graphql schema3 query3->   >>= either (const $ pure ()) (putStrLn . encode)--This queries for both time and hello, returning--```{ "data": {"hello":"it's me","time":"2016-03-08 23:29:11.62108 UTC"}}```--Notice that we can name our queries, as we did with `timeAndHello`. Since we-have only been using single queries, we can use the shorthand `{ time hello }`,-as we have been doing in the previous examples.--In GraphQL there can only be one operation per query.---== Further examples ==--More examples on queries and a more complex schema can be found in the test-directory, in the [Test.StarWars](../../tests/Test/StarWars) module. This-includes a more complex schema, and more complex queries.--> main :: IO ()-> main = main1 >> main2 >> main3

@@ -1,8 +1,8 @@-cabal-version:      1.12+cabal-version:      2.2 name:               graphql-version:            0.10.0.0-license:            BSD3-license-file:       LICENSE+version:            0.11.0.0+license:            MPL-2.0 AND BSD-3-Clause+license-file:       LICENSE LICENSE.MPL copyright:     (c) 2019-2020 Eugen Wissner,     (c) 2015-2017 J. Daniel Navarro@@ -13,24 +13,21 @@     Matthías Páll Gissurarson <mpg@mpg.is>,     Sólrún Halla Einarsdóttir <she@mpg.is> -homepage:           https://github.com/caraus-ecms/graphql#readme-bug-reports:        https://github.com/caraus-ecms/graphql/issues+homepage:           https://www.caraus.tech/projects/pub-graphql+bug-reports:        https://www.caraus.tech/projects/pub-graphql/issues synopsis:           Haskell GraphQL implementation description:-    This package provides a rudimentary parser for the <https://graphql.github.io/graphql-spec/June2018/ GraphQL> language.+    Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.  category:           Language build-type:         Simple extra-source-files:     CHANGELOG.md-    CONTRIBUTING.md-    LICENSE     README.md-    docs/tutorial/tutorial.lhs  source-repository head     type:     git-    location: https://github.com/caraus-ecms/graphql+    location: git://caraus.tech/pub/graphql.git  library     exposed-modules:@@ -63,20 +60,20 @@      default-language: Haskell2010     build-depends:-        aeson >=1.4.7.1 && <1.5,+        aeson >=1.4.7.1,         base >=4.7 && <5,-        conduit >=1.3.2 && <1.4,-        containers >=0.6.2.1 && <0.7,-        exceptions >=0.10.4 && <0.11,-        hspec-expectations >=0.8.2 && <0.9,-        megaparsec >=8.0.0 && <8.1,-        parser-combinators >=1.2.1 && <1.3,-        scientific >=0.3.6.2 && <0.4,-        text >=1.2.4.0 && <1.3,-        transformers >=0.5.6.2 && <0.6,-        unordered-containers >=0.2.10.0 && <0.3+        conduit >=1.3.3,+        containers >=0.6.2.1,+        exceptions >=0.10.4,+        hspec-expectations >=0.8.2,+        megaparsec >=8.0.0,+        parser-combinators >=1.2.1,+        scientific >=0.3.6.2,+        text >=1.2.4.0,+        transformers >=0.5.6.2,+        unordered-containers >=0.2.10.0 -test-suite tasty+test-suite graphql-test     type:             exitcode-stdio-1.0     main-is:          Spec.hs     hs-source-dirs:   tests@@ -92,28 +89,26 @@         Test.DirectiveSpec         Test.FragmentSpec         Test.RootOperationSpec-        Test.StarWars.Data-        Test.StarWars.QuerySpec-        Test.StarWars.Schema         Paths_graphql +    autogen-modules:  Paths_graphql     default-language: Haskell2010     ghc-options:      -threaded -rtsopts -with-rtsopts=-N     build-depends:-        QuickCheck >=2.13.2 && <2.14,-        aeson >=1.4.7.1 && <1.5,+        QuickCheck >=2.13.2,+        aeson >=1.4.7.1,         base >=4.7 && <5,-        conduit >=1.3.2 && <1.4,-        containers >=0.6.2.1 && <0.7,-        exceptions >=0.10.4 && <0.11,+        conduit >=1.3.3,+        containers >=0.6.2.1,+        exceptions >=0.10.4,         graphql -any,-        hspec >=2.7.2 && <2.8,-        hspec-expectations >=0.8.2 && <0.9,-        hspec-megaparsec >=2.1.0 && <2.2,-        megaparsec >=8.0.0 && <8.1,-        parser-combinators >=1.2.1 && <1.3,-        raw-strings-qq ==1.1.*,-        scientific >=0.3.6.2 && <0.4,-        text >=1.2.4.0 && <1.3,-        transformers >=0.5.6.2 && <0.6,-        unordered-containers >=0.2.10.0 && <0.3+        hspec >=2.7.4,+        hspec-expectations >=0.8.2,+        hspec-megaparsec >=2.1.0,+        megaparsec >=8.0.0,+        parser-combinators >=1.2.1,+        raw-strings-qq >=1.1,+        scientific >=0.3.6.2,+        text >=1.2.4.0,+        transformers >=0.5.6.2,+        unordered-containers >=0.2.10.0

@@ -11,13 +11,14 @@ import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson import qualified Data.HashMap.Strict as HashMap+import Data.Maybe (catMaybes) import qualified Data.Sequence as Seq import Data.Text (Text) import Language.GraphQL.AST import Language.GraphQL.Error import Language.GraphQL.Execute import qualified Language.GraphQL.Validate as Validate-import Language.GraphQL.Type.Schema+import Language.GraphQL.Type.Schema (Schema) import Text.Megaparsec (parse)  -- | If the text parses correctly as a @GraphQL@ query the query is@@ -55,24 +56,19 @@         [ ("data", data'')         , ("errors", Aeson.toJSON $ fromError <$> errors')         ]-    fromError Error{ locations = [], ..} =-        Aeson.object [("message", Aeson.toJSON message)]-    fromError Error{..} = Aeson.object+    fromError Error{..} = Aeson.object $ catMaybes+        [ Just ("message", Aeson.toJSON message)+        , toMaybe fromLocation "locations" locations+        , toMaybe fromPath "path" path+        ]+    fromValidationError Validate.Error{..} = Aeson.object         [ ("message", Aeson.toJSON message)         , ("locations", Aeson.listValue fromLocation locations)         ]-    fromValidationError Validate.Error{..}-        | [] <- path = Aeson.object-            [ ("message", Aeson.toJSON message)-            , ("locations", Aeson.listValue fromLocation locations)-            ]-        | otherwise = Aeson.object-            [ ("message", Aeson.toJSON message)-            , ("locations", Aeson.listValue fromLocation locations)-            , ("path", Aeson.listValue fromPath path)-            ]-    fromPath (Validate.Segment segment) = Aeson.String segment-    fromPath (Validate.Index index) = Aeson.toJSON index+    toMaybe _ _ [] = Nothing+    toMaybe f key xs = Just (key, Aeson.listValue f xs)+    fromPath (Segment segment) = Aeson.String segment+    fromPath (Index index) = Aeson.toJSON index     fromLocation Location{..} = Aeson.object         [ ("line", Aeson.toJSON line)         , ("column", Aeson.toJSON column)

@@ -2,6 +2,8 @@    v. 2.0. If a copy of the MPL was not distributed with this file, You can    obtain one at https://mozilla.org/MPL/2.0/. -} +{-# LANGUAGE Safe #-}+ -- | Various parts of a GraphQL document can be annotated with directives.  -- This module describes locations in a document where directives can appear. module Language.GraphQL.AST.DirectiveLocation@@ -16,8 +18,14 @@ data DirectiveLocation     = ExecutableDirectiveLocation ExecutableDirectiveLocation     | TypeSystemDirectiveLocation TypeSystemDirectiveLocation-    deriving (Eq, Show)+    deriving Eq +instance Show DirectiveLocation where+    show (ExecutableDirectiveLocation directiveLocation) =+        show directiveLocation+    show (TypeSystemDirectiveLocation directiveLocation) =+        show directiveLocation+ -- | Where directives can appear in an executable definition, like a query. data ExecutableDirectiveLocation     = Query@@ -27,8 +35,17 @@     | FragmentDefinition     | FragmentSpread     | InlineFragment-    deriving (Eq, Show)+    deriving Eq +instance Show ExecutableDirectiveLocation where+    show Query = "QUERY"+    show Mutation = "MUTATION"+    show Subscription = "SUBSCRIPTION"+    show Field = "FIELD"+    show FragmentDefinition = "FRAGMENT_DEFINITION"+    show FragmentSpread = "FRAGMENT_SPREAD"+    show InlineFragment = "INLINE_FRAGMENT"+ -- | Where directives can appear in a type system definition. data TypeSystemDirectiveLocation     = Schema@@ -42,4 +59,17 @@     | EnumValue     | InputObject     | InputFieldDefinition-    deriving (Eq, Show)+    deriving Eq++instance Show TypeSystemDirectiveLocation where+    show Schema = "SCHEMA"+    show Scalar = "SCALAR"+    show Object = "OBJECT"+    show FieldDefinition = "FIELD_DEFINITION"+    show ArgumentDefinition = "ARGUMENT_DEFINITION"+    show Interface = "INTERFACE"+    show Union = "UNION"+    show Enum = "ENUM"+    show EnumValue = "ENUM_VALUE"+    show InputObject = "INPUT_OBJECT"+    show InputFieldDefinition = "INPUT_FIELD_DEFINITION"

@@ -1,12 +1,15 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Safe #-}  -- | This module defines an abstract syntax tree for the @GraphQL@ language. It -- follows closely the structure given in the specification. Please refer to -- <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>. -- for more information. module Language.GraphQL.AST.Document-    ( Alias-    , Argument(..)+    ( Argument(..)     , ArgumentsDefinition(..)     , ConstValue(..)     , Definition(..)@@ -15,13 +18,17 @@     , Document     , EnumValueDefinition(..)     , ExecutableDefinition(..)+    , Field(..)     , FieldDefinition(..)     , FragmentDefinition(..)+    , FragmentSpread(..)     , ImplementsInterfaces(..)+    , InlineFragment(..)     , InputValueDefinition(..)     , Location(..)     , Name     , NamedType+    , Node(..)     , NonNullType(..)     , ObjectField(..)     , OperationDefinition(..)@@ -47,7 +54,7 @@ import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) import qualified Data.Text as Text-import Language.GraphQL.AST.DirectiveLocation+import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation)  -- * Language @@ -68,6 +75,15 @@         | thisLine > thatLine = GT         | otherwise = compare thisColumn thatColumn +-- | Contains some tree node with a location.+data Node a = Node+    { node :: a+    , location :: Location+    } deriving (Eq, Show)++instance Functor Node where+    fmap f Node{..} = Node (f node) location+ -- ** Document  -- | GraphQL document.@@ -116,10 +132,15 @@ -- | Field selection. type SelectionSetOpt = [Selection] --- | Selection is a single entry in a selection set. It can be a single field,--- fragment spread or inline fragment.------ The only required property of a field is its name. Optionally it can also+-- | Selection is a single entry in a selection set. It can be a single 'Field',+-- 'FragmentSpread' or an 'InlineFragment'.+data Selection+    = FieldSelection Field+    | FragmentSpreadSelection FragmentSpread+    | InlineFragmentSelection InlineFragment+    deriving (Eq, Show)++-- | The only required property of a field is its name. Optionally it can also -- have an alias, arguments, directives and a list of subfields. -- -- In the following query "user" is a field with two subfields, "id" and "name":@@ -132,8 +153,27 @@ --   } -- } -- @+data Field =+    Field (Maybe Name) Name [Argument] [Directive] SelectionSetOpt Location+    deriving (Eq, Show)++-- | Inline fragments don't have any name and the type condition ("on UserType")+-- is optional. ----- A fragment spread refers to a fragment defined outside the operation and is+-- @+-- {+--   user {+--     ... on UserType {+--       id+--       name+--     }+-- }+-- @+data InlineFragment = InlineFragment+    (Maybe TypeCondition) [Directive] SelectionSet Location+    deriving (Eq, Show)++-- | A fragment spread refers to a fragment defined outside the operation and is -- expanded at the execution time. -- -- @@@ -148,23 +188,7 @@ --   name -- } -- @------ Inline fragments are similar but they don't have any name and the type--- condition ("on UserType") is optional.------ @--- {---   user {---     ... on UserType {---       id---       name---     }--- }--- @-data Selection-    = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt-    | FragmentSpread Name [Directive]-    | InlineFragment (Maybe TypeCondition) [Directive] SelectionSet+data FragmentSpread = FragmentSpread Name [Directive] Location     deriving (Eq, Show)  -- ** Arguments@@ -180,23 +204,7 @@ -- @ -- --  Here "id" is an argument for the field "user" and its value is 4.-data Argument = Argument Name Value deriving (Eq,Show)---- ** Field Alias---- | Alternative field name.------ @--- {---   smallPic: profilePic(size: 64)---   bigPic: profilePic(size: 1024)--- }--- @------ Here "smallPic" and "bigPic" are aliases for the same field, "profilePic",--- used to distinquish between profile pictures with different arguments--- (sizes).-type Alias = Name+data Argument = Argument Name (Node Value) Location deriving (Eq, Show)  -- ** Fragments @@ -238,8 +246,11 @@ -- | Key-value pair. -- -- A list of 'ObjectField's represents a GraphQL object type.-data ObjectField a = ObjectField Name a-    deriving (Eq, Show)+data ObjectField a = ObjectField+    { name :: Name+    , value :: Node a+    , location :: Location+    } deriving (Eq, Show)  -- ** Variables @@ -259,7 +270,8 @@ -- -- Variables are usually passed along with the query, but not in the query -- itself. They make queries reusable.-data VariableDefinition = VariableDefinition Name Type (Maybe ConstValue)+data VariableDefinition =+    VariableDefinition Name Type (Maybe (Node ConstValue)) Location     deriving (Eq, Show)  -- ** Type References@@ -286,7 +298,7 @@ -- -- Directives begin with "@", can accept arguments, and can be applied to the -- most GraphQL elements, providing additional information.-data Directive = Directive Name [Argument] deriving (Eq, Show)+data Directive = Directive Name [Argument] Location deriving (Eq, Show)  -- * Type System @@ -485,8 +497,8 @@ -- @ -- -- The input type "Point2D" contains two value definitions: "x" and "y".-data InputValueDefinition-    = InputValueDefinition Description Name Type (Maybe ConstValue) [Directive]+data InputValueDefinition = InputValueDefinition+    Description Name Type (Maybe (Node ConstValue)) [Directive]     deriving (Eq, Show)  -- ** Unions

@@ -1,6 +1,8 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Safe #-}  -- | This module defines a minifier and a printer for the @GraphQL@ language. module Language.GraphQL.AST.Encoder@@ -25,7 +27,7 @@ import qualified Data.Text.Lazy.Builder as Builder import Data.Text.Lazy.Builder.Int (decimal, hexadecimal) import Data.Text.Lazy.Builder.RealFloat (realFloat)-import Language.GraphQL.AST.Document+import qualified Language.GraphQL.AST.Document as Full  -- | Instructs the encoder whether the GraphQL document should be minified or --   pretty printed.@@ -44,77 +46,78 @@ minified = Minified  -- | Converts a Document' into a string.-document :: Formatter -> Document -> Lazy.Text+document :: Formatter -> Full.Document -> Lazy.Text document formatter defs     | Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument     | Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'   where     encodeDocument = foldr executableDefinition [] defs-    executableDefinition (ExecutableDefinition executableDefinition') acc =+    executableDefinition (Full.ExecutableDefinition executableDefinition') acc =         definition formatter executableDefinition' : acc     executableDefinition _ acc = acc --- | Converts a t'ExecutableDefinition' into a string.-definition :: Formatter -> ExecutableDefinition -> Lazy.Text+-- | Converts a t'Full.ExecutableDefinition' into a string.+definition :: Formatter -> Full.ExecutableDefinition -> Lazy.Text definition formatter x     | Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'     | Minified <- formatter = encodeDefinition x   where-    encodeDefinition (DefinitionOperation operation)+    encodeDefinition (Full.DefinitionOperation operation)         = operationDefinition formatter operation-    encodeDefinition (DefinitionFragment fragment)+    encodeDefinition (Full.DefinitionFragment fragment)         = fragmentDefinition formatter fragment --- | Converts a 'OperationDefinition into a string.-operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text+-- | Converts a 'Full.OperationDefinition into a string.+operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text operationDefinition formatter = \case-    SelectionSet sels _ -> selectionSet formatter sels-    OperationDefinition Query name vars dirs sels _ ->-        "query " <> node formatter name vars dirs sels-    OperationDefinition Mutation name vars dirs sels _ ->-        "mutation " <> node formatter name vars dirs sels-    OperationDefinition Subscription name vars dirs sels _ ->-        "subscription " <> node formatter name vars dirs sels---- | Converts a Query or Mutation into a string.-node :: Formatter ->-    Maybe Name ->-    [VariableDefinition] ->-    [Directive] ->-    SelectionSet ->-    Lazy.Text-node formatter name vars dirs sels-    = Lazy.Text.fromStrict (fold name)-    <> optempty (variableDefinitions formatter) vars-    <> optempty (directives formatter) dirs-    <> eitherFormat formatter " " mempty-    <> selectionSet formatter sels+    Full.SelectionSet sels _ -> selectionSet formatter sels+    Full.OperationDefinition Full.Query name vars dirs sels _ ->+        "query " <> root name vars dirs sels+    Full.OperationDefinition Full.Mutation name vars dirs sels _ ->+        "mutation " <> root name vars dirs sels+    Full.OperationDefinition Full.Subscription name vars dirs sels _ ->+        "subscription " <> root name vars dirs sels+  where+    -- | Converts a Query or Mutation into a string.+    root :: Maybe Full.Name ->+        [Full.VariableDefinition] ->+        [Full.Directive] ->+        Full.SelectionSet ->+        Lazy.Text+    root name vars dirs sels+        = Lazy.Text.fromStrict (fold name)+        <> optempty (variableDefinitions formatter) vars+        <> optempty (directives formatter) dirs+        <> eitherFormat formatter " " mempty+        <> selectionSet formatter sels -variableDefinitions :: Formatter -> [VariableDefinition] -> Lazy.Text+variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Lazy.Text variableDefinitions formatter     = parensCommas formatter $ variableDefinition formatter -variableDefinition :: Formatter -> VariableDefinition -> Lazy.Text-variableDefinition formatter (VariableDefinition var ty defaultValue')-    = variable var+variableDefinition :: Formatter -> Full.VariableDefinition -> Lazy.Text+variableDefinition formatter variableDefinition' =+    let Full.VariableDefinition variableName variableType defaultValue' _ =+            variableDefinition'+     in variable variableName     <> eitherFormat formatter ": " ":"-    <> type' ty-    <> maybe mempty (defaultValue formatter) defaultValue'+    <> type' variableType+    <> maybe mempty (defaultValue formatter) (Full.node <$> defaultValue') -defaultValue :: Formatter -> ConstValue -> Lazy.Text+defaultValue :: Formatter -> Full.ConstValue -> Lazy.Text defaultValue formatter val     = eitherFormat formatter " = " "="     <> value formatter (fromConstValue val) -variable :: Name -> Lazy.Text+variable :: Full.Name -> Lazy.Text variable var = "$" <> Lazy.Text.fromStrict var -selectionSet :: Formatter -> SelectionSet -> Lazy.Text+selectionSet :: Formatter -> Full.SelectionSet -> Lazy.Text selectionSet formatter     = bracesList formatter (selection formatter)     . NonEmpty.toList -selectionSetOpt :: Formatter -> SelectionSetOpt -> Lazy.Text+selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text selectionSetOpt formatter = bracesList formatter $ selection formatter  indentSymbol :: Lazy.Text@@ -123,15 +126,15 @@ indent :: (Integral a) => a -> Lazy.Text indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol -selection :: Formatter -> Selection -> Lazy.Text+selection :: Formatter -> Full.Selection -> Lazy.Text selection formatter = Lazy.Text.append indent' . encodeSelection   where-    encodeSelection (Field alias name args directives' selections) =-        field incrementIndent alias name args directives' selections-    encodeSelection (InlineFragment typeCondition directives' selections) =-        inlineFragment incrementIndent typeCondition directives' selections-    encodeSelection (FragmentSpread name directives') =-        fragmentSpread incrementIndent name directives'+    encodeSelection (Full.FieldSelection fieldSelection) =+        field incrementIndent fieldSelection+    encodeSelection (Full.InlineFragmentSelection fragmentSelection) =+        inlineFragment incrementIndent fragmentSelection+    encodeSelection (Full.FragmentSpreadSelection fragmentSelection) =+        fragmentSpread incrementIndent fragmentSelection     incrementIndent         | Pretty indentation <- formatter = Pretty $ indentation + 1         | otherwise = Minified@@ -142,15 +145,9 @@ colon :: Formatter -> Lazy.Text colon formatter = eitherFormat formatter ": " ":" --- | Converts Field into a string-field :: Formatter ->-    Maybe Name ->-    Name ->-    [Argument] ->-    [Directive] ->-    [Selection] ->-    Lazy.Text-field formatter alias name args dirs set+-- | Converts Field into a string.+field :: Formatter -> Full.Field -> Lazy.Text+field formatter (Full.Field alias name args dirs set _)     = optempty prependAlias (fold alias)     <> Lazy.Text.fromStrict name     <> optempty (arguments formatter) args@@ -161,36 +158,32 @@     selectionSetOpt' = (eitherFormat formatter " " "" <>)         . selectionSetOpt formatter -arguments :: Formatter -> [Argument] -> Lazy.Text+arguments :: Formatter -> [Full.Argument] -> Lazy.Text arguments formatter = parensCommas formatter $ argument formatter -argument :: Formatter -> Argument -> Lazy.Text-argument formatter (Argument name value')+argument :: Formatter -> Full.Argument -> Lazy.Text+argument formatter (Full.Argument name value' _)     = Lazy.Text.fromStrict name     <> colon formatter-    <> value formatter value'+    <> value formatter (Full.node value')  -- * Fragments -fragmentSpread :: Formatter -> Name -> [Directive] -> Lazy.Text-fragmentSpread formatter name directives'+fragmentSpread :: Formatter -> Full.FragmentSpread -> Lazy.Text+fragmentSpread formatter (Full.FragmentSpread name directives' _)     = "..." <> Lazy.Text.fromStrict name     <> optempty (directives formatter) directives' -inlineFragment ::-    Formatter ->-    Maybe TypeCondition ->-    [Directive] ->-    SelectionSet ->-    Lazy.Text-inlineFragment formatter tc dirs sels = "... on "-    <> Lazy.Text.fromStrict (fold tc)-    <> directives formatter dirs+inlineFragment :: Formatter -> Full.InlineFragment -> Lazy.Text+inlineFragment formatter (Full.InlineFragment typeCondition directives' selections _)+    = "... on "+    <> Lazy.Text.fromStrict (fold typeCondition)+    <> directives formatter directives'     <> eitherFormat formatter " " mempty-    <> selectionSet formatter sels+    <> selectionSet formatter selections -fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text-fragmentDefinition formatter (FragmentDefinition name tc dirs sels _)+fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Lazy.Text+fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels _)     = "fragment " <> Lazy.Text.fromStrict name     <> " on " <> Lazy.Text.fromStrict tc     <> optempty (directives formatter) dirs@@ -199,39 +192,39 @@  -- * Miscellaneous --- | Converts a 'Directive' into a string.-directive :: Formatter -> Directive -> Lazy.Text-directive formatter (Directive name args)+-- | Converts a 'Full.Directive' into a string.+directive :: Formatter -> Full.Directive -> Lazy.Text+directive formatter (Full.Directive name args _)     = "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args -directives :: Formatter -> [Directive] -> Lazy.Text+directives :: Formatter -> [Full.Directive] -> Lazy.Text directives Minified = spaces (directive Minified) directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter) --- | Converts a 'Value' into a string.-value :: Formatter -> Value -> Lazy.Text-value _ (Variable x) = variable x-value _ (Int x) = Builder.toLazyText $ decimal x-value _ (Float x) = Builder.toLazyText $ realFloat x-value _ (Boolean  x) = booleanValue x-value _ Null = "null"-value formatter (String string) = stringValue formatter string-value _ (Enum x) = Lazy.Text.fromStrict x-value formatter (List x) = listValue formatter x-value formatter (Object x) = objectValue formatter x+-- | Converts a 'Full.Value' into a string.+value :: Formatter -> Full.Value -> Lazy.Text+value _ (Full.Variable x) = variable x+value _ (Full.Int x) = Builder.toLazyText $ decimal x+value _ (Full.Float x) = Builder.toLazyText $ realFloat x+value _ (Full.Boolean  x) = booleanValue x+value _ Full.Null = "null"+value formatter (Full.String string) = stringValue formatter string+value _ (Full.Enum x) = Lazy.Text.fromStrict x+value formatter (Full.List x) = listValue formatter x+value formatter (Full.Object x) = objectValue formatter x -fromConstValue :: ConstValue -> Value-fromConstValue (ConstInt x) = Int x-fromConstValue (ConstFloat x) = Float x-fromConstValue (ConstBoolean  x) = Boolean x-fromConstValue ConstNull = Null-fromConstValue (ConstString string) = String string-fromConstValue (ConstEnum x) = Enum x-fromConstValue (ConstList x) = List $ fromConstValue <$> x-fromConstValue (ConstObject x) = Object $ fromConstObjectField <$> x+fromConstValue :: Full.ConstValue -> Full.Value+fromConstValue (Full.ConstInt x) = Full.Int x+fromConstValue (Full.ConstFloat x) = Full.Float x+fromConstValue (Full.ConstBoolean  x) = Full.Boolean x+fromConstValue Full.ConstNull = Full.Null+fromConstValue (Full.ConstString string) = Full.String string+fromConstValue (Full.ConstEnum x) = Full.Enum x+fromConstValue (Full.ConstList x) = Full.List $ fromConstValue <$> x+fromConstValue (Full.ConstObject x) = Full.Object $ fromConstObjectField <$> x   where-    fromConstObjectField (ObjectField key value') =-        ObjectField key $ fromConstValue value'+    fromConstObjectField Full.ObjectField{value = value', ..} =+        Full.ObjectField name (fromConstValue <$> value') location  booleanValue :: Bool -> Lazy.Text booleanValue True  = "true"@@ -288,10 +281,10 @@   where     unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord) -listValue :: Formatter -> [Value] -> Lazy.Text+listValue :: Formatter -> [Full.Value] -> Lazy.Text listValue formatter = bracketsCommas formatter $ value formatter -objectValue :: Formatter -> [ObjectField Value] -> Lazy.Text+objectValue :: Formatter -> [Full.ObjectField Full.Value] -> Lazy.Text objectValue formatter = intercalate $ objectField formatter   where     intercalate f@@ -299,22 +292,22 @@         . Lazy.Text.intercalate (eitherFormat formatter ", " ",")         . fmap f -objectField :: Formatter -> ObjectField Value -> Lazy.Text-objectField formatter (ObjectField name value') =+objectField :: Formatter -> Full.ObjectField Full.Value -> Lazy.Text+objectField formatter (Full.ObjectField name (Full.Node value' _) _) =     Lazy.Text.fromStrict name <> colon formatter <> value formatter value' --- | Converts a 'Type' a type into a string.-type' :: Type -> Lazy.Text-type' (TypeNamed   x) = Lazy.Text.fromStrict x-type' (TypeList    x) = listType x-type' (TypeNonNull x) = nonNullType x+-- | Converts a 'Full.Type' a type into a string.+type' :: Full.Type -> Lazy.Text+type' (Full.TypeNamed x) = Lazy.Text.fromStrict x+type' (Full.TypeList x) = listType x+type' (Full.TypeNonNull x) = nonNullType x -listType :: Type -> Lazy.Text+listType :: Full.Type -> Lazy.Text listType x = brackets (type' x) -nonNullType :: NonNullType -> Lazy.Text-nonNullType (NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"-nonNullType (NonNullTypeList  x) = listType x <> "!"+nonNullType :: Full.NonNullType -> Lazy.Text+nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"+nonNullType (Full.NonNullTypeList x) = listType x <> "!"  -- * Internal 

@@ -92,16 +92,16 @@ dollar = symbol "$"  -- | Parser for "@".-at :: Parser Text-at = symbol "@"+at :: Parser ()+at = symbol "@" >> pure ()  -- | Parser for "&". amp :: Parser T.Text amp = symbol "&"  -- | Parser for ":".-colon :: Parser T.Text-colon = symbol ":"+colon :: Parser ()+colon = symbol ":" >> pure ()  -- | Parser for "=". equals :: Parser T.Text

@@ -1,3 +1,4 @@+{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}@@ -18,7 +19,7 @@     , ExecutableDirectiveLocation     , TypeSystemDirectiveLocation     )-import Language.GraphQL.AST.Document+import qualified Language.GraphQL.AST.Document as Full import Language.GraphQL.AST.Lexer import Text.Megaparsec     ( MonadParsec(..)@@ -32,13 +33,13 @@     )  -- | Parser for the GraphQL documents.-document :: Parser Document+document :: Parser Full.Document document = unicodeBOM     *> spaceConsumer     *> lexeme (NonEmpty.some definition) -definition :: Parser Definition-definition = ExecutableDefinition <$> executableDefinition+definition :: Parser Full.Definition+definition = Full.ExecutableDefinition <$> executableDefinition     <|> typeSystemDefinition'     <|> typeSystemExtension'     <?> "Definition"@@ -46,41 +47,41 @@     typeSystemDefinition' = do         location <- getLocation         definition' <- typeSystemDefinition-        pure $ TypeSystemDefinition definition' location+        pure $ Full.TypeSystemDefinition definition' location     typeSystemExtension' = do         location <- getLocation         definition' <- typeSystemExtension-        pure $ TypeSystemExtension definition' location+        pure $ Full.TypeSystemExtension definition' location -getLocation :: Parser Location+getLocation :: Parser Full.Location getLocation = fromSourcePosition <$> getSourcePos   where     fromSourcePosition SourcePos{..} =-        Location (wordFromPosition sourceLine) (wordFromPosition sourceColumn)+        Full.Location (wordFromPosition sourceLine) (wordFromPosition sourceColumn)     wordFromPosition = fromIntegral . unPos -executableDefinition :: Parser ExecutableDefinition-executableDefinition = DefinitionOperation <$> operationDefinition-    <|> DefinitionFragment  <$> fragmentDefinition+executableDefinition :: Parser Full.ExecutableDefinition+executableDefinition = Full.DefinitionOperation <$> operationDefinition+    <|> Full.DefinitionFragment  <$> fragmentDefinition     <?> "ExecutableDefinition" -typeSystemDefinition :: Parser TypeSystemDefinition+typeSystemDefinition :: Parser Full.TypeSystemDefinition typeSystemDefinition = schemaDefinition     <|> typeSystemDefinitionWithDescription     <?> "TypeSystemDefinition"   where     typeSystemDefinitionWithDescription = description         >>= liftA2 (<|>) typeDefinition' directiveDefinition-    typeDefinition' description' = TypeDefinition+    typeDefinition' description' = Full.TypeDefinition         <$> typeDefinition description' -typeSystemExtension :: Parser TypeSystemExtension-typeSystemExtension = SchemaExtension <$> schemaExtension-    <|> TypeExtension <$> typeExtension+typeSystemExtension :: Parser Full.TypeSystemExtension+typeSystemExtension = Full.SchemaExtension <$> schemaExtension+    <|> Full.TypeExtension <$> typeExtension     <?> "TypeSystemExtension" -directiveDefinition :: Description -> Parser TypeSystemDefinition-directiveDefinition description' = DirectiveDefinition description'+directiveDefinition :: Full.Description -> Parser Full.TypeSystemDefinition+directiveDefinition description' = Full.DirectiveDefinition description'     <$ symbol "directive"     <* at     <*> name@@ -124,7 +125,7 @@     <|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION"     <?> "TypeSystemDirectiveLocation" -typeDefinition :: Description -> Parser TypeDefinition+typeDefinition :: Full.Description -> Parser Full.TypeDefinition typeDefinition description' = scalarTypeDefinition description'     <|> objectTypeDefinition description'     <|> interfaceTypeDefinition description'@@ -133,7 +134,7 @@     <|> inputObjectTypeDefinition description'     <?> "TypeDefinition" -typeExtension :: Parser TypeExtension+typeExtension :: Parser Full.TypeExtension typeExtension = scalarTypeExtension     <|> objectTypeExtension     <|> interfaceTypeExtension@@ -142,143 +143,143 @@     <|> inputObjectTypeExtension     <?> "TypeExtension" -scalarTypeDefinition :: Description -> Parser TypeDefinition-scalarTypeDefinition description' = ScalarTypeDefinition description'+scalarTypeDefinition :: Full.Description -> Parser Full.TypeDefinition+scalarTypeDefinition description' = Full.ScalarTypeDefinition description'     <$ symbol "scalar"     <*> name     <*> directives     <?> "ScalarTypeDefinition" -scalarTypeExtension :: Parser TypeExtension+scalarTypeExtension :: Parser Full.TypeExtension scalarTypeExtension = extend "scalar" "ScalarTypeExtension"-    $ (ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| []+    $ (Full.ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| [] -objectTypeDefinition :: Description -> Parser TypeDefinition-objectTypeDefinition description' = ObjectTypeDefinition description'+objectTypeDefinition :: Full.Description -> Parser Full.TypeDefinition+objectTypeDefinition description' = Full.ObjectTypeDefinition description'     <$ symbol "type"     <*> name-    <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)+    <*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)     <*> directives     <*> braces (many fieldDefinition)     <?> "ObjectTypeDefinition" -objectTypeExtension :: Parser TypeExtension+objectTypeExtension :: Parser Full.TypeExtension objectTypeExtension = extend "type" "ObjectTypeExtension"     $ fieldsDefinitionExtension :|         [ directivesExtension         , implementsInterfacesExtension         ]   where-    fieldsDefinitionExtension = ObjectTypeFieldsDefinitionExtension+    fieldsDefinitionExtension = Full.ObjectTypeFieldsDefinitionExtension         <$> name-        <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)+        <*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)         <*> directives         <*> braces (NonEmpty.some fieldDefinition)-    directivesExtension = ObjectTypeDirectivesExtension+    directivesExtension = Full.ObjectTypeDirectivesExtension         <$> name-        <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)+        <*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)         <*> NonEmpty.some directive-    implementsInterfacesExtension = ObjectTypeImplementsInterfacesExtension+    implementsInterfacesExtension = Full.ObjectTypeImplementsInterfacesExtension         <$> name         <*> implementsInterfaces NonEmpty.sepBy1 -description :: Parser Description-description = Description+description :: Parser Full.Description+description = Full.Description     <$> optional stringValue     <?> "Description" -unionTypeDefinition :: Description -> Parser TypeDefinition-unionTypeDefinition description' = UnionTypeDefinition description'+unionTypeDefinition :: Full.Description -> Parser Full.TypeDefinition+unionTypeDefinition description' = Full.UnionTypeDefinition description'     <$ symbol "union"     <*> name     <*> directives-    <*> option (UnionMemberTypes []) (unionMemberTypes sepBy1)+    <*> option (Full.UnionMemberTypes []) (unionMemberTypes sepBy1)     <?> "UnionTypeDefinition" -unionTypeExtension :: Parser TypeExtension+unionTypeExtension :: Parser Full.TypeExtension unionTypeExtension = extend "union" "UnionTypeExtension"     $ unionMemberTypesExtension :| [directivesExtension]   where-    unionMemberTypesExtension = UnionTypeUnionMemberTypesExtension+    unionMemberTypesExtension = Full.UnionTypeUnionMemberTypesExtension         <$> name         <*> directives         <*> unionMemberTypes NonEmpty.sepBy1-    directivesExtension = UnionTypeDirectivesExtension+    directivesExtension = Full.UnionTypeDirectivesExtension         <$> name         <*> NonEmpty.some directive  unionMemberTypes ::     Foldable t =>-    (Parser Text -> Parser Text -> Parser (t NamedType)) ->-    Parser (UnionMemberTypes t)-unionMemberTypes sepBy' = UnionMemberTypes+    (Parser Text -> Parser Text -> Parser (t Full.NamedType)) ->+    Parser (Full.UnionMemberTypes t)+unionMemberTypes sepBy' = Full.UnionMemberTypes     <$ equals     <* optional pipe     <*> name `sepBy'` pipe     <?> "UnionMemberTypes" -interfaceTypeDefinition :: Description -> Parser TypeDefinition-interfaceTypeDefinition description' = InterfaceTypeDefinition description'+interfaceTypeDefinition :: Full.Description -> Parser Full.TypeDefinition+interfaceTypeDefinition description' = Full.InterfaceTypeDefinition description'     <$ symbol "interface"     <*> name     <*> directives     <*> braces (many fieldDefinition)     <?> "InterfaceTypeDefinition" -interfaceTypeExtension :: Parser TypeExtension+interfaceTypeExtension :: Parser Full.TypeExtension interfaceTypeExtension = extend "interface" "InterfaceTypeExtension"     $ fieldsDefinitionExtension :| [directivesExtension]   where-    fieldsDefinitionExtension = InterfaceTypeFieldsDefinitionExtension+    fieldsDefinitionExtension = Full.InterfaceTypeFieldsDefinitionExtension         <$> name         <*> directives         <*> braces (NonEmpty.some fieldDefinition)-    directivesExtension = InterfaceTypeDirectivesExtension+    directivesExtension = Full.InterfaceTypeDirectivesExtension         <$> name         <*> NonEmpty.some directive -enumTypeDefinition :: Description -> Parser TypeDefinition-enumTypeDefinition description' = EnumTypeDefinition description'+enumTypeDefinition :: Full.Description -> Parser Full.TypeDefinition+enumTypeDefinition description' = Full.EnumTypeDefinition description'     <$ symbol "enum"     <*> name     <*> directives     <*> listOptIn braces enumValueDefinition     <?> "EnumTypeDefinition" -enumTypeExtension :: Parser TypeExtension+enumTypeExtension :: Parser Full.TypeExtension enumTypeExtension = extend "enum" "EnumTypeExtension"     $ enumValuesDefinitionExtension :| [directivesExtension]   where-    enumValuesDefinitionExtension = EnumTypeEnumValuesDefinitionExtension+    enumValuesDefinitionExtension = Full.EnumTypeEnumValuesDefinitionExtension         <$> name         <*> directives         <*> braces (NonEmpty.some enumValueDefinition)-    directivesExtension = EnumTypeDirectivesExtension+    directivesExtension = Full.EnumTypeDirectivesExtension         <$> name         <*> NonEmpty.some directive -inputObjectTypeDefinition :: Description -> Parser TypeDefinition-inputObjectTypeDefinition description' = InputObjectTypeDefinition description'+inputObjectTypeDefinition :: Full.Description -> Parser Full.TypeDefinition+inputObjectTypeDefinition description' = Full.InputObjectTypeDefinition description'     <$ symbol "input"     <*> name     <*> directives     <*> listOptIn braces inputValueDefinition     <?> "InputObjectTypeDefinition" -inputObjectTypeExtension :: Parser TypeExtension+inputObjectTypeExtension :: Parser Full.TypeExtension inputObjectTypeExtension = extend "input" "InputObjectTypeExtension"     $ inputFieldsDefinitionExtension :| [directivesExtension]   where-    inputFieldsDefinitionExtension = InputObjectTypeInputFieldsDefinitionExtension+    inputFieldsDefinitionExtension = Full.InputObjectTypeInputFieldsDefinitionExtension         <$> name         <*> directives         <*> braces (NonEmpty.some inputValueDefinition)-    directivesExtension = InputObjectTypeDirectivesExtension+    directivesExtension = Full.InputObjectTypeDirectivesExtension         <$> name         <*> NonEmpty.some directive -enumValueDefinition :: Parser EnumValueDefinition-enumValueDefinition = EnumValueDefinition+enumValueDefinition :: Parser Full.EnumValueDefinition+enumValueDefinition = Full.EnumValueDefinition     <$> description     <*> enumValue     <*> directives@@ -286,16 +287,16 @@  implementsInterfaces ::     Foldable t =>-    (Parser Text -> Parser Text -> Parser (t NamedType)) ->-    Parser (ImplementsInterfaces t)-implementsInterfaces sepBy' = ImplementsInterfaces+    (Parser Text -> Parser Text -> Parser (t Full.NamedType)) ->+    Parser (Full.ImplementsInterfaces t)+implementsInterfaces sepBy' = Full.ImplementsInterfaces     <$ symbol "implements"     <* optional amp     <*> name `sepBy'` amp     <?> "ImplementsInterfaces" -inputValueDefinition :: Parser InputValueDefinition-inputValueDefinition = InputValueDefinition+inputValueDefinition :: Parser Full.InputValueDefinition+inputValueDefinition = Full.InputValueDefinition     <$> description     <*> name     <* colon@@ -304,13 +305,13 @@     <*> directives     <?> "InputValueDefinition" -argumentsDefinition :: Parser ArgumentsDefinition-argumentsDefinition = ArgumentsDefinition+argumentsDefinition :: Parser Full.ArgumentsDefinition+argumentsDefinition = Full.ArgumentsDefinition     <$> listOptIn parens inputValueDefinition     <?> "ArgumentsDefinition" -fieldDefinition :: Parser FieldDefinition-fieldDefinition = FieldDefinition+fieldDefinition :: Parser Full.FieldDefinition+fieldDefinition = Full.FieldDefinition     <$> description     <*> name     <*> argumentsDefinition@@ -319,33 +320,33 @@     <*> directives     <?> "FieldDefinition" -schemaDefinition :: Parser TypeSystemDefinition-schemaDefinition = SchemaDefinition+schemaDefinition :: Parser Full.TypeSystemDefinition+schemaDefinition = Full.SchemaDefinition     <$ symbol "schema"     <*> directives     <*> operationTypeDefinitions     <?> "SchemaDefinition" -operationTypeDefinitions :: Parser (NonEmpty OperationTypeDefinition)+operationTypeDefinitions :: Parser (NonEmpty Full.OperationTypeDefinition) operationTypeDefinitions = braces $ NonEmpty.some operationTypeDefinition -schemaExtension :: Parser SchemaExtension+schemaExtension :: Parser Full.SchemaExtension schemaExtension = extend "schema" "SchemaExtension"     $ schemaOperationExtension :| [directivesExtension]   where-    directivesExtension = SchemaDirectivesExtension+    directivesExtension = Full.SchemaDirectivesExtension         <$> NonEmpty.some directive-    schemaOperationExtension = SchemaOperationExtension+    schemaOperationExtension = Full.SchemaOperationExtension         <$> directives         <*> operationTypeDefinitions -operationTypeDefinition :: Parser OperationTypeDefinition-operationTypeDefinition = OperationTypeDefinition+operationTypeDefinition :: Parser Full.OperationTypeDefinition+operationTypeDefinition = Full.OperationTypeDefinition     <$> operationType <* colon     <*> name     <?> "OperationTypeDefinition" -operationDefinition :: Parser OperationDefinition+operationDefinition :: Parser Full.OperationDefinition operationDefinition = shorthand     <|> operationDefinition'     <?> "OperationDefinition"@@ -353,7 +354,7 @@     shorthand = do         location <- getLocation         selectionSet' <- selectionSet-        pure $ SelectionSet selectionSet' location+        pure $ Full.SelectionSet selectionSet' location     operationDefinition' = do         location <- getLocation         operationType' <- operationType@@ -361,60 +362,74 @@         variableDefinitions' <- variableDefinitions         directives' <- directives         selectionSet' <- selectionSet-        pure $ OperationDefinition operationType' operationName variableDefinitions' directives' selectionSet' location+        pure $ Full.OperationDefinition+            operationType'+            operationName+            variableDefinitions'+            directives'+            selectionSet'+            location -operationType :: Parser OperationType-operationType = Query <$ symbol "query"-    <|> Mutation <$ symbol "mutation"-    <|> Subscription <$ symbol "subscription"+operationType :: Parser Full.OperationType+operationType = Full.Query <$ symbol "query"+    <|> Full.Mutation <$ symbol "mutation"+    <|> Full.Subscription <$ symbol "subscription"     <?> "OperationType" -selectionSet :: Parser SelectionSet+selectionSet :: Parser Full.SelectionSet selectionSet = braces (NonEmpty.some selection) <?> "SelectionSet" -selectionSetOpt :: Parser SelectionSetOpt+selectionSetOpt :: Parser Full.SelectionSetOpt selectionSetOpt = listOptIn braces selection <?> "SelectionSet" -selection :: Parser Selection-selection = field-    <|> try fragmentSpread-    <|> inlineFragment+selection :: Parser Full.Selection+selection = Full.FieldSelection <$> field+    <|> Full.FragmentSpreadSelection <$> try fragmentSpread+    <|> Full.InlineFragmentSelection <$> inlineFragment     <?> "Selection" -field :: Parser Selection-field = Field-    <$> optional alias-    <*> name-    <*> arguments-    <*> directives-    <*> selectionSetOpt-    <?> "Field"+field :: Parser Full.Field+field = label "Field" $ do+    location <- getLocation+    alias' <- optional alias+    name' <- name+    arguments' <- arguments+    directives' <- directives+    selectionSetOpt' <- selectionSetOpt+    pure $ Full.Field alias' name' arguments' directives' selectionSetOpt' location -alias :: Parser Alias+alias :: Parser Full.Name alias = try (name <* colon) <?> "Alias" -arguments :: Parser [Argument]+arguments :: Parser [Full.Argument] arguments = listOptIn parens argument <?> "Arguments" -argument :: Parser Argument-argument = Argument <$> name <* colon <*> value <?> "Argument"+argument :: Parser Full.Argument+argument = label "Argument" $ do+    location <- getLocation+    name' <- name+    colon+    value' <- valueNode value+    pure $ Full.Argument name' value' location -fragmentSpread :: Parser Selection-fragmentSpread = FragmentSpread-    <$ spread-    <*> fragmentName-    <*> directives-    <?> "FragmentSpread"+fragmentSpread :: Parser Full.FragmentSpread+fragmentSpread = label "FragmentSpread" $ do+    location <- getLocation+    _ <- spread+    fragmentName' <- fragmentName+    directives' <- directives+    pure $ Full.FragmentSpread fragmentName' directives' location -inlineFragment :: Parser Selection-inlineFragment = InlineFragment-    <$ spread-    <*> optional typeCondition-    <*> directives-    <*> selectionSet-    <?> "InlineFragment"+inlineFragment :: Parser Full.InlineFragment+inlineFragment = label "InlineFragment" $ do+    location <- getLocation+    _ <- spread+    typeCondition' <- optional typeCondition+    directives' <- directives+    selectionSet' <- selectionSet+    pure $ Full.InlineFragment typeCondition' directives' selectionSet' location -fragmentDefinition :: Parser FragmentDefinition+fragmentDefinition :: Parser Full.FragmentDefinition fragmentDefinition =  label "FragmentDefinition" $ do     location <- getLocation     _ <- symbol "fragment"@@ -422,36 +437,42 @@     typeCondition' <- typeCondition     directives' <- directives     selectionSet' <- selectionSet-    pure $ FragmentDefinition+    pure $ Full.FragmentDefinition         fragmentName' typeCondition' directives' selectionSet' location -fragmentName :: Parser Name+fragmentName :: Parser Full.Name fragmentName = but (symbol "on") *> name <?> "FragmentName" -typeCondition :: Parser TypeCondition+typeCondition :: Parser Full.TypeCondition typeCondition = symbol "on" *> name <?> "TypeCondition" -value :: Parser Value-value = Variable <$> variable-    <|> Float <$> try float-    <|> Int <$> integer-    <|> Boolean <$> booleanValue-    <|> Null <$  nullValue-    <|> String <$> stringValue-    <|> Enum <$> try enumValue-    <|> List <$> brackets (some value)-    <|> Object <$> braces (some $ objectField value)+valueNode :: forall a. Parser a -> Parser (Full.Node a)+valueNode valueParser = do+    location <- getLocation+    value' <- valueParser+    pure $ Full.Node value' location++value :: Parser Full.Value+value = Full.Variable <$> variable+    <|> Full.Float <$> try float+    <|> Full.Int <$> integer+    <|> Full.Boolean <$> booleanValue+    <|> Full.Null <$  nullValue+    <|> Full.String <$> stringValue+    <|> Full.Enum <$> try enumValue+    <|> Full.List <$> brackets (some value)+    <|> Full.Object <$> braces (some $ objectField $ valueNode value)     <?> "Value" -constValue :: Parser ConstValue-constValue = ConstFloat <$> try float-    <|> ConstInt <$> integer-    <|> ConstBoolean <$> booleanValue-    <|> ConstNull <$ nullValue-    <|> ConstString <$> stringValue-    <|> ConstEnum <$> try enumValue-    <|> ConstList <$> brackets (some constValue)-    <|> ConstObject <$> braces (some $ objectField constValue)+constValue :: Parser Full.ConstValue+constValue = Full.ConstFloat <$> try float+    <|> Full.ConstInt <$> integer+    <|> Full.ConstBoolean <$> booleanValue+    <|> Full.ConstNull <$ nullValue+    <|> Full.ConstString <$> stringValue+    <|> Full.ConstEnum <$> try enumValue+    <|> Full.ConstList <$> brackets (some constValue)+    <|> Full.ConstObject <$> braces (some $ objectField $ valueNode constValue)     <?> "Value"  booleanValue :: Parser Bool@@ -459,7 +480,7 @@     <|> False <$ symbol "false"     <?> "BooleanValue" -enumValue :: Parser Name+enumValue :: Parser Full.Name enumValue = but (symbol "true")     *> but (symbol "false")     *> but (symbol "null")@@ -472,51 +493,54 @@ nullValue :: Parser Text nullValue = symbol "null" <?> "NullValue" -objectField :: Parser a -> Parser (ObjectField a)-objectField valueParser = ObjectField-    <$> name-    <* colon-    <*> valueParser-    <?> "ObjectField"+objectField :: forall a. Parser (Full.Node a) -> Parser (Full.ObjectField a)+objectField valueParser = label "ObjectField" $ do+    location <- getLocation+    fieldName <- name+    colon+    fieldValue <- valueParser+    pure $ Full.ObjectField fieldName fieldValue location -variableDefinitions :: Parser [VariableDefinition]+variableDefinitions :: Parser [Full.VariableDefinition] variableDefinitions = listOptIn parens variableDefinition     <?> "VariableDefinitions" -variableDefinition :: Parser VariableDefinition-variableDefinition = VariableDefinition-    <$> variable-    <*  colon-    <*> type'-    <*> defaultValue-    <?> "VariableDefinition"+variableDefinition :: Parser Full.VariableDefinition+variableDefinition = label "VariableDefinition" $ do+    location <- getLocation+    variableName <- variable+    colon+    variableType <- type'+    variableValue <- defaultValue+    pure $ Full.VariableDefinition variableName variableType variableValue location -variable :: Parser Name+variable :: Parser Full.Name variable = dollar *> name <?> "Variable" -defaultValue :: Parser (Maybe ConstValue)-defaultValue = optional (equals *> constValue) <?> "DefaultValue"+defaultValue :: Parser (Maybe (Full.Node Full.ConstValue))+defaultValue = optional (equals *> valueNode constValue) <?> "DefaultValue" -type' :: Parser Type-type' = try (TypeNonNull <$> nonNullType)-    <|> TypeList <$> brackets type'-    <|> TypeNamed <$> name+type' :: Parser Full.Type+type' = try (Full.TypeNonNull <$> nonNullType)+    <|> Full.TypeList <$> brackets type'+    <|> Full.TypeNamed <$> name     <?> "Type" -nonNullType :: Parser NonNullType-nonNullType = NonNullTypeNamed <$> name <* bang-    <|> NonNullTypeList  <$> brackets type'  <* bang+nonNullType :: Parser Full.NonNullType+nonNullType = Full.NonNullTypeNamed <$> name <* bang+    <|> Full.NonNullTypeList  <$> brackets type'  <* bang     <?> "NonNullType" -directives :: Parser [Directive]+directives :: Parser [Full.Directive] directives = many directive <?> "Directives" -directive :: Parser Directive-directive = Directive-    <$  at-    <*> name-    <*> arguments-    <?> "Directive"+directive :: Parser Full.Directive+directive = label "Directive" $ do+    location <- getLocation+    at+    directiveName <- name+    directiveArguments <- arguments+    pure $ Full.Directive directiveName directiveArguments location  listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a] listOptIn surround = option [] . surround . some

@@ -5,15 +5,16 @@  -- | Error handling. module Language.GraphQL.Error-    ( parseError-    , CollectErrsT+    ( CollectErrsT     , Error(..)+    , Path(..)     , Resolution(..)     , ResolverException(..)     , Response(..)     , ResponseEventStream     , addErr     , addErrMsg+    , parseError     , runCollectErrs     , singleError     ) where@@ -28,7 +29,7 @@ import qualified Data.Text as Text import Language.GraphQL.AST (Location(..), Name) import Language.GraphQL.Execute.Coerce-import Language.GraphQL.Type.Schema+import qualified Language.GraphQL.Type.Schema as Schema import Prelude hiding (null) import Text.Megaparsec     ( ParseErrorBundle(..)@@ -43,7 +44,7 @@ -- | Executor context. data Resolution m = Resolution     { errors :: Seq Error-    , types :: HashMap Name (Type m)+    , types :: HashMap Name (Schema.Type m)     }  -- | Wraps a parse error into a list of errors.@@ -57,6 +58,7 @@     errorObject s SourcePos{..} = Error         { message = Text.pack $ init $ parseErrorTextPretty s         , locations = [Location (unPos' sourceLine) (unPos' sourceColumn)]+        , path = []         }     unPos' = fromIntegral . unPos     go (result, state) x =@@ -75,7 +77,7 @@     appender resolution@Resolution{..} = resolution{ errors = errors |> v }  makeErrorMessage :: Text -> Error-makeErrorMessage s = Error s []+makeErrorMessage s = Error s [] []  -- | Constructs a response object containing only the error with the given -- message.@@ -86,10 +88,20 @@ addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null +-- | If an error can be associated to a particular field in the GraphQL result,+-- it must contain an entry with the key path that details the path of the+-- response field which experienced the error. This allows clients to identify+-- whether a null result is intentional or caused by a runtime error.+data Path+    = Segment Text -- ^ Field name.+    | Index Int -- ^ List index if a field returned a list.+    deriving (Eq, Show)+ -- | @GraphQL@ error. data Error = Error     { message :: Text     , locations :: [Location]+    , path :: [Path]     } deriving (Eq, Show)  -- | The server\'s response describes the result of executing the requested@@ -117,7 +129,7 @@ -- | Runs the given query computation, but collects the errors into an error -- list, which is then sent back with the data. runCollectErrs :: (Monad m, Serialize a)-    => HashMap Name (Type m)+    => HashMap Name (Schema.Type m)     -> CollectErrsT m a     -> m (Response a) runCollectErrs types' res = do

@@ -32,8 +32,8 @@     -> HashMap Name a -- ^ Variable substitution function.     -> Document -- @GraphQL@ document.     -> m (Either (ResponseEventStream m b) (Response b))-execute schema operationName subs document =-    case Transform.document schema operationName subs document of+execute schema' operationName subs document =+    case Transform.document schema' operationName subs document of         Left queryError -> pure             $ Right             $ singleError

@@ -27,8 +27,7 @@ import qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out-import Language.GraphQL.Type.Internal-import Language.GraphQL.Type.Schema+import qualified Language.GraphQL.Type.Internal as Internal import Prelude hiding (null)  resolveFieldValue :: MonadCatch m@@ -43,7 +42,7 @@         => ResolverException         -> CollectErrsT m Type.Value     handleFieldError e =-        addErr (Error (Text.pack $ displayException e) []) >> pure Type.Null+        addErr (Error (Text.pack $ displayException e) [] []) >> pure Type.Null     context = Type.Context         { Type.arguments = Type.Arguments args         , Type.values = result@@ -60,7 +59,7 @@          in Map.insertWith (<>) responseKey (field :| []) groupedFields     forEach groupedFields (Transform.SelectionFragment selectionFragment)         | Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment-        , doesFragmentTypeApply fragmentType objectType =+        , Internal.doesFragmentTypeApply fragmentType objectType =             let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet              in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet         | otherwise = groupedFields@@ -69,15 +68,15 @@ aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias  resolveAbstractType :: Monad m-    => AbstractType m+    => Internal.AbstractType m     -> Type.Subs     -> CollectErrsT m (Maybe (Out.ObjectType m)) resolveAbstractType abstractType values'     | Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do         types' <- gets types         case HashMap.lookup typeName types' of-            Just (ObjectType objectType) ->-                if instanceOf objectType abstractType+            Just (Internal.ObjectType objectType) ->+                if Internal.instanceOf objectType abstractType                     then pure $ Just objectType                     else pure Nothing             _ -> pure Nothing@@ -124,25 +123,25 @@     let Type.EnumType _ _ enumMembers = enumType      in if HashMap.member enum enumMembers         then coerceResult outputType $ Enum enum-        else addErrMsg "Value completion failed."+        else addErrMsg "Enum value completion failed." completeValue (Out.ObjectBaseType objectType) fields result =     executeSelectionSet result objectType $ mergeSelectionSets fields completeValue (Out.InterfaceBaseType interfaceType) fields result     | Type.Object objectMap <- result = do-        let abstractType = AbstractInterfaceType interfaceType+        let abstractType = Internal.AbstractInterfaceType interfaceType         concreteType <- resolveAbstractType abstractType objectMap         case concreteType of             Just objectType -> executeSelectionSet result objectType                 $ mergeSelectionSets fields-            Nothing -> addErrMsg "Value completion failed."+            Nothing -> addErrMsg "Interface value completion failed." completeValue (Out.UnionBaseType unionType) fields result     | Type.Object objectMap <- result = do-        let abstractType = AbstractUnionType unionType+        let abstractType = Internal.AbstractUnionType unionType         concreteType <- resolveAbstractType abstractType objectMap         case concreteType of             Just objectType -> executeSelectionSet result objectType                 $ mergeSelectionSets fields-            Nothing -> addErrMsg "Value completion failed."+            Nothing -> addErrMsg "Union value completion failed." completeValue _ _ _ = addErrMsg "Value completion failed."  mergeSelectionSets :: MonadCatch m

@@ -47,24 +47,23 @@ import qualified Language.GraphQL.Execute.Coerce as Coerce import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type as Type-import qualified Language.GraphQL.Type.In as In-import Language.GraphQL.Type.Internal+import qualified Language.GraphQL.Type.Internal as Type import qualified Language.GraphQL.Type.Out as Out-import Language.GraphQL.Type.Schema+import qualified Language.GraphQL.Type.Schema as Schema  -- | Associates a fragment name with a list of 'Field's. data Replacement m = Replacement     { fragments :: HashMap Full.Name (Fragment m)     , fragmentDefinitions :: FragmentDefinitions     , variableValues :: Type.Subs-    , types :: HashMap Full.Name (Type m)+    , types :: HashMap Full.Name (Schema.Type m)     }  type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition  -- | Represents fragments and inline fragments. data Fragment m-    = Fragment (CompositeType m) (Seq (Selection m))+    = Fragment (Type.CompositeType m) (Seq (Selection m))  -- | Single selection element. data Selection m@@ -85,7 +84,7 @@  -- | Contains the operation to be executed along with its root type. data Document m = Document-    (HashMap Full.Name (Type m)) (Out.ObjectType m) (Operation m)+    (HashMap Full.Name (Schema.Type m)) (Out.ObjectType m) (Operation m)  data OperationDefinition = OperationDefinition     Full.OperationType@@ -139,38 +138,9 @@     matchingName (OperationDefinition _ name _ _ _) =         name == Just operationName -lookupInputType-    :: Full.Type-    -> HashMap.HashMap Full.Name (Type m)-    -> Maybe In.Type-lookupInputType (Full.TypeNamed name) types =-    case HashMap.lookup name types of-        Just (ScalarType scalarType) ->-            Just $ In.NamedScalarType scalarType-        Just (EnumType enumType) ->-            Just $ In.NamedEnumType enumType-        Just (InputObjectType objectType) ->-            Just $ In.NamedInputObjectType objectType-        _ -> Nothing-lookupInputType (Full.TypeList list) types-    = In.ListType-    <$> lookupInputType list types-lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types  =-    case HashMap.lookup nonNull types of-        Just (ScalarType scalarType) ->-            Just $ In.NonNullScalarType scalarType-        Just (EnumType enumType) ->-            Just $ In.NonNullEnumType enumType-        Just (InputObjectType objectType) ->-            Just $ In.NonNullInputObjectType objectType-        _ -> Nothing-lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types-    = In.NonNullListType-    <$> lookupInputType nonNull types- coerceVariableValues :: Coerce.VariableValue a     => forall m-    . HashMap Full.Name (Type m)+    . HashMap Full.Name (Schema.Type m)     -> OperationDefinition     -> HashMap.HashMap Full.Name a     -> Either QueryError Type.Subs@@ -180,10 +150,10 @@         $ foldr forEach (Just HashMap.empty) variableDefinitions   where     forEach variableDefinition coercedValues = do-        let Full.VariableDefinition variableName variableTypeName defaultValue =+        let Full.VariableDefinition variableName variableTypeName defaultValue _ =                 variableDefinition-        let defaultValue' = constValue <$> defaultValue-        variableType <- lookupInputType variableTypeName types+        let defaultValue' = constValue . Full.node <$> defaultValue+        variableType <- Type.lookupInputType variableTypeName types          Coerce.matchFieldValues             coerceVariableValue'@@ -207,19 +177,20 @@ constValue (Full.ConstObject o) =     Type.Object $ HashMap.fromList $ constObjectField <$> o   where-    constObjectField (Full.ObjectField key value') = (key, constValue value')+    constObjectField Full.ObjectField{value = value', ..} =+        (name, constValue $ Full.node value')  -- | Rewrites the original syntax tree into an intermediate representation used -- for query execution. document :: Coerce.VariableValue a     => forall m-    . Schema m+    . Type.Schema m     -> Maybe Full.Name     -> HashMap Full.Name a     -> Full.Document     -> Either QueryError (Document m) document schema operationName subs ast = do-    let referencedTypes = collectReferencedTypes schema+    let referencedTypes = Schema.types schema      (operations, fragmentTable) <- defragment ast     chosenOperation <- getOperation operationName operations@@ -233,14 +204,14 @@             }     case chosenOperation of         OperationDefinition Full.Query _ _ _ _ ->-            pure $ Document referencedTypes (query schema)+            pure $ Document referencedTypes (Schema.query schema)                 $ operation chosenOperation replacement         OperationDefinition Full.Mutation _ _ _ _-            | Just mutationType <- mutation schema ->+            | Just mutationType <- Schema.mutation schema ->                 pure $ Document referencedTypes mutationType                     $ operation chosenOperation replacement         OperationDefinition Full.Subscription _ _ _ _-            | Just subscriptionType <- subscription schema ->+            | Just subscriptionType <- Schema.subscription schema ->                 pure $ Document referencedTypes subscriptionType                     $ operation chosenOperation replacement         _ -> Left UnsupportedRootOperation@@ -288,33 +259,47 @@ selection     :: Full.Selection     ->  State (Replacement m) (Either (Seq (Selection m)) (Selection m))-selection (Full.Field alias name arguments' directives' selections) =-    maybe (Left mempty) (Right . SelectionField) <$> do-        fieldArguments <- foldM go HashMap.empty arguments'-        fieldSelections <- appendSelection selections-        fieldDirectives <- Definition.selection <$> directives directives'-        let field' = Field alias name fieldArguments fieldSelections-        pure $ field' <$ fieldDirectives+selection (Full.FieldSelection fieldSelection) =+    maybe (Left mempty) (Right . SelectionField) <$> field fieldSelection+selection (Full.FragmentSpreadSelection fragmentSelection)+    = maybe (Left mempty) (Right . SelectionFragment)+    <$> fragmentSpread fragmentSelection+selection (Full.InlineFragmentSelection fragmentSelection) =+    inlineFragment fragmentSelection++field :: Full.Field ->  State (Replacement m) (Maybe (Field m))+field (Full.Field alias name arguments' directives' selections _) = do+    fieldArguments <- foldM go HashMap.empty arguments'+    fieldSelections <- appendSelection selections+    fieldDirectives <- Definition.selection <$> directives directives'+    let field' = Field alias name fieldArguments fieldSelections+    pure $ field' <$ fieldDirectives   where-    go arguments (Full.Argument name' value') =+    go arguments (Full.Argument name' (Full.Node value' _) _) =         inputField arguments name' value' -selection (Full.FragmentSpread name directives') =-    maybe (Left mempty) (Right . SelectionFragment) <$> do-        spreadDirectives <- Definition.selection <$> directives directives'-        fragments' <- gets fragments+fragmentSpread+    :: Full.FragmentSpread+    -> State (Replacement m) (Maybe (Fragment m))+fragmentSpread (Full.FragmentSpread name directives' _) = do+    spreadDirectives <- Definition.selection <$> directives directives'+    fragments' <- gets fragments -        fragmentDefinitions' <- gets fragmentDefinitions-        case HashMap.lookup name fragments' of-            Just definition -> lift $ pure $ definition <$ spreadDirectives-            Nothing-                | Just definition <- HashMap.lookup name fragmentDefinitions' -> do-                    fragDef <- fragmentDefinition definition-                    case fragDef of-                        Just fragment -> lift $ pure $ fragment <$ spreadDirectives-                        _ -> lift $ pure  Nothing-                | otherwise -> lift $ pure  Nothing-selection (Full.InlineFragment type' directives' selections) = do+    fragmentDefinitions' <- gets fragmentDefinitions+    case HashMap.lookup name fragments' of+        Just definition -> lift $ pure $ definition <$ spreadDirectives+        Nothing+            | Just definition <- HashMap.lookup name fragmentDefinitions' -> do+                fragDef <- fragmentDefinition definition+                case fragDef of+                    Just fragment -> lift $ pure $ fragment <$ spreadDirectives+                    _ -> lift $ pure  Nothing+            | otherwise -> lift $ pure  Nothing++inlineFragment+    :: Full.InlineFragment+    ->  State (Replacement m) (Either (Seq (Selection m)) (Selection m))+inlineFragment (Full.InlineFragment type' directives' selections _) = do     fragmentDirectives <- Definition.selection <$> directives directives'     case fragmentDirectives of         Nothing -> pure $ Left mempty@@ -325,7 +310,7 @@                 Nothing -> pure $ Left fragmentSelectionSet                 Just typeName -> do                     types' <- gets types-                    case lookupTypeCondition typeName types' of+                    case Type.lookupTypeCondition typeName types' of                         Just typeCondition -> pure $                             selectionFragment typeCondition fragmentSelectionSet                         Nothing -> pure $ Left mempty@@ -346,10 +331,10 @@ directives :: [Full.Directive] ->  State (Replacement m) [Definition.Directive] directives = traverse directive   where-    directive (Full.Directive directiveName directiveArguments)+    directive (Full.Directive directiveName directiveArguments _)         = Definition.Directive directiveName . Type.Arguments         <$> foldM go HashMap.empty directiveArguments-    go arguments (Full.Argument name value') = do+    go arguments (Full.Argument name (Full.Node value' _) _) = do         substitutedValue <- value value'         return $ HashMap.insert name substitutedValue arguments @@ -372,7 +357,7 @@     fragmentSelection <- appendSelection selections     types' <- gets types -    case lookupTypeCondition type' types' of+    case Type.lookupTypeCondition type' types' of         Just compositeType -> do             let newValue = Fragment compositeType fragmentSelection             modify $ insertFragment newValue@@ -399,7 +384,8 @@ value (Full.Object object) =     Type.Object . HashMap.fromList <$> traverse objectField object   where-    objectField (Full.ObjectField name value') = (name,) <$> value value'+    objectField Full.ObjectField{value = value', ..} =+        (name,) <$> value (Full.node value')  input :: forall m. Full.Value -> State (Replacement m) (Maybe Input) input (Full.Variable name) =@@ -415,8 +401,8 @@     objectFields <- foldM objectField HashMap.empty object     pure $ pure $ Object objectFields   where-    objectField resultMap (Full.ObjectField name value') =-        inputField resultMap name value'+    objectField resultMap Full.ObjectField{value = value', ..} =+        inputField resultMap name $ Full.node value'  inputField :: forall m     . HashMap Full.Name Input

@@ -21,6 +21,6 @@     ) where  import Language.GraphQL.Type.Definition-import Language.GraphQL.Type.Schema (Schema(..))+import Language.GraphQL.Type.Schema (Schema, schema) import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out

@@ -11,6 +11,7 @@ -- with 'Language.GraphQL.Type.Out'. module Language.GraphQL.Type.In     ( Argument(..)+    , Arguments     , InputField(..)     , InputObjectType(..)     , Type(..)@@ -24,10 +25,10 @@ import Data.HashMap.Strict (HashMap) import Data.Text (Text) import Language.GraphQL.AST.Document (Name)-import Language.GraphQL.Type.Definition+import qualified Language.GraphQL.Type.Definition as Definition  -- | Single field of an 'InputObjectType'.-data InputField = InputField (Maybe Text) Type (Maybe Value)+data InputField = InputField (Maybe Text) Type (Maybe Definition.Value)  -- | Input object type definition. --@@ -45,25 +46,28 @@ -- type can wrap other wrapping or named types. Wrapping types are lists and -- Non-Null types (named types are nullable by default). data Type-    = NamedScalarType ScalarType-    | NamedEnumType EnumType+    = NamedScalarType Definition.ScalarType+    | NamedEnumType Definition.EnumType     | NamedInputObjectType InputObjectType     | ListType Type-    | NonNullScalarType ScalarType-    | NonNullEnumType EnumType+    | NonNullScalarType Definition.ScalarType+    | NonNullEnumType Definition.EnumType     | NonNullInputObjectType InputObjectType     | NonNullListType Type     deriving Eq  -- | Field argument definition.-data Argument = Argument (Maybe Text) Type (Maybe Value)+data Argument = Argument (Maybe Text) Type (Maybe Definition.Value) +-- | Field argument definitions.+type Arguments = HashMap Name Argument+ -- | Matches either 'NamedScalarType' or 'NonNullScalarType'.-pattern ScalarBaseType :: ScalarType -> Type+pattern ScalarBaseType :: Definition.ScalarType -> Type pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType)  -- | Matches either 'NamedEnumType' or 'NonNullEnumType'.-pattern EnumBaseType :: EnumType -> Type+pattern EnumBaseType :: Definition.EnumType -> Type pattern EnumBaseType enumType <- (isEnumType -> Just enumType)  -- | Matches either 'NamedInputObjectType' or 'NonNullInputObjectType'.@@ -76,7 +80,7 @@  {-# COMPLETE EnumBaseType, ListBaseType, InputObjectBaseType, ScalarBaseType #-} -isScalarType :: Type -> Maybe ScalarType+isScalarType :: Type -> Maybe Definition.ScalarType isScalarType (NamedScalarType inputType) = Just inputType isScalarType (NonNullScalarType inputType) = Just inputType isScalarType _ = Nothing@@ -86,7 +90,7 @@ isInputObjectType (NonNullInputObjectType inputType) = Just inputType isInputObjectType _ = Nothing -isEnumType :: Type -> Maybe EnumType+isEnumType :: Type -> Maybe Definition.EnumType isEnumType (NamedEnumType inputType) = Just inputType isEnumType (NonNullEnumType inputType) = Just inputType isEnumType _ = Nothing

@@ -3,24 +3,86 @@    obtain one at https://mozilla.org/MPL/2.0/. -}  {-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE LambdaCase #-}  module Language.GraphQL.Type.Internal     ( AbstractType(..)     , CompositeType(..)-    , collectReferencedTypes+    , Directive(..)+    , Directives+    , Schema(..)+    , Type(..)+    , directives     , doesFragmentTypeApply     , instanceOf+    , lookupInputType     , lookupTypeCondition+    , lookupTypeField+    , mutation+    , subscription+    , query+    , types     ) where  import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap-import Language.GraphQL.AST (Name)+import Data.Text (Text)+import qualified Language.GraphQL.AST as Full+import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation) import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out-import Language.GraphQL.Type.Schema +-- | These are all of the possible kinds of types.+data Type m+    = ScalarType Definition.ScalarType+    | EnumType Definition.EnumType+    | ObjectType (Out.ObjectType m)+    | InputObjectType In.InputObjectType+    | InterfaceType (Out.InterfaceType m)+    | UnionType (Out.UnionType m)+    deriving Eq++-- | Directive definition.+data Directive = Directive (Maybe Text) [DirectiveLocation] In.Arguments++-- | Directive definitions.+type Directives = HashMap Full.Name Directive++-- | A Schema is created by supplying the root types of each type of operation,+--   query and mutation (optional). A schema definition is then supplied to the+--   validator and executor.+--+--   __Note:__ When the schema is constructed, by default only the types that+--   are reachable by traversing the root types are included, other types must+--   be explicitly referenced.+data Schema m = Schema+    (Out.ObjectType m)+    (Maybe (Out.ObjectType m))+    (Maybe (Out.ObjectType m))+    Directives+    (HashMap Full.Name (Type m))++-- | Schema query type.+query :: forall m. Schema m -> Out.ObjectType m+query (Schema query' _ _ _ _) = query'++-- | Schema mutation type.+mutation :: forall m. Schema m -> Maybe (Out.ObjectType m)+mutation (Schema _ mutation' _ _ _) = mutation'++-- | Schema subscription type.+subscription :: forall m. Schema m -> Maybe (Out.ObjectType m)+subscription (Schema _ _ subscription' _ _) = subscription'++-- | Schema directive definitions.+directives :: forall m. Schema m -> Directives+directives (Schema _ _ _ directives' _) = directives'++-- | Types referenced by the schema.+types :: forall m. Schema m -> HashMap Full.Name (Type m)+types (Schema _ _ _ _ types') = types'+ -- | These types may describe the parent context of a selection set. data CompositeType m     = CompositeUnionType (Out.UnionType m)@@ -34,65 +96,6 @@     | AbstractInterfaceType (Out.InterfaceType m)     deriving Eq --- | Traverses the schema and finds all referenced types.-collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m)-collectReferencedTypes schema =-    let queryTypes = traverseObjectType (query schema) HashMap.empty-     in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema-  where-    collect traverser typeName element foundTypes-        | HashMap.member typeName foundTypes = foundTypes-        | otherwise = traverser $ HashMap.insert typeName element foundTypes-    visitFields (Out.Field _ outputType arguments) foundTypes-        = traverseOutputType outputType-        $ foldr visitArguments foundTypes arguments-    visitArguments (In.Argument _ inputType _) = traverseInputType inputType-    visitInputFields (In.InputField _ inputType _) = traverseInputType inputType-    getField (Out.ValueResolver field _) = field-    getField (Out.EventStreamResolver field _ _) = field-    traverseInputType (In.InputObjectBaseType objectType) =-        let (In.InputObjectType typeName _ inputFields) = objectType-            element = InputObjectType objectType-            traverser = flip (foldr visitInputFields) inputFields-         in collect traverser typeName element-    traverseInputType (In.ListBaseType listType) =-        traverseInputType listType-    traverseInputType (In.ScalarBaseType scalarType) =-        let (Definition.ScalarType typeName _) = scalarType-         in collect Prelude.id typeName (ScalarType scalarType)-    traverseInputType (In.EnumBaseType enumType) =-        let (Definition.EnumType typeName _ _) = enumType-         in collect Prelude.id typeName (EnumType enumType)-    traverseOutputType (Out.ObjectBaseType objectType) =-        traverseObjectType objectType-    traverseOutputType (Out.InterfaceBaseType interfaceType) =-        traverseInterfaceType interfaceType-    traverseOutputType (Out.UnionBaseType unionType) =-        let (Out.UnionType typeName _ types) = unionType-            traverser = flip (foldr traverseObjectType) types-         in collect traverser typeName (UnionType unionType)-    traverseOutputType (Out.ListBaseType listType) =-        traverseOutputType listType-    traverseOutputType (Out.ScalarBaseType scalarType) =-        let (Definition.ScalarType typeName _) = scalarType-         in collect Prelude.id typeName (ScalarType scalarType)-    traverseOutputType (Out.EnumBaseType enumType) =-        let (Definition.EnumType typeName _ _) = enumType-         in collect Prelude.id typeName (EnumType enumType)-    traverseObjectType objectType foundTypes =-        let (Out.ObjectType typeName _ interfaces fields) = objectType-            element = ObjectType objectType-            traverser = polymorphicTraverser interfaces (getField <$> fields)-         in collect traverser typeName element foundTypes-    traverseInterfaceType interfaceType foundTypes =-        let (Out.InterfaceType typeName _ interfaces fields) = interfaceType-            element = InterfaceType interfaceType-            traverser = polymorphicTraverser interfaces fields-         in collect traverser typeName element foundTypes-    polymorphicTraverser interfaces fields-        = flip (foldr visitFields) fields-        . flip (foldr traverseInterfaceType) interfaces- doesFragmentTypeApply :: forall m     . CompositeType m     -> Out.ObjectType m@@ -118,13 +121,56 @@     go unionMemberType acc = acc || objectType == unionMemberType  lookupTypeCondition :: forall m-    . Name-    -> HashMap Name (Type m)+    . Full.Name+    -> HashMap Full.Name (Type m)     -> Maybe (CompositeType m) lookupTypeCondition type' types' =     case HashMap.lookup type' types' of-        Just (ObjectType objectType) -> Just $ CompositeObjectType objectType+        Just (ObjectType objectType) ->+            Just $ CompositeObjectType objectType         Just (UnionType unionType) -> Just $ CompositeUnionType unionType         Just (InterfaceType interfaceType) ->             Just $ CompositeInterfaceType interfaceType         _ -> Nothing++lookupInputType :: Full.Type -> HashMap Full.Name (Type m) -> Maybe In.Type+lookupInputType (Full.TypeNamed name) types' =+    case HashMap.lookup name types' of+        Just (ScalarType scalarType) ->+            Just $ In.NamedScalarType scalarType+        Just (EnumType enumType) ->+            Just $ In.NamedEnumType enumType+        Just (InputObjectType objectType) ->+            Just $ In.NamedInputObjectType objectType+        _ -> Nothing+lookupInputType (Full.TypeList list) types'+    = In.ListType+    <$> lookupInputType list types'+lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types' =+    case HashMap.lookup nonNull types' of+        Just (ScalarType scalarType) ->+            Just $ In.NonNullScalarType scalarType+        Just (EnumType enumType) ->+            Just $ In.NonNullEnumType enumType+        Just (InputObjectType objectType) ->+            Just $ In.NonNullInputObjectType objectType+        _ -> Nothing+lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types'+    = In.NonNullListType+    <$> lookupInputType nonNull types'++lookupTypeField :: forall a. Full.Name -> Out.Type a -> Maybe (Out.Field a)+lookupTypeField fieldName = \case+    Out.ObjectBaseType objectType ->+        objectChild objectType+    Out.InterfaceBaseType interfaceType ->+        interfaceChild interfaceType+    Out.ListBaseType listType -> lookupTypeField fieldName listType+    _ -> Nothing+  where+    objectChild (Out.ObjectType _ _ _ resolvers) =+        resolverType <$> HashMap.lookup fieldName resolvers+    interfaceChild (Out.InterfaceType _ _ _ fields) =+        HashMap.lookup fieldName fields+    resolverType (Out.ValueResolver objectField _) = objectField+    resolverType (Out.EventStreamResolver objectField _ _) = objectField

@@ -76,7 +76,7 @@ data Field m = Field     (Maybe Text) -- ^ Description.     (Type m) -- ^ Field type.-    (HashMap Name In.Argument) -- ^ Arguments.+    In.Arguments -- ^ Arguments.  -- | These types may be used as output types as the result of fields. --

@@ -2,36 +2,154 @@    v. 2.0. If a copy of the MPL was not distributed with this file, You can    obtain one at https://mozilla.org/MPL/2.0/. -} +{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE OverloadedStrings #-}+ -- | This module provides a representation of a @GraphQL@ Schema in addition to -- functions for defining and manipulating schemas. module Language.GraphQL.Type.Schema-    ( Schema(..)-    , Type(..)+    ( schema+    , module Language.GraphQL.Type.Internal     ) where +import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))+import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation+import qualified Language.GraphQL.AST as Full+import Language.GraphQL.Type.Internal+    ( Directive(..)+    , Directives+    , Schema+    , Type(..)+    , directives+    , mutation+    , subscription+    , query+    , types+    ) import qualified Language.GraphQL.Type.Definition as Definition+import qualified Language.GraphQL.Type.Internal as Internal import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out --- | These are all of the possible kinds of types.-data Type m-    = ScalarType Definition.ScalarType-    | EnumType Definition.EnumType-    | ObjectType (Out.ObjectType m)-    | InputObjectType In.InputObjectType-    | InterfaceType (Out.InterfaceType m)-    | UnionType (Out.UnionType m)-    deriving Eq+-- | Schema constructor.+schema :: forall m+    . Out.ObjectType m -- ^ Query type.+    -> Maybe (Out.ObjectType m) -- ^ Mutation type.+    -> Maybe (Out.ObjectType m) -- ^ Subscription type.+    -> Directives -- ^ Directive definitions.+    -> Schema m -- ^ Schema.+schema queryRoot mutationRoot subscriptionRoot directiveDefinitions =+    Internal.Schema queryRoot mutationRoot subscriptionRoot allDirectives collectedTypes+  where+    collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot+    allDirectives = HashMap.union directiveDefinitions defaultDirectives+    defaultDirectives = HashMap.fromList+        [ ("skip", skipDirective)+        , ("include", includeDirective)+        , ("deprecated", deprecatedDirective)+        ]+    includeDirective =+        Directive includeDescription skipIncludeLocations includeArguments+    includeArguments = HashMap.singleton "if"+        $ In.Argument (Just "Included when true.") ifType Nothing+    includeDescription = Just+        "Directs the executor to include this field or fragment only when the \+        \`if` argument is true."+    skipDirective = Directive skipDescription skipIncludeLocations skipArguments+    skipArguments = HashMap.singleton "if"+        $ In.Argument (Just "skipped when true.") ifType Nothing+    ifType = In.NonNullScalarType Definition.boolean+    skipDescription = Just+        "Directs the executor to skip this field or fragment when the `if` \+        \argument is true."+    skipIncludeLocations =+        [ ExecutableDirectiveLocation DirectiveLocation.Field+        , ExecutableDirectiveLocation DirectiveLocation.FragmentSpread+        , ExecutableDirectiveLocation DirectiveLocation.InlineFragment+        ]+    deprecatedDirective =+        Directive deprecatedDescription deprecatedLocations deprecatedArguments+    reasonDescription = Just+        "Explains why this element was deprecated, usually also including a \+        \suggestion for how to access supported similar data. Formatted using \+        \the Markdown syntax, as specified by \+        \[CommonMark](https://commonmark.org/).'"+    deprecatedArguments = HashMap.singleton "reason"+        $ In.Argument reasonDescription reasonType+        $ Just "No longer supported"+    reasonType = In.NamedScalarType Definition.string+    deprecatedDescription = Just+        "Marks an element of a GraphQL schema as no longer supported."+    deprecatedLocations =+        [ TypeSystemDirectiveLocation DirectiveLocation.FieldDefinition+        , TypeSystemDirectiveLocation DirectiveLocation.ArgumentDefinition+        , TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition+        , TypeSystemDirectiveLocation DirectiveLocation.EnumValue+        ] --- | A Schema is created by supplying the root types of each type of operation,---   query and mutation (optional). A schema definition is then supplied to the---   validator and executor.------   __Note:__ When the schema is constructed, by default only the types that---   are reachable by traversing the root types are included, other types must---   be explicitly referenced.-data Schema m = Schema-    { query :: Out.ObjectType m-    , mutation :: Maybe (Out.ObjectType m)-    , subscription :: Maybe (Out.ObjectType m)-    }+-- | Traverses the schema and finds all referenced types.+collectReferencedTypes :: forall m+    . Out.ObjectType m+    -> Maybe (Out.ObjectType m)+    -> Maybe (Out.ObjectType m)+    -> HashMap Full.Name (Type m)+collectReferencedTypes queryRoot mutationRoot subscriptionRoot =+    let queryTypes = traverseObjectType queryRoot HashMap.empty+        mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes)+            mutationRoot+     in maybe mutationTypes (`traverseObjectType` queryTypes) subscriptionRoot+  where+    collect traverser typeName element foundTypes+        | HashMap.member typeName foundTypes = foundTypes+        | otherwise = traverser $ HashMap.insert typeName element foundTypes+    visitFields (Out.Field _ outputType arguments) foundTypes+        = traverseOutputType outputType+        $ foldr visitArguments foundTypes arguments+    visitArguments (In.Argument _ inputType _) = traverseInputType inputType+    visitInputFields (In.InputField _ inputType _) = traverseInputType inputType+    getField (Out.ValueResolver field _) = field+    getField (Out.EventStreamResolver field _ _) = field+    traverseInputType (In.InputObjectBaseType objectType) =+        let In.InputObjectType typeName _ inputFields = objectType+            element = InputObjectType objectType+            traverser = flip (foldr visitInputFields) inputFields+         in collect traverser typeName element+    traverseInputType (In.ListBaseType listType) =+        traverseInputType listType+    traverseInputType (In.ScalarBaseType scalarType) =+        let Definition.ScalarType typeName _ = scalarType+         in collect Prelude.id typeName (ScalarType scalarType)+    traverseInputType (In.EnumBaseType enumType) =+        let Definition.EnumType typeName _ _ = enumType+         in collect Prelude.id typeName (EnumType enumType)+    traverseOutputType (Out.ObjectBaseType objectType) =+        traverseObjectType objectType+    traverseOutputType (Out.InterfaceBaseType interfaceType) =+        traverseInterfaceType interfaceType+    traverseOutputType (Out.UnionBaseType unionType) =+        let Out.UnionType typeName _ types' = unionType+            traverser = flip (foldr traverseObjectType) types'+         in collect traverser typeName (UnionType unionType)+    traverseOutputType (Out.ListBaseType listType) =+        traverseOutputType listType+    traverseOutputType (Out.ScalarBaseType scalarType) =+        let Definition.ScalarType typeName _ = scalarType+         in collect Prelude.id typeName (ScalarType scalarType)+    traverseOutputType (Out.EnumBaseType enumType) =+        let Definition.EnumType typeName _ _ = enumType+         in collect Prelude.id typeName (EnumType enumType)+    traverseObjectType objectType foundTypes =+        let Out.ObjectType typeName _ interfaces fields = objectType+            element = ObjectType objectType+            traverser = polymorphicTraverser interfaces (getField <$> fields)+         in collect traverser typeName element foundTypes+    traverseInterfaceType interfaceType foundTypes =+        let Out.InterfaceType typeName _ interfaces fields = interfaceType+            element = InterfaceType interfaceType+            traverser = polymorphicTraverser interfaces fields+         in collect traverser typeName element foundTypes+    polymorphicTraverser interfaces fields+        = flip (foldr visitFields) fields+        . flip (foldr traverseInterfaceType) interfaces

@@ -2,80 +2,505 @@    v. 2.0. If a copy of the MPL was not distributed with this file, You can    obtain one at https://mozilla.org/MPL/2.0/. -} -{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | GraphQL validator. module Language.GraphQL.Validate-    ( Error(..)-    , Path(..)+    ( Validation.Error(..)     , document     , module Language.GraphQL.Validate.Rules     ) where -import Control.Monad (foldM)-import Control.Monad.Trans.Reader (Reader, asks, mapReaderT, runReader)-import Data.Foldable (foldrM)+import Control.Monad (join)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Reader (runReaderT)+import Data.Foldable (toList)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap import Data.Sequence (Seq(..), (><), (|>)) import qualified Data.Sequence as Seq-import Language.GraphQL.AST.Document-import Language.GraphQL.Type.Internal-import Language.GraphQL.Type.Schema (Schema(..))+import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))+import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation+import qualified Language.GraphQL.AST.Document as Full+import qualified Language.GraphQL.Type.Internal as Type+import qualified Language.GraphQL.Type.In as In+import qualified Language.GraphQL.Type.Out as Out+import Language.GraphQL.Type.Schema (Schema)+import qualified Language.GraphQL.Type.Schema as Schema import Language.GraphQL.Validate.Rules-import Language.GraphQL.Validate.Validation+import Language.GraphQL.Validate.Validation (Validation(Validation))+import qualified Language.GraphQL.Validate.Validation as Validation -type ValidateT m = Reader (Validation m) (Seq Error)+type ApplySelectionRule m a+    = HashMap Full.Name (Schema.Type m)+    -> Validation.Rule m+    -> Maybe (Out.Type m)+    -> a+    -> Seq (Validation.RuleT m) +type ApplyRule m a = Validation.Rule m -> a -> Seq (Validation.RuleT m)+ -- | Validates a document and returns a list of found errors. If the returned -- list is empty, the document is valid.-document :: forall m. Schema m -> [Rule m] -> Document -> Seq Error+document :: forall m+    . Schema m+    -> [Validation.Rule m]+    -> Full.Document+    -> Seq Validation.Error document schema' rules' document' =-    runReader (foldrM go Seq.empty document') context+    runReaderT reader context   where     context = Validation-        { ast = document'-        , schema = schema'-        , types = collectReferencedTypes schema'-        , rules = rules'+        { Validation.ast = document'+        , Validation.schema = schema'         }-    go definition' accumulator = (accumulator ><) <$> definition definition'+    reader = do+        rule' <- lift $ Seq.fromList rules'+        join $ lift $ foldr (definition rule' context) Seq.empty document' -definition :: forall m. Definition -> ValidateT m-definition = \case-    definition'@(ExecutableDefinition executableDefinition') -> do-        applied <- applyRules definition'-        children <- executableDefinition executableDefinition'-        pure $ children >< applied-    definition' -> applyRules definition'+definition :: Validation.Rule m+    -> Validation m+    -> Full.Definition+    -> Seq (Validation.RuleT m)+    -> Seq (Validation.RuleT m)+definition (Validation.DefinitionRule rule) _ definition' accumulator =+    accumulator |> rule definition'+definition rule context (Full.ExecutableDefinition definition') accumulator =+    accumulator >< executableDefinition rule context definition'+definition rule context (Full.TypeSystemDefinition typeSystemDefinition' _) accumulator =+    accumulator >< typeSystemDefinition context rule typeSystemDefinition'+definition rule context (Full.TypeSystemExtension extension _) accumulator =+    accumulator >< typeSystemExtension context rule extension++typeSystemExtension :: forall m+    . Validation m+    -> ApplyRule m Full.TypeSystemExtension+typeSystemExtension context rule = \case+    Full.SchemaExtension extension -> schemaExtension context rule extension+    Full.TypeExtension extension -> typeExtension context rule extension++typeExtension :: forall m. Validation m -> ApplyRule m Full.TypeExtension+typeExtension context rule = \case+    Full.ScalarTypeExtension _ directives' ->+        directives context rule scalarLocation directives'+    Full.ObjectTypeFieldsDefinitionExtension _ _ directives' fields+        -> directives context rule objectLocation directives'+        >< foldMap (fieldDefinition context rule) fields+    Full.ObjectTypeDirectivesExtension _ _ directives' ->+        directives context rule objectLocation directives'+    Full.ObjectTypeImplementsInterfacesExtension _ _ -> mempty+    Full.InterfaceTypeFieldsDefinitionExtension _ directives' fields+        -> directives context rule interfaceLocation directives'+        >< foldMap (fieldDefinition context rule) fields+    Full.InterfaceTypeDirectivesExtension _ directives' ->+        directives context rule interfaceLocation directives'+    Full.UnionTypeUnionMemberTypesExtension _ directives' _ ->+        directives context rule unionLocation directives'+    Full.UnionTypeDirectivesExtension _ directives' ->+        directives context rule unionLocation directives'+    Full.EnumTypeEnumValuesDefinitionExtension _ directives' values+        -> directives context rule enumLocation directives'+        >< foldMap (enumValueDefinition context rule) values+    Full.EnumTypeDirectivesExtension _ directives' ->+        directives context rule enumLocation directives'+    Full.InputObjectTypeInputFieldsDefinitionExtension _ directives' fields+        -> directives context rule inputObjectLocation directives'+        >< foldMap forEachInputFieldDefinition fields+    Full.InputObjectTypeDirectivesExtension _ directives' ->+        directives context rule inputObjectLocation directives'   where-    applyRules definition' =-        asks rules >>= foldM (ruleFilter definition') Seq.empty-    ruleFilter definition' accumulator (DefinitionRule rule) =-        mapReaderT (runRule accumulator) $ rule definition'-    ruleFilter _ accumulator _ = pure accumulator+    forEachInputFieldDefinition =+        inputValueDefinition context rule inputFieldDefinitionLocation -runRule :: Applicative f => Seq Error -> Maybe Error -> f (Seq Error)-runRule accumulator (Just error') = pure $ accumulator |> error'-runRule accumulator Nothing = pure accumulator+schemaExtension :: forall m. Validation m -> ApplyRule m Full.SchemaExtension+schemaExtension context rule = \case+    Full.SchemaOperationExtension directives' _ ->+        directives context rule schemaLocation directives'+    Full.SchemaDirectivesExtension directives' ->+        directives context rule schemaLocation directives' -executableDefinition :: forall m. ExecutableDefinition -> ValidateT m-executableDefinition (DefinitionOperation definition') =-    operationDefinition definition'-executableDefinition (DefinitionFragment definition') =-    fragmentDefinition definition'+schemaLocation :: DirectiveLocation+schemaLocation = TypeSystemDirectiveLocation DirectiveLocation.Schema -operationDefinition :: forall m. OperationDefinition -> ValidateT m-operationDefinition operation =-    asks rules >>= foldM ruleFilter Seq.empty+interfaceLocation :: DirectiveLocation+interfaceLocation = TypeSystemDirectiveLocation DirectiveLocation.Interface++objectLocation :: DirectiveLocation+objectLocation = TypeSystemDirectiveLocation DirectiveLocation.Object++unionLocation :: DirectiveLocation+unionLocation = TypeSystemDirectiveLocation DirectiveLocation.Union++enumLocation :: DirectiveLocation+enumLocation = TypeSystemDirectiveLocation DirectiveLocation.Enum++inputObjectLocation :: DirectiveLocation+inputObjectLocation = TypeSystemDirectiveLocation DirectiveLocation.InputObject++scalarLocation :: DirectiveLocation+scalarLocation = TypeSystemDirectiveLocation DirectiveLocation.Scalar++enumValueLocation :: DirectiveLocation+enumValueLocation = TypeSystemDirectiveLocation DirectiveLocation.EnumValue++fieldDefinitionLocation :: DirectiveLocation+fieldDefinitionLocation =+    TypeSystemDirectiveLocation DirectiveLocation.FieldDefinition++inputFieldDefinitionLocation :: DirectiveLocation+inputFieldDefinitionLocation =+    TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition++argumentDefinitionLocation :: DirectiveLocation+argumentDefinitionLocation =+    TypeSystemDirectiveLocation DirectiveLocation.ArgumentDefinition++queryLocation :: DirectiveLocation+queryLocation = ExecutableDirectiveLocation DirectiveLocation.Query++mutationLocation :: DirectiveLocation+mutationLocation = ExecutableDirectiveLocation DirectiveLocation.Mutation++subscriptionLocation :: DirectiveLocation+subscriptionLocation =+    ExecutableDirectiveLocation DirectiveLocation.Subscription++fieldLocation :: DirectiveLocation+fieldLocation = ExecutableDirectiveLocation DirectiveLocation.Field++fragmentDefinitionLocation :: DirectiveLocation+fragmentDefinitionLocation =+    ExecutableDirectiveLocation DirectiveLocation.FragmentDefinition++fragmentSpreadLocation :: DirectiveLocation+fragmentSpreadLocation =+    ExecutableDirectiveLocation DirectiveLocation.FragmentSpread++inlineFragmentLocation :: DirectiveLocation+inlineFragmentLocation =+    ExecutableDirectiveLocation DirectiveLocation.InlineFragment++executableDefinition :: forall m+    . Validation.Rule m+    -> Validation m+    -> Full.ExecutableDefinition+    -> Seq (Validation.RuleT m)+executableDefinition rule context (Full.DefinitionOperation operation) =+    operationDefinition rule context operation+executableDefinition rule context (Full.DefinitionFragment fragment) =+    fragmentDefinition rule context fragment++typeSystemDefinition :: forall m+    . Validation m+    -> ApplyRule m Full.TypeSystemDefinition+typeSystemDefinition context rule = \case+    Full.SchemaDefinition directives' _ ->+        directives context rule schemaLocation directives'+    Full.TypeDefinition typeDefinition' ->+        typeDefinition context rule typeDefinition'+    Full.DirectiveDefinition _ _ arguments' _ ->+        argumentsDefinition context rule arguments'++typeDefinition :: forall m. Validation m -> ApplyRule m Full.TypeDefinition+typeDefinition context rule = \case+    Full.ScalarTypeDefinition _ _ directives' ->+        directives context rule scalarLocation directives'+    Full.ObjectTypeDefinition _ _ _ directives' fields+        -> directives context rule objectLocation directives'+         >< foldMap (fieldDefinition context rule) fields+    Full.InterfaceTypeDefinition _ _ directives' fields+        -> directives context rule interfaceLocation directives'+        >< foldMap (fieldDefinition context rule) fields+    Full.UnionTypeDefinition _ _ directives' _ ->+        directives context rule unionLocation directives'+    Full.EnumTypeDefinition _ _ directives' values+        -> directives context rule enumLocation directives'+        >< foldMap (enumValueDefinition context rule) values+    Full.InputObjectTypeDefinition _ _ directives' fields+        -> directives context rule inputObjectLocation directives'+        <> foldMap forEachInputFieldDefinition fields   where-    ruleFilter accumulator (OperationDefinitionRule rule) =-        mapReaderT (runRule accumulator) $ rule operation-    ruleFilter accumulator _ = pure accumulator+    forEachInputFieldDefinition =+        inputValueDefinition context rule inputFieldDefinitionLocation -fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m-fragmentDefinition fragment =-    asks rules >>= foldM ruleFilter Seq.empty+enumValueDefinition :: forall m+    . Validation m+    -> ApplyRule m Full.EnumValueDefinition+enumValueDefinition context rule (Full.EnumValueDefinition _ _ directives') =+    directives context rule enumValueLocation directives'++fieldDefinition :: forall m. Validation m -> ApplyRule m Full.FieldDefinition+fieldDefinition context rule (Full.FieldDefinition _ _ arguments' _ directives')+    = directives context rule fieldDefinitionLocation directives'+    >< argumentsDefinition context rule arguments'++argumentsDefinition :: forall m+    . Validation m+    -> ApplyRule m Full.ArgumentsDefinition+argumentsDefinition context rule (Full.ArgumentsDefinition definitions) =+    foldMap forEachArgument definitions   where-    ruleFilter accumulator (FragmentDefinitionRule rule) =-        mapReaderT (runRule accumulator) $ rule fragment-    ruleFilter accumulator _ = pure accumulator+    forEachArgument =+        inputValueDefinition context rule argumentDefinitionLocation++inputValueDefinition :: forall m+    . Validation m+    -> Validation.Rule m+    -> DirectiveLocation+    -> Full.InputValueDefinition+    -> Seq (Validation.RuleT m)+inputValueDefinition context rule directiveLocation definition' =+    let Full.InputValueDefinition _ _ _ _ directives' = definition'+     in directives context rule directiveLocation directives'++operationDefinition :: forall m+    . Validation.Rule m+    -> Validation m+    -> Full.OperationDefinition+    -> Seq (Validation.RuleT m)+operationDefinition rule context operation+    | Validation.OperationDefinitionRule operationRule <- rule =+        pure $ operationRule operation+    | Validation.VariablesRule variablesRule <- rule+    , Full.OperationDefinition _ _ variables _ _ _ <- operation =+        foldMap (variableDefinition context rule) variables |> variablesRule variables+    | Full.SelectionSet selections _ <- operation =+        selectionSet context types' rule queryRoot selections+    | Full.OperationDefinition Full.Query _ _ directives' selections _  <- operation+        = selectionSet context types' rule queryRoot selections+        >< directives context rule queryLocation directives'+    | Full.OperationDefinition Full.Mutation _ _ directives' selections _  <- operation =+        let root = Out.NamedObjectType <$> Schema.mutation schema'+         in selectionSet context types' rule root selections+        >< directives context rule mutationLocation directives'+    | Full.OperationDefinition Full.Subscription _ _ directives' selections _  <- operation =+        let root = Out.NamedObjectType <$> Schema.subscription schema'+         in selectionSet context types' rule root selections+        >< directives context rule subscriptionLocation directives'+  where+    schema' = Validation.schema context+    queryRoot = Just $ Out.NamedObjectType $ Schema.query schema'+    types' = Schema.types schema'+        +typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m)+typeToOut (Schema.ObjectType objectType) =+    Just $ Out.NamedObjectType objectType+typeToOut (Schema.InterfaceType interfaceType) =+    Just $ Out.NamedInterfaceType interfaceType+typeToOut (Schema.UnionType unionType) = Just $ Out.NamedUnionType unionType+typeToOut (Schema.EnumType enumType) = Just $ Out.NamedEnumType enumType+typeToOut (Schema.ScalarType scalarType) = Just $ Out.NamedScalarType scalarType+typeToOut _ = Nothing++variableDefinition :: forall m+    . Validation m+    -> ApplyRule m Full.VariableDefinition+variableDefinition context rule (Full.VariableDefinition _ typeName value' _)+    | Just defaultValue' <- value'+    , types <- Schema.types $ Validation.schema context+    , variableType <- Type.lookupInputType typeName types =+        constValue rule variableType defaultValue'+variableDefinition _ _ _ = mempty++constValue :: forall m+    . Validation.Rule m+    -> Maybe In.Type+    -> Full.Node Full.ConstValue+    -> Seq (Validation.RuleT m)+constValue (Validation.ValueRule _ rule) valueType = go valueType+  where+    go inputObjectType value'@(Full.Node (Full.ConstObject fields) _)+        = foldMap (forEach inputObjectType) (Seq.fromList fields)+        |> rule inputObjectType value'+    go listType value'@(Full.Node (Full.ConstList values) location')+        = embedListLocation go listType values location'+        |> rule listType value'+    go anotherValue value' = pure $ rule anotherValue value'+    forEach inputObjectType Full.ObjectField{value = value', ..} =+        go (valueTypeByName name inputObjectType) value'+constValue _ _ = const mempty++inputFieldType :: In.InputField -> In.Type+inputFieldType (In.InputField _ inputFieldType' _) = inputFieldType'++valueTypeByName :: Full.Name -> Maybe In.Type -> Maybe In.Type+valueTypeByName fieldName (Just( In.InputObjectBaseType inputObjectType)) =+    let In.InputObjectType _ _ fieldTypes = inputObjectType+     in inputFieldType <$> HashMap.lookup fieldName fieldTypes+valueTypeByName _ _ = Nothing++fragmentDefinition :: forall m+    . Validation.Rule m+    -> Validation m+    -> Full.FragmentDefinition+    -> Seq (Validation.RuleT m)+fragmentDefinition (Validation.FragmentDefinitionRule rule) _ definition' =+    pure $ rule definition'+fragmentDefinition rule context definition'+    | Full.FragmentDefinition _ typeCondition directives' selections _ <- definition'+    , Validation.FragmentRule definitionRule _ <- rule+        = applyToChildren typeCondition directives' selections+        |> definitionRule definition'+    | Full.FragmentDefinition _ typeCondition directives' selections _ <- definition'+        = applyToChildren typeCondition directives' selections+  where+    types' = Schema.types $ Validation.schema context+    applyToChildren typeCondition directives' selections+        = selectionSet context types' rule (lookupType' typeCondition) selections+        >< directives context rule fragmentDefinitionLocation directives'+    lookupType' = flip lookupType types'++lookupType :: forall m+    . Full.TypeCondition+    -> HashMap Full.Name (Schema.Type m)+    -> Maybe (Out.Type m)+lookupType typeCondition types' = HashMap.lookup typeCondition types'+    >>= typeToOut++selectionSet :: Traversable t+    => forall m+    . Validation m+    -> ApplySelectionRule m (t Full.Selection)+selectionSet context types' rule = foldMap . selection context types' rule++selection :: forall m. Validation m -> ApplySelectionRule m Full.Selection+selection context types' rule objectType selection'+    | Validation.SelectionRule selectionRule <- rule =+        applyToChildren |> selectionRule objectType selection'+    | otherwise = applyToChildren+  where+    applyToChildren =+        case selection' of+            Full.FieldSelection field' ->+                field context types' rule objectType field'+            Full.InlineFragmentSelection inlineFragment' ->+                inlineFragment context types' rule objectType inlineFragment'+            Full.FragmentSpreadSelection fragmentSpread' ->+                fragmentSpread context rule fragmentSpread'++field :: forall m. Validation m -> ApplySelectionRule m Full.Field+field context types' rule objectType field' = go field'+  where+    go (Full.Field _ fieldName _ _ _ _)+        | Validation.FieldRule fieldRule <- rule =+            applyToChildren fieldName |> fieldRule objectType field'+        | Validation.ArgumentsRule argumentsRule _  <- rule =+            applyToChildren fieldName |> argumentsRule objectType field'+        | otherwise = applyToChildren fieldName+    typeFieldType (Out.Field _ type' _) = type'+    typeFieldArguments (Out.Field _ _ argumentTypes) = argumentTypes+    applyToChildren fieldName =+        let Full.Field _ _ arguments' directives' selections _ = field'+            typeField = objectType >>= Type.lookupTypeField fieldName+            argumentTypes = maybe mempty typeFieldArguments typeField+         in selectionSet context types' rule (typeFieldType <$> typeField) selections+            >< directives context rule fieldLocation directives'+            >< arguments rule argumentTypes arguments'++arguments :: forall m+    . Validation.Rule m+    -> In.Arguments+    -> [Full.Argument]+    -> Seq (Validation.RuleT m)+arguments rule argumentTypes = foldMap forEach . Seq.fromList+  where+    forEach argument'@(Full.Argument argumentName _ _) = +       let argumentType = HashMap.lookup argumentName argumentTypes+        in argument rule argumentType argument'++argument :: forall m+    . Validation.Rule m+    -> Maybe In.Argument+    -> Full.Argument+    -> Seq (Validation.RuleT m)+argument rule argumentType (Full.Argument _ value' _) =+    value rule (valueType <$> argumentType) value'+  where+    valueType (In.Argument _ valueType' _) = valueType'++-- valueTypeFromList :: Maybe In.Type -> Maybe In.Type+embedListLocation :: forall a m+    . (Maybe In.Type -> Full.Node a -> Seq m)+    -> Maybe In.Type+    -> [a]+    -> Full.Location+    -> Seq m+embedListLocation go listType values location'+    = foldMap (go $ valueTypeFromList listType) +    $ flip Full.Node location' <$> Seq.fromList values+  where+    valueTypeFromList (Just (In.ListBaseType baseType)) = Just baseType+    valueTypeFromList _ = Nothing++value :: forall m+    . Validation.Rule m+    -> Maybe In.Type+    -> Full.Node Full.Value+    -> Seq (Validation.RuleT m)+value (Validation.ValueRule rule _) valueType = go valueType+  where+    go inputObjectType value'@(Full.Node (Full.Object fields) _)+        = foldMap (forEach inputObjectType) (Seq.fromList fields)+        |> rule inputObjectType value'+    go listType value'@(Full.Node (Full.List values) location')+        = embedListLocation go listType values location'+        |> rule listType value'+    go anotherValue value' = pure $ rule anotherValue value'+    forEach inputObjectType Full.ObjectField{value = value', ..} =+        go (valueTypeByName name inputObjectType) value'+value _ _ = const mempty++inlineFragment :: forall m+    . Validation m+    -> ApplySelectionRule m Full.InlineFragment+inlineFragment context types' rule objectType inlineFragment' =+    go inlineFragment'+  where+    go (Full.InlineFragment optionalType directives' selections _)+        | Validation.FragmentRule _ fragmentRule <- rule+            = applyToChildren (refineTarget optionalType) directives' selections+            |> fragmentRule inlineFragment'+        | otherwise = applyToChildren (refineTarget optionalType) directives' selections+    refineTarget (Just typeCondition) = lookupType typeCondition types'+    refineTarget Nothing = objectType+    applyToChildren objectType' directives' selections+        = selectionSet context types' rule objectType' selections+        >< directives context rule inlineFragmentLocation directives'++fragmentSpread :: forall m. Validation m -> ApplyRule m Full.FragmentSpread+fragmentSpread context rule fragmentSpread'@(Full.FragmentSpread _ directives' _)+    | Validation.FragmentSpreadRule fragmentRule <- rule =+        applyToChildren |> fragmentRule fragmentSpread'+    | otherwise = applyToChildren+  where+    applyToChildren = directives context rule fragmentSpreadLocation directives'++directives :: Traversable t+    => forall m+    . Validation m+    -> Validation.Rule m+    -> DirectiveLocation+    -> t Full.Directive+    -> Seq (Validation.RuleT m)+directives context rule directiveLocation directives'+    | Validation.DirectivesRule directivesRule <- rule =+        applyToChildren |> directivesRule directiveLocation directiveList+    | otherwise = applyToChildren+  where+    directiveList = toList directives'+    applyToChildren = foldMap (directive context rule) directiveList++directive :: forall m. Validation m -> ApplyRule m Full.Directive+directive _ (Validation.ArgumentsRule _ argumentsRule) directive' =+    pure $ argumentsRule directive'+directive context rule (Full.Directive directiveName arguments' _) =+    let argumentTypes = maybe HashMap.empty directiveArguments+            $ HashMap.lookup directiveName+            $ Schema.directives+            $ Validation.schema context+     in arguments rule argumentTypes arguments'+  where+    directiveArguments (Schema.Directive _ _ argumentTypes) = argumentTypes

@@ -2,160 +2,229 @@    v. 2.0. If a copy of the MPL was not distributed with this file, You can    obtain one at https://mozilla.org/MPL/2.0/. -} -{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-}  -- | This module contains default rules defined in the GraphQL specification. module Language.GraphQL.Validate.Rules-    ( executableDefinitionsRule+    ( directivesInValidLocationsRule+    , executableDefinitionsRule+    , fieldsOnCorrectTypeRule+    , fragmentsOnCompositeTypesRule+    , fragmentSpreadTargetDefinedRule+    , fragmentSpreadTypeExistenceRule     , loneAnonymousOperationRule+    , knownArgumentNamesRule+    , knownDirectiveNamesRule+    , knownInputFieldNamesRule+    , noFragmentCyclesRule+    , noUndefinedVariablesRule+    , noUnusedFragmentsRule+    , noUnusedVariablesRule+    , providedRequiredInputFieldsRule+    , providedRequiredArgumentsRule+    , scalarLeafsRule     , singleFieldSubscriptionsRule     , specifiedRules+    , uniqueArgumentNamesRule+    , uniqueDirectiveNamesRule     , uniqueFragmentNamesRule+    , uniqueInputFieldNamesRule     , uniqueOperationNamesRule+    , uniqueVariableNamesRule+    , variablesAreInputTypesRule     ) where -import Control.Monad (foldM)+import Control.Monad ((>=>), foldM) import Control.Monad.Trans.Class (MonadTrans(..))-import Control.Monad.Trans.Reader (asks)-import Control.Monad.Trans.State (evalStateT, gets, modify)+import Control.Monad.Trans.Reader (ReaderT(..), asks, mapReaderT)+import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)+import Data.Bifunctor (first)+import Data.Foldable (find, toList)+import qualified Data.HashMap.Strict as HashMap+import Data.HashMap.Strict (HashMap)+import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet+import Data.List (groupBy, sortBy, sortOn)+import Data.Maybe (isNothing, mapMaybe)+import Data.List.NonEmpty (NonEmpty)+import Data.Ord (comparing)+import Data.Sequence (Seq(..), (|>))+import qualified Data.Sequence as Seq+import Data.Text (Text) import qualified Data.Text as Text-import Language.GraphQL.AST.Document-import Language.GraphQL.Type.Internal+import qualified Language.GraphQL.AST.Document as Full+import qualified Language.GraphQL.Type.Definition as Definition+import qualified Language.GraphQL.Type.Internal as Type+import qualified Language.GraphQL.Type.In as In+import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Schema as Schema import Language.GraphQL.Validate.Validation +-- Local help type that contains a hash set to track visited fragments.+type ValidationState m a =+    StateT (HashSet Full.Name) (ReaderT (Validation m) Seq) a+ -- | Default rules given in the specification. specifiedRules :: forall m. [Rule m] specifiedRules =+    -- Documents.     [ executableDefinitionsRule+    -- Operations.     , singleFieldSubscriptionsRule     , loneAnonymousOperationRule     , uniqueOperationNamesRule+    -- Fields+    , fieldsOnCorrectTypeRule+    , scalarLeafsRule+    -- Arguments.+    , knownArgumentNamesRule+    , uniqueArgumentNamesRule+    , providedRequiredArgumentsRule+    -- Fragments.     , uniqueFragmentNamesRule+    , fragmentSpreadTypeExistenceRule+    , fragmentsOnCompositeTypesRule+    , noUnusedFragmentsRule+    , fragmentSpreadTargetDefinedRule+    , noFragmentCyclesRule+    -- Values+    , knownInputFieldNamesRule+    , uniqueInputFieldNamesRule+    , providedRequiredInputFieldsRule+    -- Directives.+    , knownDirectiveNamesRule+    , directivesInValidLocationsRule+    , uniqueDirectiveNamesRule+    -- Variables.+    , uniqueVariableNamesRule+    , variablesAreInputTypesRule+    , noUndefinedVariablesRule+    , noUnusedVariablesRule     ]  -- | Definition must be OperationDefinition or FragmentDefinition. executableDefinitionsRule :: forall m. Rule m executableDefinitionsRule = DefinitionRule $ \case-    ExecutableDefinition _ -> lift Nothing-    TypeSystemDefinition _ location -> pure $ error' location-    TypeSystemExtension _ location -> pure $ error' location+    Full.ExecutableDefinition _ -> lift mempty+    Full.TypeSystemDefinition _ location' -> pure $ error' location'+    Full.TypeSystemExtension _ location' -> pure $ error' location'   where-    error' location = Error+    error' location' = Error         { message =             "Definition must be OperationDefinition or FragmentDefinition."-        , locations = [location]-        , path = []+        , locations = [location']         }  -- | Subscription operations must have exactly one root field. singleFieldSubscriptionsRule :: forall m. Rule m singleFieldSubscriptionsRule = OperationDefinitionRule $ \case-    OperationDefinition Subscription name' _ _ rootFields location -> do+    Full.OperationDefinition Full.Subscription name' _ _ rootFields location' -> do         groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty         case HashSet.size groupedFieldSet of-            1 -> lift Nothing+            1 -> lift mempty             _                 | Just name <- name' -> pure $ Error-                    { message = unwords-                        [ "Subscription"+                    { message = concat+                        [ "Subscription \""                         , Text.unpack name-                        , "must select only one top level field."+                        , "\" must select only one top level field."                         ]-                    , locations = [location]-                    , path = []+                    , locations = [location']                     }                 | otherwise -> pure $ Error                     { message = errorMessage-                    , locations = [location]-                    , path = []+                    , locations = [location']                     }-    _ -> lift Nothing+    _ -> lift mempty   where     errorMessage =         "Anonymous Subscription must select only one top level field."     collectFields selectionSet = foldM forEach HashSet.empty selectionSet-    forEach accumulator (Field alias name _ directives _)-        | any skip directives = pure accumulator+    forEach accumulator = \case+        Full.FieldSelection fieldSelection -> forField accumulator fieldSelection+        Full.FragmentSpreadSelection fragmentSelection ->+            forSpread accumulator fragmentSelection+        Full.InlineFragmentSelection fragmentSelection ->+            forInline accumulator fragmentSelection+    forField accumulator (Full.Field alias name _ directives' _ _)+        | any skip directives' = pure accumulator         | Just aliasedName <- alias = pure             $ HashSet.insert aliasedName accumulator         | otherwise = pure $ HashSet.insert name accumulator-    forEach accumulator (FragmentSpread fragmentName directives)-        | any skip directives = pure accumulator+    forSpread accumulator (Full.FragmentSpread fragmentName directives' _)+        | any skip directives' = pure accumulator         | otherwise = do             inVisitetFragments <- gets $ HashSet.member fragmentName             if inVisitetFragments                then pure accumulator                else collectFromSpread fragmentName accumulator-    forEach accumulator (InlineFragment typeCondition' directives selectionSet)-        | any skip directives = pure accumulator-        | Just typeCondition <- typeCondition' =-            collectFromFragment typeCondition selectionSet accumulator+    forInline accumulator (Full.InlineFragment maybeType directives' selections _)+        | any skip directives' = pure accumulator+        | Just typeCondition <- maybeType =+            collectFromFragment typeCondition selections accumulator         | otherwise = HashSet.union accumulator-            <$> collectFields selectionSet-    skip (Directive "skip" [Argument "if" (Boolean True)]) = True-    skip (Directive "include" [Argument "if" (Boolean False)]) = True+            <$> collectFields selections+    skip (Full.Directive "skip" [Full.Argument "if" (Full.Node argumentValue _) _] _) =+        Full.Boolean True == argumentValue+    skip (Full.Directive "include" [Full.Argument "if" (Full.Node argumentValue _) _] _) =+        Full.Boolean False == argumentValue     skip _ = False-    findFragmentDefinition (ExecutableDefinition executableDefinition) Nothing-        | DefinitionFragment fragmentDefinition <- executableDefinition =-            Just fragmentDefinition-    findFragmentDefinition _ accumulator = accumulator     collectFromFragment typeCondition selectionSet accumulator = do-        types' <- lift $ asks types+        types' <- lift $ asks $ Schema.types . schema         schema' <- lift $ asks schema-        case lookupTypeCondition typeCondition types' of+        case Type.lookupTypeCondition typeCondition types' of             Nothing -> pure accumulator             Just compositeType                 | Just objectType <- Schema.subscription schema'-                , True <- doesFragmentTypeApply compositeType objectType ->-                    HashSet.union accumulator<$> collectFields selectionSet+                , True <- Type.doesFragmentTypeApply compositeType objectType ->+                    HashSet.union accumulator <$> collectFields selectionSet                 | otherwise -> pure accumulator     collectFromSpread fragmentName accumulator = do         modify $ HashSet.insert fragmentName         ast' <- lift $ asks ast-        case foldr findFragmentDefinition Nothing ast' of+        case findFragmentDefinition fragmentName ast' of             Nothing -> pure accumulator-            Just (FragmentDefinition _ typeCondition _ selectionSet _) ->+            Just (Full.FragmentDefinition _ typeCondition _ selectionSet _) ->                 collectFromFragment typeCondition selectionSet accumulator  -- | GraphQL allows a short‐hand form for defining query operations when only -- that one operation exists in the document. loneAnonymousOperationRule :: forall m. Rule m loneAnonymousOperationRule = OperationDefinitionRule $ \case-      SelectionSet _ thisLocation -> check thisLocation-      OperationDefinition _ Nothing _ _ _ thisLocation -> check thisLocation-      _ -> lift Nothing+      Full.SelectionSet _ thisLocation -> check thisLocation+      Full.OperationDefinition _ Nothing _ _ _ thisLocation ->+          check thisLocation+      _ -> lift mempty     where       check thisLocation = asks ast-          >>= lift . foldr (filterAnonymousOperations thisLocation) Nothing-      filterAnonymousOperations thisLocation definition Nothing+          >>= lift . foldr (filterAnonymousOperations thisLocation) mempty+      filterAnonymousOperations thisLocation definition Empty           | (viewOperation -> Just operationDefinition) <- definition =               compareAnonymousOperations thisLocation operationDefinition       filterAnonymousOperations _ _ accumulator = accumulator       compareAnonymousOperations thisLocation = \case-          OperationDefinition _ _ _ _ _ thatLocation+          Full.OperationDefinition _ _ _ _ _ thatLocation               | thisLocation /= thatLocation -> pure $ error' thisLocation-          SelectionSet _ thatLocation+          Full.SelectionSet _ thatLocation               | thisLocation /= thatLocation -> pure $ error' thisLocation-          _ -> Nothing-      error' location = Error+          _ -> mempty+      error' location' = Error           { message =               "This anonymous operation must be the only defined operation."-          , locations = [location]-          , path = []+          , locations = [location']           }  -- | Each named operation definition must be unique within a document when -- referred to by its name. uniqueOperationNamesRule :: forall m. Rule m uniqueOperationNamesRule = OperationDefinitionRule $ \case-    OperationDefinition _ (Just thisName) _ _ _ thisLocation ->+    Full.OperationDefinition _ (Just thisName) _ _ _ thisLocation ->         findDuplicates (filterByName thisName) thisLocation (error' thisName)-    _ -> lift Nothing+    _ -> lift mempty   where     error' operationName = concat         [ "There can be only one operation named \""@@ -164,12 +233,12 @@         ]     filterByName thisName definition' accumulator         | (viewOperation -> Just operationDefinition) <- definition'-        , OperationDefinition _ (Just thatName) _ _ _ thatLocation <- operationDefinition+        , Full.OperationDefinition _ (Just thatName) _ _ _ thatLocation <- operationDefinition         , thisName == thatName = thatLocation : accumulator         | otherwise = accumulator -findDuplicates :: (Definition -> [Location] -> [Location])-    -> Location+findDuplicates :: (Full.Definition -> [Full.Location] -> [Full.Location])+    -> Full.Location     -> String     -> RuleT m findDuplicates filterByName thisLocation errorMessage = do@@ -177,21 +246,27 @@     let locations' = foldr filterByName [] ast'     if length locations' > 1 && head locations' == thisLocation         then pure $ error' locations'-        else lift Nothing+        else lift mempty   where     error' locations' = Error          { message = errorMessage         , locations = locations'-        , path = []         } -viewOperation :: Definition -> Maybe OperationDefinition+viewOperation :: Full.Definition -> Maybe Full.OperationDefinition viewOperation definition-    | ExecutableDefinition executableDefinition <- definition-    , DefinitionOperation operationDefinition <- executableDefinition =+    | Full.ExecutableDefinition executableDefinition <- definition+    , Full.DefinitionOperation operationDefinition <- executableDefinition =         Just operationDefinition viewOperation _ = Nothing +viewFragment :: Full.Definition -> Maybe Full.FragmentDefinition+viewFragment definition+    | Full.ExecutableDefinition executableDefinition <- definition+    , Full.DefinitionFragment fragmentDefinition <- executableDefinition =+        Just fragmentDefinition+viewFragment _ = Nothing+ -- | Fragment definitions are referenced in fragment spreads by name. To avoid -- ambiguity, each fragment’s name must be unique within a document. --@@ -199,7 +274,7 @@ -- by this validation rule. uniqueFragmentNamesRule :: forall m. Rule m uniqueFragmentNamesRule = FragmentDefinitionRule $ \case-    FragmentDefinition thisName _ _ _ thisLocation ->+    Full.FragmentDefinition thisName _ _ _ thisLocation ->         findDuplicates (filterByName thisName) thisLocation (error' thisName)   where     error' fragmentName = concat@@ -208,8 +283,733 @@         , "\"."         ]     filterByName thisName definition accumulator-        | ExecutableDefinition executableDefinition <- definition-        , DefinitionFragment fragmentDefinition <- executableDefinition-        , FragmentDefinition thatName _ _ _ thatLocation <- fragmentDefinition+        | Just fragmentDefinition <- viewFragment definition+        , Full.FragmentDefinition thatName _ _ _ thatLocation <- fragmentDefinition         , thisName == thatName = thatLocation : accumulator         | otherwise = accumulator++-- | Named fragment spreads must refer to fragments defined within the document.+-- It is a validation error if the target of a spread is not defined.+fragmentSpreadTargetDefinedRule :: forall m. Rule m+fragmentSpreadTargetDefinedRule = FragmentSpreadRule $ \case+    Full.FragmentSpread fragmentName _ location' -> do+        ast' <- asks ast+        case find (isSpreadTarget fragmentName) ast' of+            Nothing -> pure $ Error+                { message = error' fragmentName+                , locations = [location']+                }+            Just _ -> lift mempty+  where+    error' fragmentName = concat+        [ "Fragment target \""+        , Text.unpack fragmentName+        , "\" is undefined."+        ]++isSpreadTarget :: Text -> Full.Definition -> Bool+isSpreadTarget thisName (viewFragment -> Just fragmentDefinition)+    | Full.FragmentDefinition thatName _ _ _ _ <- fragmentDefinition+    , thisName == thatName = True+isSpreadTarget _ _ = False++-- | Fragments must be specified on types that exist in the schema. This applies+-- for both named and inline fragments. If they are not defined in the schema,+-- the query does not validate.+fragmentSpreadTypeExistenceRule :: forall m. Rule m+fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case+    Full.FragmentSpreadSelection fragmentSelection+        | Full.FragmentSpread fragmentName _ location' <- fragmentSelection -> do+            ast' <- asks ast+            let target = find (isSpreadTarget fragmentName) ast'+            typeCondition <- lift $ maybeToSeq $ target >>= extractTypeCondition+            types' <- asks $ Schema.types . schema+            case HashMap.lookup typeCondition types' of+                Nothing -> pure $ Error+                    { message = spreadError fragmentName typeCondition+                    , locations = [location']+                    }+                Just _ -> lift mempty+    Full.InlineFragmentSelection fragmentSelection+        | Full.InlineFragment maybeType _ _ location' <- fragmentSelection+        , Just typeCondition <- maybeType -> do+            types' <- asks $ Schema.types . schema+            case HashMap.lookup typeCondition types' of+                Nothing -> pure $ Error+                    { message = inlineError typeCondition+                    , locations = [location']+                    }+                Just _ -> lift mempty+    _ -> lift mempty+  where+    extractTypeCondition (viewFragment -> Just fragmentDefinition) =+        let Full.FragmentDefinition _ typeCondition _ _ _ = fragmentDefinition+         in Just typeCondition+    extractTypeCondition _ = Nothing+    spreadError fragmentName typeCondition = concat+        [ "Fragment \""+        , Text.unpack fragmentName+        , "\" is specified on type \""+        , Text.unpack typeCondition+        , "\" which doesn't exist in the schema."+        ]+    inlineError typeCondition = concat+        [ "Inline fragment is specified on type \""+        , Text.unpack typeCondition+        , "\" which doesn't exist in the schema."+        ]++maybeToSeq :: forall a. Maybe a -> Seq a+maybeToSeq (Just x) = pure x+maybeToSeq Nothing = mempty++-- | Fragments can only be declared on unions, interfaces, and objects. They are+-- invalid on scalars. They can only be applied on non‐leaf fields. This rule+-- applies to both inline and named fragments.+fragmentsOnCompositeTypesRule :: forall m. Rule m+fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule+  where+    inlineRule (Full.InlineFragment (Just typeCondition) _ _ location') =+        check typeCondition location'+    inlineRule _ = lift mempty+    definitionRule (Full.FragmentDefinition _ typeCondition _ _ location') =+        check typeCondition location'+    check typeCondition location' = do+        types' <- asks $ Schema.types . schema+        -- Skip unknown types, they are checked by another rule.+        _ <- lift $ maybeToSeq $ HashMap.lookup typeCondition types'+        case Type.lookupTypeCondition typeCondition types' of+            Nothing -> pure $ Error+                { message = errorMessage typeCondition+                , locations = [location']+                }+            Just _ -> lift mempty+    errorMessage typeCondition = concat+        [ "Fragment cannot condition on non composite type \""+        , Text.unpack typeCondition,+        "\"."+        ]++-- | Defined fragments must be used within a document.+noUnusedFragmentsRule :: forall m. Rule m+noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment -> do+    let Full.FragmentDefinition fragmentName _ _ _ location' = fragment+     in mapReaderT (checkFragmentName fragmentName location')+        $ asks ast+        >>= flip evalStateT HashSet.empty+        . filterSelections evaluateSelection+        . foldMap definitionSelections+  where+    checkFragmentName fragmentName location' elements+        | fragmentName `elem` elements = mempty+        | otherwise = pure $ makeError fragmentName location'+    makeError fragName location' = Error+        { message = errorMessage fragName+        , locations = [location']+        }+    errorMessage fragName = concat+        [ "Fragment \""+        , Text.unpack fragName+        , "\" is never used."+        ]+    evaluateSelection selection+        | Full.FragmentSpreadSelection spreadSelection <- selection+        , Full.FragmentSpread spreadName _ _ <- spreadSelection =+            lift $ pure spreadName+    evaluateSelection _ = lift $ lift mempty++definitionSelections :: Full.Definition -> Full.SelectionSetOpt+definitionSelections (viewOperation -> Just operation)+    | Full.OperationDefinition _ _ _ _ selections _ <- operation =+        toList selections+    | Full.SelectionSet selections _ <- operation = toList selections+definitionSelections (viewFragment -> Just fragment)+    | Full.FragmentDefinition _ _ _ selections _ <- fragment = toList selections+definitionSelections _ = []++filterSelections :: Foldable t+    => forall a m+    . (Full.Selection -> ValidationState m a)+    -> t Full.Selection+    -> ValidationState m a+filterSelections applyFilter selections+    = (lift . lift) (Seq.fromList $ foldr evaluateSelection mempty selections)+    >>= applyFilter+  where+    evaluateSelection selection accumulator+        | Full.FragmentSpreadSelection{} <- selection = selection : accumulator+        | Full.FieldSelection fieldSelection <- selection+        , Full.Field _ _ _ _ subselections _ <- fieldSelection =+            selection : foldr evaluateSelection accumulator subselections+        | Full.InlineFragmentSelection inlineSelection <- selection+        , Full.InlineFragment _ _ subselections _ <- inlineSelection =+            selection : foldr evaluateSelection accumulator subselections++-- | The graph of fragment spreads must not form any cycles including spreading+-- itself. Otherwise an operation could infinitely spread or infinitely execute+-- on cycles in the underlying data.+noFragmentCyclesRule :: forall m. Rule m+noFragmentCyclesRule = FragmentDefinitionRule $ \case+    Full.FragmentDefinition fragmentName _ _ selections location' -> do+        state <- evalStateT (collectFields selections)+            (0, fragmentName)+        let spreadPath = fst <$> sortBy (comparing snd) (HashMap.toList state)+        case reverse spreadPath of+            x : _ | x == fragmentName -> pure $ Error+                { message = concat+                    [ "Cannot spread fragment \""+                    , Text.unpack fragmentName+                    , "\" within itself (via "+                    , Text.unpack $ Text.intercalate " -> " $ fragmentName : spreadPath+                    , ")."+                    ]+                , locations = [location']+                }+            _ -> lift mempty+  where+    collectFields :: Traversable t+        => t Full.Selection+        -> StateT (Int, Full.Name) (ReaderT (Validation m) Seq) (HashMap Full.Name Int)+    collectFields selectionSet = foldM forEach HashMap.empty selectionSet+    forEach accumulator = \case+        Full.FieldSelection fieldSelection -> forField accumulator fieldSelection+        Full.InlineFragmentSelection fragmentSelection ->+            forInline accumulator fragmentSelection+        Full.FragmentSpreadSelection fragmentSelection ->+            forSpread accumulator fragmentSelection+    forSpread accumulator (Full.FragmentSpread fragmentName _ _) = do+        firstFragmentName <- gets snd+        modify $ first (+ 1)+        lastIndex <- gets fst+        let newAccumulator = HashMap.insert fragmentName lastIndex accumulator+        let inVisitetFragment = HashMap.member fragmentName accumulator+        if fragmentName == firstFragmentName || inVisitetFragment+            then pure newAccumulator+            else collectFromSpread fragmentName newAccumulator+    forInline accumulator (Full.InlineFragment _ _ selections _) =+        (accumulator <>) <$> collectFields selections+    forField accumulator (Full.Field _ _ _ _ selections _) =+        (accumulator <>) <$> collectFields selections+    collectFromSpread fragmentName accumulator = do+        ast' <- lift $ asks ast+        case findFragmentDefinition fragmentName ast' of+            Nothing -> pure accumulator+            Just (Full.FragmentDefinition _ _ _ selections _) ->+                (accumulator <>) <$> collectFields selections++findFragmentDefinition :: Text+    -> NonEmpty Full.Definition+    -> Maybe Full.FragmentDefinition+findFragmentDefinition fragmentName = foldr compareDefinition Nothing+  where+    compareDefinition (Full.ExecutableDefinition executableDefinition) Nothing+        | Full.DefinitionFragment fragmentDefinition <- executableDefinition+        , Full.FragmentDefinition anotherName _ _ _ _ <- fragmentDefinition+        , anotherName == fragmentName = Just fragmentDefinition+    compareDefinition _ accumulator = accumulator++-- | Fields and directives treat arguments as a mapping of argument name to+-- value. More than one argument with the same name in an argument set is+-- ambiguous and invalid.+uniqueArgumentNamesRule :: forall m. Rule m+uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule+  where+    fieldRule _ (Full.Field _ _ arguments _ _ _) =+        lift $ filterDuplicates extract "argument" arguments+    directiveRule (Full.Directive _ arguments _) =+        lift $ filterDuplicates extract "argument" arguments+    extract (Full.Argument argumentName _ location') = (argumentName, location')++-- | Directives are used to describe some metadata or behavioral change on the+-- definition they apply to. When more than one directive of the same name is+-- used, the expected metadata or behavior becomes ambiguous, therefore only one+-- of each directive is allowed per location.+uniqueDirectiveNamesRule :: forall m. Rule m+uniqueDirectiveNamesRule = DirectivesRule+    $ const $ lift . filterDuplicates extract "directive"+  where+    extract (Full.Directive directiveName _ location') =+        (directiveName, location')++filterDuplicates :: (a -> (Text, Full.Location)) -> String -> [a] -> Seq Error+filterDuplicates extract nodeType = Seq.fromList+    . fmap makeError+    . filter ((> 1) . length)+    . groupBy equalByName+    . sortOn getName+  where+    getName = fst . extract+    equalByName lhs rhs = getName lhs == getName rhs+    makeError directives' = Error+        { message = makeMessage $ head directives'+        , locations = snd . extract <$> directives'+        }+    makeMessage directive = concat+        [ "There can be only one "+        , nodeType+        , " named \""+        , Text.unpack $ fst $ extract directive+        , "\"."+        ]++-- | If any operation defines more than one variable with the same name, it is+-- ambiguous and invalid. It is invalid even if the type of the duplicate+-- variable is the same.+uniqueVariableNamesRule :: forall m. Rule m+uniqueVariableNamesRule = VariablesRule+    $ lift . filterDuplicates extract "variable"+  where+    extract (Full.VariableDefinition variableName _ _ location') =+        (variableName, location')++-- | Variables can only be input types. Objects, unions and interfaces cannot be+-- used as inputs.+variablesAreInputTypesRule :: forall m. Rule m+variablesAreInputTypesRule = VariablesRule+    $ (traverse check . Seq.fromList) >=> lift+  where+    check (Full.VariableDefinition name typeName _ location')+        = asks (Schema.types . schema)+        >>= lift+        . maybe (makeError name typeName location') (const mempty)+        . Type.lookupInputType typeName+    makeError name typeName location' = pure $ Error+        { message = concat+            [ "Variable \"$"+            , Text.unpack name+            , "\" cannot be non-input type \""+            , Text.unpack $ getTypeName typeName+            , "\"."+            ]+        , locations = [location']+        }+    getTypeName (Full.TypeNamed name) = name+    getTypeName (Full.TypeList name) = getTypeName name+    getTypeName (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) = nonNull+    getTypeName (Full.TypeNonNull (Full.NonNullTypeList nonNull)) =+        getTypeName nonNull++-- | Variables are scoped on a per‐operation basis. That means that any variable+-- used within the context of an operation must be defined at the top level of+-- that operation.+noUndefinedVariablesRule :: forall m. Rule m+noUndefinedVariablesRule =+    variableUsageDifference (flip HashMap.difference) errorMessage+  where+    errorMessage Nothing variableName = concat+        [ "Variable \"$"+        , Text.unpack variableName+        , "\" is not defined."+        ]+    errorMessage (Just operationName) variableName = concat+        [ "Variable \"$"+        , Text.unpack variableName+        , "\" is not defined by operation \""+        , Text.unpack operationName+        , "\"."+        ]++type UsageDifference+    = HashMap Full.Name [Full.Location]+    -> HashMap Full.Name [Full.Location]+    -> HashMap Full.Name [Full.Location]++variableUsageDifference :: forall m. UsageDifference+    -> (Maybe Full.Name -> Full.Name -> String)+    -> Rule m+variableUsageDifference difference errorMessage = OperationDefinitionRule $ \case+    Full.SelectionSet _ _ -> lift mempty+    Full.OperationDefinition _ operationName variables _ selections _ ->+        let variableNames = HashMap.fromList $ getVariableName <$> variables+         in mapReaderT (readerMapper operationName variableNames)+            $ flip evalStateT HashSet.empty+            $ filterSelections'+            $ toList selections+  where+    readerMapper operationName variableNames' = Seq.fromList+        . fmap (makeError operationName)+        . HashMap.toList+        . difference variableNames'+        . HashMap.fromListWith (++)+        . toList+    getVariableName (Full.VariableDefinition variableName _ _ location') =+        (variableName, [location'])+    filterSelections' :: Foldable t+        => t Full.Selection+        -> ValidationState m (Full.Name, [Full.Location])+    filterSelections' = filterSelections variableFilter+    variableFilter :: Full.Selection -> ValidationState m (Full.Name, [Full.Location])+    variableFilter (Full.InlineFragmentSelection inline)+        | Full.InlineFragment _ directives' _ _ <- inline =+            lift $ lift $ mapDirectives directives'+    variableFilter (Full.FieldSelection fieldSelection)+        | Full.Field _ _ arguments directives' _ _ <- fieldSelection =+            lift $ lift $ mapArguments arguments <> mapDirectives directives'+    variableFilter (Full.FragmentSpreadSelection spread)+        | Full.FragmentSpread fragmentName _ _ <- spread = do+            definitions <- lift $ asks ast+            visited <- gets (HashSet.member fragmentName)+            modify (HashSet.insert fragmentName)+            case find (isSpreadTarget fragmentName) definitions of+                Just (viewFragment -> Just fragmentDefinition)+                    | not visited -> diveIntoSpread fragmentDefinition+                _ -> lift $ lift mempty+    diveIntoSpread (Full.FragmentDefinition _ _ directives' selections _)+        = filterSelections' selections+        >>= lift . mapReaderT (<> mapDirectives directives') . pure+    findDirectiveVariables (Full.Directive _ arguments _) = mapArguments arguments+    mapArguments = Seq.fromList . mapMaybe findArgumentVariables+    mapDirectives = foldMap findDirectiveVariables+    findArgumentVariables (Full.Argument _ Full.Node{ node = Full.Variable value', ..} _) =+        Just (value', [location])+    findArgumentVariables _ = Nothing+    makeError operationName (variableName, locations') = Error+        { message = errorMessage operationName variableName+        , locations = locations'+        }++-- | All variables defined by an operation must be used in that operation or a+-- fragment transitively included by that operation. Unused variables cause a+-- validation error.+noUnusedVariablesRule :: forall m. Rule m+noUnusedVariablesRule = variableUsageDifference HashMap.difference errorMessage+  where+    errorMessage Nothing variableName = concat+        [ "Variable \"$"+        , Text.unpack variableName+        , "\" is never used."+        ]+    errorMessage (Just operationName) variableName = concat+        [ "Variable \"$"+        , Text.unpack variableName+        , "\" is never used in operation \""+        , Text.unpack operationName+        , "\"."+        ]++-- | Input objects must not contain more than one field of the same name,+-- otherwise an ambiguity would exist which includes an ignored portion of+-- syntax.+uniqueInputFieldNamesRule :: forall m. Rule m+uniqueInputFieldNamesRule =+    ValueRule (const $ lift . go) (const $ lift . constGo)+  where+    go (Full.Node (Full.Object fields) _) = filterFieldDuplicates fields+    go _ = mempty+    filterFieldDuplicates fields =+        filterDuplicates getFieldName "input field" fields+    getFieldName (Full.ObjectField fieldName _ location') = (fieldName, location')+    constGo (Full.Node (Full.ConstObject fields) _) = filterFieldDuplicates fields+    constGo _ = mempty++-- | The target field of a field selection must be defined on the scoped type of+-- the selection set. There are no limitations on alias names.+fieldsOnCorrectTypeRule :: forall m. Rule m+fieldsOnCorrectTypeRule = FieldRule fieldRule+  where+    fieldRule parentType (Full.Field _ fieldName _ _ _ location')+        | Just objectType <- parentType+        , Nothing <- Type.lookupTypeField fieldName objectType+        , Just typeName <- compositeTypeName objectType = pure $ Error+            { message = errorMessage fieldName typeName+            , locations = [location']+            }+        | otherwise = lift mempty+    errorMessage fieldName typeName = concat+        [ "Cannot query field \""+        , Text.unpack fieldName+        , "\" on type \""+        , Text.unpack typeName+        , "\"."+        ]++compositeTypeName :: forall m. Out.Type m -> Maybe Full.Name+compositeTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =+    Just typeName+compositeTypeName (Out.InterfaceBaseType interfaceType) =+    let Out.InterfaceType typeName _ _ _ = interfaceType+        in Just typeName+compositeTypeName (Out.UnionBaseType (Out.UnionType typeName _ _)) =+    Just typeName+compositeTypeName (Out.ScalarBaseType _) =+    Nothing+compositeTypeName (Out.EnumBaseType _) =+    Nothing+compositeTypeName (Out.ListBaseType wrappedType) =+    compositeTypeName wrappedType++-- | Field selections on scalars or enums are never allowed, because they are+-- the leaf nodes of any GraphQL query.+scalarLeafsRule :: forall m. Rule m+scalarLeafsRule = FieldRule fieldRule+  where+    fieldRule parentType selectionField@(Full.Field _ fieldName _ _ _ _)+        | Just objectType <- parentType+        , Just field <- Type.lookupTypeField fieldName objectType =+            let Out.Field _ fieldType _ = field+             in lift $ check fieldType selectionField+        | otherwise = lift mempty+    check (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =+        checkNotEmpty typeName+    check (Out.InterfaceBaseType (Out.InterfaceType typeName _ _ _)) =+        checkNotEmpty typeName+    check (Out.UnionBaseType (Out.UnionType typeName _ _)) =+        checkNotEmpty typeName+    check (Out.ScalarBaseType (Definition.ScalarType typeName _)) =+        checkEmpty typeName+    check (Out.EnumBaseType (Definition.EnumType typeName _ _)) =+        checkEmpty typeName+    check (Out.ListBaseType wrappedType) = check wrappedType+    checkNotEmpty typeName (Full.Field _ fieldName _ _ [] location') =+        let fieldName' = Text.unpack fieldName+         in makeError location' $ concat+            [ "Field \""+            , fieldName'+            , "\" of type \""+            , Text.unpack typeName+            , "\" must have a selection of subfields. Did you mean \""+            , fieldName'+            , " { ... }\"?"+            ]+    checkNotEmpty _ _ = mempty+    checkEmpty _ (Full.Field _ _ _ _ [] _) = mempty+    checkEmpty typeName field' =+        let Full.Field _ fieldName _ _ _ location' = field'+         in makeError location' $ concat+            [ "Field \""+            , Text.unpack fieldName+            , "\" must not have a selection since type \""+            , Text.unpack typeName+            , "\" has no subfields."+            ]+    makeError location' errorMessage = pure $ Error+        { message = errorMessage+        , locations = [location']+        }++-- | Every argument provided to a field or directive must be defined in the set+-- of possible arguments of that field or directive.+knownArgumentNamesRule :: forall m. Rule m+knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule+  where+    fieldRule (Just objectType) (Full.Field _ fieldName arguments  _ _ _)+        | Just typeField <- Type.lookupTypeField fieldName objectType+        , Just typeName <- compositeTypeName objectType =+            lift $ foldr (go typeName fieldName typeField) Seq.empty arguments+    fieldRule _ _ = lift mempty+    go typeName fieldName fieldDefinition (Full.Argument argumentName _ location') errors+        | Out.Field _ _ definitions <- fieldDefinition+        , Just _ <- HashMap.lookup argumentName definitions = errors+        | otherwise = errors |> Error+            { message = fieldMessage argumentName fieldName typeName+            , locations = [location']+            }+    fieldMessage argumentName fieldName typeName = concat+        [ "Unknown argument \""+        , Text.unpack argumentName+        , "\" on field \""+        , Text.unpack typeName+        , "."+        , Text.unpack fieldName+        , "\"."+        ]+    directiveRule (Full.Directive directiveName arguments _) = do+        available <- asks $ HashMap.lookup directiveName+            . Schema.directives . schema+        Full.Argument argumentName _ location' <- lift $ Seq.fromList arguments+        case available of+            Just (Schema.Directive _ _ definitions)+                | not $ HashMap.member argumentName definitions ->+                    pure $ makeError argumentName directiveName location'+            _ -> lift mempty+    makeError argumentName directiveName location' = Error+        { message = directiveMessage argumentName directiveName+        , locations = [location']+        }+    directiveMessage argumentName directiveName = concat+        [ "Unknown argument \""+        , Text.unpack argumentName+        , "\" on directive \"@"+        , Text.unpack directiveName+        , "\"."+        ]++-- | GraphQL servers define what directives they support. For each usage of a+-- directive, the directive must be available on that server.+knownDirectiveNamesRule :: Rule m+knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do+    definitions' <- asks $ Schema.directives . schema+    let directiveSet = HashSet.fromList $ fmap directiveName directives'+    let definitionSet = HashSet.fromList $ HashMap.keys definitions'+    let difference = HashSet.difference directiveSet definitionSet+    let undefined' = filter (definitionFilter difference) directives'+    lift $ Seq.fromList $ makeError <$> undefined'+  where+    definitionFilter difference = flip HashSet.member difference+        . directiveName+    directiveName (Full.Directive directiveName' _ _) = directiveName'+    makeError (Full.Directive directiveName' _ location') = Error+        { message = errorMessage directiveName'+        , locations = [location']+        }+    errorMessage directiveName' = concat+        [ "Unknown directive \"@"+        , Text.unpack directiveName'+        , "\"."+        ]++-- | Every input field provided in an input object value must be defined in the+-- set of possible fields of that input object’s expected type.+knownInputFieldNamesRule :: Rule m+knownInputFieldNamesRule = ValueRule go constGo+  where+    go (Just valueType) (Full.Node (Full.Object inputFields) _)+        | In.InputObjectBaseType objectType <- valueType =+             lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields+    go _ _ = lift mempty+    constGo (Just valueType) (Full.Node (Full.ConstObject inputFields) _)+        | In.InputObjectBaseType objectType <- valueType =+             lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields+    constGo  _ _ = lift mempty+    forEach objectType (Full.ObjectField inputFieldName _ location')+        | In.InputObjectType _ _ fieldTypes <- objectType+        , Just _ <- HashMap.lookup inputFieldName fieldTypes = Nothing+        | otherwise+        , In.InputObjectType typeName _ _ <- objectType = pure $ Error+            { message = errorMessage inputFieldName typeName+            , locations = [location']+            }+    errorMessage fieldName typeName = concat+        [ "Field \""+        , Text.unpack fieldName+        , "\" is not defined by type \""+        , Text.unpack typeName+        , "\"."+        ]++-- | GraphQL servers define what directives they support and where they support+-- them. For each usage of a directive, the directive must be used in a location+-- that the server has declared support for.+directivesInValidLocationsRule :: Rule m+directivesInValidLocationsRule = DirectivesRule directivesRule+  where+    directivesRule directiveLocation directives' = do+        Full.Directive directiveName _ location <- lift $ Seq.fromList directives'+        maybeDefinition <- asks+            $ HashMap.lookup directiveName . Schema.directives . schema+        case maybeDefinition of+            Just (Schema.Directive _ allowedLocations _)+                | directiveLocation `notElem` allowedLocations -> pure $ Error+                    { message = errorMessage directiveName directiveLocation+                    , locations = [location]+                    }+            _ -> lift mempty+    errorMessage directiveName directiveLocation = concat+        [ "Directive \"@"+        , Text.unpack directiveName+        , "\" may not be used on "+        , show directiveLocation+        , "."+        ]++-- | Arguments can be required. An argument is required if the argument type is+-- non‐null and does not have a default value. Otherwise, the argument is+-- optional.+providedRequiredArgumentsRule :: Rule m+providedRequiredArgumentsRule = ArgumentsRule fieldRule directiveRule+  where+    fieldRule (Just objectType) (Full.Field _ fieldName arguments  _ _ location')+        | Just typeField <- Type.lookupTypeField fieldName objectType+        , Out.Field _ _ definitions <- typeField =+            let forEach = go (fieldMessage fieldName) arguments location'+             in lift $ HashMap.foldrWithKey forEach Seq.empty definitions+    fieldRule _ _ = lift mempty+    directiveRule (Full.Directive directiveName arguments location') = do+        available <- asks+            $ HashMap.lookup directiveName . Schema.directives . schema+        case available of+            Just (Schema.Directive _ _ definitions) ->+                let forEach = go (directiveMessage directiveName) arguments location'+                 in lift $ HashMap.foldrWithKey forEach Seq.empty definitions+            _ -> lift mempty+    go makeMessage arguments location' argumentName argumentType errors+        | In.Argument _ type' optionalValue <- argumentType+        , In.isNonNullType type'+        , typeName <- inputTypeName type'+        , isNothing optionalValue+        , isNothingOrNull $ find (lookupArgument argumentName) arguments+            = errors+            |> makeError (makeMessage argumentName typeName) location'+        | otherwise = errors+    makeError errorMessage location' = Error+        { message = errorMessage+        , locations = [location']+        }+    isNothingOrNull (Just (Full.Argument _ (Full.Node Full.Null _) _)) = True+    isNothingOrNull x = isNothing x+    lookupArgument needle (Full.Argument argumentName _ _) =+        needle == argumentName+    fieldMessage fieldName argumentName typeName = concat+        [ "Field \""+        , Text.unpack fieldName+        , "\" argument \""+        , Text.unpack argumentName+        , "\" of type \""+        , Text.unpack typeName+        , "\" is required, but it was not provided."+        ]+    directiveMessage directiveName argumentName typeName = concat+        [ "Directive \"@"+        , Text.unpack directiveName+        , "\" argument \""+        , Text.unpack argumentName+        , "\" of type \""+        , Text.unpack typeName+        , "\" is required, but it was not provided."+        ]++inputTypeName :: In.Type -> Text+inputTypeName (In.ScalarBaseType (Definition.ScalarType typeName _)) = typeName+inputTypeName (In.EnumBaseType (Definition.EnumType typeName _ _)) = typeName+inputTypeName (In.InputObjectBaseType (In.InputObjectType typeName _ _)) =+    typeName+inputTypeName (In.ListBaseType listType) = inputTypeName listType++-- | Input object fields may be required. Much like a field may have required+-- arguments, an input object may have required fields. An input field is+-- required if it has a non‐null type and does not have a default value.+-- Otherwise, the input object field is optional.+providedRequiredInputFieldsRule :: Rule m+providedRequiredInputFieldsRule = ValueRule go constGo+  where+    go (Just valueType) (Full.Node (Full.Object inputFields) location')+        | In.InputObjectBaseType objectType <- valueType+        , In.InputObjectType objectTypeName _ fieldDefinitions <- objectType+            = lift+            $ Seq.fromList+            $ HashMap.elems+            $ flip HashMap.mapMaybeWithKey fieldDefinitions+            $ forEach inputFields objectTypeName location'+    go _ _ = lift mempty+    constGo  _ _ = lift mempty+    forEach inputFields typeName location' definitionName fieldDefinition+        | In.InputField _ inputType optionalValue <- fieldDefinition+        , In.isNonNullType inputType+        , isNothing optionalValue+        , isNothingOrNull $ find (lookupField definitionName) inputFields =+            Just $ makeError definitionName typeName location'+        | otherwise = Nothing+    isNothingOrNull (Just (Full.ObjectField _ (Full.Node Full.Null _) _)) = True+    isNothingOrNull x = isNothing x+    lookupField needle (Full.ObjectField fieldName _ _) = needle == fieldName+    makeError fieldName typeName location' = Error+        { message = errorMessage fieldName typeName+        , locations = [location']+        }+    errorMessage fieldName typeName = concat+        [ "Input field \""+        , Text.unpack fieldName+        , "\" of type \""+        , Text.unpack typeName+        , "\" is required, but it was not provided."+        ]

@@ -5,41 +5,29 @@ -- | Definitions used by the validation rules and the validator itself. module Language.GraphQL.Validate.Validation     ( Error(..)-    , Path(..)     , Rule(..)     , RuleT     , Validation(..)     ) where -import Control.Monad.Trans.Reader (ReaderT(..))-import Data.HashMap.Strict (HashMap)-import Data.Text (Text)+import Control.Monad.Trans.Reader (ReaderT)+import Data.Sequence (Seq)+import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..)) import Language.GraphQL.AST.Document+import qualified Language.GraphQL.Type.In as In+import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Type.Schema (Schema)-import qualified Language.GraphQL.Type.Schema as Schema --- | If an error can be associated to a particular field in the GraphQL result,--- it must contain an entry with the key path that details the path of the--- response field which experienced the error. This allows clients to identify--- whether a null result is intentional or caused by a runtime error.-data Path-    = Segment Text -- ^ Field name.-    | Index Int -- ^ List index if a field returned a list.-    deriving (Eq, Show)- -- | Validation error. data Error = Error     { message :: String     , locations :: [Location]-    , path :: [Path]     } deriving (Eq, Show)  -- | Validation rule context. data Validation m = Validation     { ast :: Document     , schema :: Schema m-    , types :: HashMap Name (Schema.Type m)-    , rules :: [Rule m]     }  -- | 'Rule' assigns a function to each AST node that can be validated. If the@@ -49,6 +37,14 @@     = DefinitionRule (Definition -> RuleT m)     | OperationDefinitionRule (OperationDefinition -> RuleT m)     | FragmentDefinitionRule (FragmentDefinition -> RuleT m)+    | SelectionRule (Maybe (Out.Type m) -> Selection -> RuleT m)+    | FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m)+    | FragmentSpreadRule (FragmentSpread -> RuleT m)+    | FieldRule (Maybe (Out.Type m) -> Field -> RuleT m)+    | ArgumentsRule (Maybe (Out.Type m) -> Field -> RuleT m) (Directive -> RuleT m)+    | DirectivesRule (DirectiveLocation -> [Directive] -> RuleT m)+    | VariablesRule ([VariableDefinition] -> RuleT m)+    | ValueRule (Maybe In.Type -> Node Value -> RuleT m) (Maybe In.Type -> Node ConstValue -> RuleT m)  -- | Monad transformer used by the rules.-type RuleT m = ReaderT (Validation m) Maybe Error+type RuleT m = ReaderT (Validation m) Seq Error

@@ -4,7 +4,7 @@     ( spec     ) where -import Language.GraphQL.AST+import qualified Language.GraphQL.AST.Document as Full import Language.GraphQL.AST.Encoder import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain) import Test.QuickCheck (choose, oneof, forAll)@@ -15,52 +15,52 @@ spec = do     describe "value" $ do         context "null value" $ do-            let testNull formatter = value formatter Null `shouldBe` "null"+            let testNull formatter = value formatter Full.Null `shouldBe` "null"             it "minified" $ testNull minified             it "pretty" $ testNull pretty          context "minified" $ do             it "escapes \\" $-                value minified (String "\\") `shouldBe` "\"\\\\\""+                value minified (Full.String "\\") `shouldBe` "\"\\\\\""             it "escapes double quotes" $-                value minified (String "\"") `shouldBe` "\"\\\"\""+                value minified (Full.String "\"") `shouldBe` "\"\\\"\""             it "escapes \\f" $-                value minified (String "\f") `shouldBe` "\"\\f\""+                value minified (Full.String "\f") `shouldBe` "\"\\f\""             it "escapes \\n" $-                value minified (String "\n") `shouldBe` "\"\\n\""+                value minified (Full.String "\n") `shouldBe` "\"\\n\""             it "escapes \\r" $-                value minified (String "\r") `shouldBe` "\"\\r\""+                value minified (Full.String "\r") `shouldBe` "\"\\r\""             it "escapes \\t" $-                value minified (String "\t") `shouldBe` "\"\\t\""+                value minified (Full.String "\t") `shouldBe` "\"\\t\""             it "escapes backspace" $-                value minified (String "a\bc") `shouldBe` "\"a\\bc\""+                value minified (Full.String "a\bc") `shouldBe` "\"a\\bc\""             context "escapes Unicode for chars less than 0010" $ do-                it "Null" $ value minified (String "\x0000") `shouldBe` "\"\\u0000\""-                it "bell" $ value minified (String "\x0007") `shouldBe` "\"\\u0007\""+                it "Null" $ value minified (Full.String "\x0000") `shouldBe` "\"\\u0000\""+                it "bell" $ value minified (Full.String "\x0007") `shouldBe` "\"\\u0007\""             context "escapes Unicode for char less than 0020" $ do-                it "DLE" $ value minified (String "\x0010") `shouldBe` "\"\\u0010\""-                it "EM" $ value minified (String "\x0019") `shouldBe` "\"\\u0019\""+                it "DLE" $ value minified (Full.String "\x0010") `shouldBe` "\"\\u0010\""+                it "EM" $ value minified (Full.String "\x0019") `shouldBe` "\"\\u0019\""             context "encodes without escape" $ do-                it "space" $ value minified (String "\x0020") `shouldBe` "\" \""-                it "~" $ value minified (String "\x007E") `shouldBe` "\"~\""+                it "space" $ value minified (Full.String "\x0020") `shouldBe` "\" \""+                it "~" $ value minified (Full.String "\x007E") `shouldBe` "\"~\""          context "pretty" $ do             it "uses strings for short string values" $-                value pretty (String "Short text") `shouldBe` "\"Short text\""+                value pretty (Full.String "Short text") `shouldBe` "\"Short text\""             it "uses block strings for text with new lines, with newline symbol" $-                value pretty (String "Line 1\nLine 2")+                value pretty (Full.String "Line 1\nLine 2")                     `shouldBe` [r|"""   Line 1   Line 2 """|]             it "uses block strings for text with new lines, with CR symbol" $-                value pretty (String "Line 1\rLine 2")+                value pretty (Full.String "Line 1\rLine 2")                     `shouldBe` [r|"""   Line 1   Line 2 """|]             it "uses block strings for text with new lines, with CR symbol followed by newline" $-                value pretty (String "Line 1\r\nLine 2")+                value pretty (Full.String "Line 1\r\nLine 2")                     `shouldBe` [r|"""   Line 1   Line 2@@ -77,12 +77,12 @@                 forAll genNotAllowedSymbol $ \x -> do                     let                       rawValue = "Short \n" <> cons x "text"-                      encoded = value pretty (String $ toStrict rawValue)+                      encoded = value pretty (Full.String $ toStrict rawValue)                     shouldStartWith (unpack encoded) "\""                     shouldEndWith (unpack encoded) "\""                     shouldNotContain (unpack encoded) "\"\"\"" -            it "Hello world" $ value pretty (String "Hello,\n  World!\n\nYours,\n  GraphQL.")+            it "Hello world" $ value pretty (Full.String "Hello,\n  World!\n\nYours,\n  GraphQL.")               `shouldBe` [r|"""   Hello,     World!@@ -91,29 +91,29 @@     GraphQL. """|] -            it "has only newlines" $ value pretty (String "\n") `shouldBe` [r|"""+            it "has only newlines" $ value pretty (Full.String "\n") `shouldBe` [r|"""   """|]             it "has newlines and one symbol at the begining" $-              value pretty (String "a\n\n") `shouldBe` [r|"""+              value pretty (Full.String "a\n\n") `shouldBe` [r|"""   a   """|]             it "has newlines and one symbol at the end" $-              value pretty (String "\n\na") `shouldBe` [r|"""+              value pretty (Full.String "\n\na") `shouldBe` [r|"""     a """|]             it "has newlines and one symbol in the middle" $-              value pretty (String "\na\n") `shouldBe` [r|"""+              value pretty (Full.String "\na\n") `shouldBe` [r|"""    a  """|]-            it "skip trailing whitespaces" $ value pretty (String "  Short\ntext    ")+            it "skip trailing whitespaces" $ value pretty (Full.String "  Short\ntext    ")               `shouldBe` [r|"""   Short   text@@ -121,11 +121,13 @@      describe "definition" $         it "indents block strings in arguments" $-            let arguments = [Argument "message" (String "line1\nline2")]-                field = Field Nothing "field" arguments [] []-                operation = DefinitionOperation-                    $ SelectionSet (pure field)-                    $ Location 0 0+            let location = Full.Location 0 0+                argumentValue = Full.Node (Full.String "line1\nline2") location+                arguments = [Full.Argument "message" argumentValue location]+                field = Full.Field Nothing "field" arguments [] [] location+                fieldSelection = pure $ Full.FieldSelection field+                operation = Full.DefinitionOperation+                    $ Full.SelectionSet fieldSelection location              in definition pretty operation `shouldBe` [r|{   field(message: """     line1

@@ -75,9 +75,9 @@             parse dollar "" "$" `shouldParse` "$"             runBetween parens `shouldSucceedOn` "()"             parse spread "" "..." `shouldParse` "..."-            parse colon "" ":" `shouldParse` ":"+            parse colon "" `shouldSucceedOn` ":"             parse equals "" "=" `shouldParse` "="-            parse at "" "@" `shouldParse` "@"+            parse at "" `shouldSucceedOn` "@"             runBetween brackets `shouldSucceedOn` "[]"             runBetween braces `shouldSucceedOn` "{}"             parse pipe "" "|" `shouldParse` "|"

@@ -128,7 +128,7 @@         parse document "" `shouldSucceedOn` [r|extend schema { query: Query }|]      it "parses schema extension with an operation type and directive" $-        let newDirective = Directive "newDirective" []+        let newDirective = Directive "newDirective" [] $ Location 1 15             schemaExtension = SchemaExtension                 $ SchemaOperationExtension [newDirective]                 $ OperationTypeDefinition Query "Query" :| []

@@ -19,6 +19,6 @@ spec :: Spec spec = describe "singleError" $     it "constructs an error with the given message" $-        let errors'' = Seq.singleton $ Error "Message." []+        let errors'' = Seq.singleton $ Error "Message." [] []             expected = Response Aeson.Null errors''          in singleError "Message." `shouldBe` expected

@@ -3,6 +3,7 @@    obtain one at https://mozilla.org/MPL/2.0/. -}  {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} module Language.GraphQL.ExecuteSpec     ( spec     ) where@@ -10,10 +11,11 @@ import Control.Exception (SomeException) import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson+import Data.Aeson.Types (emptyObject) import Data.Conduit import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap-import Language.GraphQL.AST (Name)+import Language.GraphQL.AST (Document, Name) import Language.GraphQL.AST.Parser (document) import Language.GraphQL.Error import Language.GraphQL.Execute@@ -21,13 +23,10 @@ import Language.GraphQL.Type.Out as Out import Test.Hspec (Spec, context, describe, it, shouldBe) import Text.Megaparsec (parse)+import Text.RawString.QQ (r) -schema :: Schema (Either SomeException)-schema = Schema-    { query = queryType-    , mutation = Nothing-    , subscription = Just subscriptionType-    }+philosopherSchema :: Schema (Either SomeException)+philosopherSchema = schema queryType Nothing (Just subscriptionType) mempty  queryType :: Out.ObjectType (Either SomeException) queryType = Out.ObjectType "Query" Nothing []@@ -71,9 +70,32 @@     quoteField =         Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty +type EitherStreamOrValue = Either+    (ResponseEventStream (Either SomeException) Aeson.Value)+    (Response Aeson.Value)++execute' :: Document -> Either SomeException EitherStreamOrValue+execute' =+    execute philosopherSchema Nothing (mempty :: HashMap Name Aeson.Value)+ spec :: Spec spec =     describe "execute" $ do+        it "rejects recursive fragments" $+            let sourceQuery = [r|+              {+                ...cyclicFragment+              }++              fragment cyclicFragment on Query {+                ...cyclicFragment+              }+            |]+                expected = Response emptyObject mempty+                Right (Right actual) = either (pure . parseError) execute'+                    $ parse document "" sourceQuery+             in actual `shouldBe` expected+         context "Query" $ do             it "skips unknown fields" $                 let data'' = Aeson.object@@ -82,7 +104,6 @@                             ]                         ]                     expected = Response data'' mempty-                    execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)                     Right (Right actual) = either (pure . parseError) execute'                         $ parse document "" "{ philosopher { firstName surname } }"                 in actual `shouldBe` expected@@ -94,7 +115,6 @@                             ]                         ]                     expected = Response data'' mempty-                    execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)                     Right (Right actual) = either (pure . parseError) execute'                         $ parse document "" "{ philosopher { firstName } philosopher { lastName } }"                 in actual `shouldBe` expected@@ -106,7 +126,6 @@                             ]                         ]                     expected = Response data'' mempty-                    execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)                     Right (Left stream) = either (pure . parseError) execute'                         $ parse document "" "subscription { newQuote { quote } }"                     Right (Just actual) = runConduit $ stream .| await

@@ -9,8 +9,7 @@     ( spec     ) where -import Data.Sequence (Seq(..))-import qualified Data.Sequence as Seq+import Data.Foldable (toList) import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import qualified Language.GraphQL.AST as AST@@ -18,23 +17,25 @@ import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Validate-import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Hspec (Spec, describe, it, shouldBe, shouldContain) import Text.Megaparsec (parse) import Text.RawString.QQ (r) -schema :: Schema IO-schema = Schema-    { query = queryType-    , mutation = Nothing-    , subscription = Nothing-    } +petSchema :: Schema IO+petSchema = schema queryType Nothing (Just subscriptionType) mempty  queryType :: ObjectType IO-queryType = ObjectType "Query" Nothing []-    $ HashMap.singleton "dog" dogResolver+queryType = ObjectType "Query" Nothing [] $ HashMap.fromList+    [ ("dog", dogResolver)+    , ("findDog", findDogResolver)+    ]   where     dogField = Field Nothing (Out.NamedObjectType dogType) mempty     dogResolver = ValueResolver dogField $ pure Null+    findDogArguments = HashMap.singleton "complex"+        $ In.Argument Nothing (In.NonNullInputObjectType dogDataType) Nothing+    findDogField = Field Nothing (Out.NamedObjectType dogType) findDogArguments+    findDogResolver = ValueResolver findDogField $ pure Null  dogCommandType :: EnumType dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList@@ -72,6 +73,12 @@     ownerField = Field Nothing (Out.NamedObjectType humanType) mempty     ownerResolver = ValueResolver ownerField $ pure Null +dogDataType :: InputObjectType+dogDataType = InputObjectType "DogData" Nothing+    $ HashMap.singleton "name" nameInputField+  where+    nameInputField = InputField Nothing (In.NonNullScalarType string) Nothing+ sentientType :: InterfaceType IO sentientType = InterfaceType "Sentient" Nothing []     $ HashMap.singleton "name"@@ -81,19 +88,28 @@ petType = InterfaceType "Pet" Nothing []     $ HashMap.singleton "name"     $ Field Nothing (Out.NonNullScalarType string) mempty-{--alienType :: ObjectType IO-alienType = ObjectType "Alien" Nothing [sentientType] $ HashMap.fromList-    [ ("name", nameResolver)-    , ("homePlanet", homePlanetResolver)++subscriptionType :: ObjectType IO+subscriptionType = ObjectType "Subscription" Nothing [] $ HashMap.fromList+    [ ("newMessage", newMessageResolver)+    , ("disallowedSecondRootField", newMessageResolver)     ]   where-    nameField = Field Nothing (Out.NonNullScalarType string) mempty-    nameResolver = ValueResolver nameField $ pure "Name"-    homePlanetField =-        Field Nothing (Out.NamedScalarType string) mempty-    homePlanetResolver = ValueResolver homePlanetField $ pure "Home planet"--}+    newMessageField = Field Nothing (Out.NonNullObjectType messageType) mempty+    newMessageResolver = ValueResolver newMessageField+        $ pure $ Object HashMap.empty++messageType :: ObjectType IO+messageType = ObjectType "Message" Nothing [] $ HashMap.fromList+    [ ("sender", senderResolver)+    , ("body", bodyResolver)+    ]+  where+    senderField = Field Nothing (Out.NonNullScalarType string) mempty+    senderResolver = ValueResolver senderField $ pure "Sender"+    bodyField = Field Nothing (Out.NonNullScalarType string) mempty+    bodyResolver = ValueResolver bodyField $ pure "Message body."+ humanType :: ObjectType IO humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList     [ ("name", nameResolver)@@ -106,45 +122,14 @@         Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty     petsResolver = ValueResolver petsField $ pure $ List [] {--catCommandType :: EnumType-catCommandType = EnumType "CatCommand" Nothing $ HashMap.fromList-    [ ("JUMP", EnumValue Nothing)-    ]--catType :: ObjectType IO-catType = ObjectType "Cat" Nothing [petType] $ HashMap.fromList-    [ ("name", nameResolver)-    , ("nickname", nicknameResolver)-    , ("doesKnowCommand", doesKnowCommandResolver)-    , ("meowVolume", meowVolumeResolver)-    ]-  where-    nameField = Field Nothing (Out.NonNullScalarType string) mempty-    nameResolver = ValueResolver nameField $ pure "Name"-    nicknameField = Field Nothing (Out.NamedScalarType string) mempty-    nicknameResolver = ValueResolver nicknameField $ pure "Nickname"-    doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)-        $ HashMap.singleton "catCommand"-        $ In.Argument Nothing (In.NonNullEnumType catCommandType) Nothing-    doesKnowCommandResolver = ValueResolver doesKnowCommandField-        $ pure $ Boolean True-    meowVolumeField = Field Nothing (Out.NamedScalarType int) mempty-    meowVolumeResolver = ValueResolver meowVolumeField $ pure $ Int 2- catOrDogType :: UnionType IO catOrDogType = UnionType "CatOrDog" Nothing [catType, dogType]--dogOrHumanType :: UnionType IO-dogOrHumanType = UnionType "DogOrHuman" Nothing [dogType, humanType]--humanOrAlienType :: UnionType IO-humanOrAlienType = UnionType "HumanOrAlien" Nothing [humanType, alienType] -}-validate :: Text -> Seq Error+validate :: Text -> [Error] validate queryString =     case parse AST.document "" queryString of-        Left _ -> Seq.empty-        Right ast -> document schema specifiedRules ast+        Left _ -> []+        Right ast -> toList $ document petSchema specifiedRules ast  spec :: Spec spec =@@ -166,9 +151,8 @@                     { message =                         "Definition must be OperationDefinition or FragmentDefinition."                     , locations = [AST.Location 9 15]-                    , path = []                     }-             in validate queryString `shouldBe` Seq.singleton expected+               in validate queryString `shouldContain` [expected]          it "rejects multiple subscription root fields" $             let queryString = [r|@@ -182,11 +166,11 @@             |]                 expected = Error                     { message =-                        "Subscription sub must select only one top level field."+                        "Subscription \"sub\" must select only one top level \+                        \field."                     , locations = [AST.Location 2 15]-                    , path = []                     }-             in validate queryString `shouldBe` Seq.singleton expected+             in validate queryString `shouldContain` [expected]          it "rejects multiple subscription root fields coming from a fragment" $             let queryString = [r|@@ -204,11 +188,11 @@             |]                 expected = Error                     { message =-                        "Subscription sub must select only one top level field."+                        "Subscription \"sub\" must select only one top level \+                        \field."                     , locations = [AST.Location 2 15]-                    , path = []                     }-             in validate queryString `shouldBe` Seq.singleton expected+             in validate queryString `shouldContain` [expected]          it "rejects multiple anonymous operations" $             let queryString = [r|@@ -230,9 +214,8 @@                     { message =                         "This anonymous operation must be the only defined operation."                     , locations = [AST.Location 2 15]-                    , path = []                     }-             in validate queryString `shouldBe` Seq.singleton expected+             in validate queryString `shouldBe` [expected]          it "rejects operations with the same name" $             let queryString = [r|@@ -252,9 +235,8 @@                     { message =                         "There can be only one operation named \"dogOperation\"."                     , locations = [AST.Location 2 15, AST.Location 8 15]-                    , path = []                     }-             in validate queryString `shouldBe` Seq.singleton expected+             in validate queryString `shouldBe` [expected]          it "rejects fragments with the same name" $             let queryString = [r|@@ -278,6 +260,406 @@                     { message =                         "There can be only one fragment named \"fragmentOne\"."                     , locations = [AST.Location 8 15, AST.Location 12 15]-                    , path = []                     }-             in validate queryString `shouldBe` Seq.singleton expected+             in validate queryString `shouldBe` [expected]++        it "rejects the fragment spread without a target" $+            let queryString = [r|+              {+                dog {+                  ...undefinedFragment+                }+              }+            |]+                expected = Error+                    { message =+                        "Fragment target \"undefinedFragment\" is undefined."+                    , locations = [AST.Location 4 19]+                    }+             in validate queryString `shouldBe` [expected]++        it "rejects fragment spreads without an unknown target type" $+            let queryString = [r|+              {+                dog {+                  ...notOnExistingType+                }+              }+              fragment notOnExistingType on NotInSchema {+                name+              }+            |]+                expected = Error+                    { message =+                        "Fragment \"notOnExistingType\" is specified on type \+                        \\"NotInSchema\" which doesn't exist in the schema."+                    , locations = [AST.Location 4 19]+                    }+             in validate queryString `shouldBe` [expected]++        it "rejects inline fragments without a target" $+            let queryString = [r|+              {+                ... on NotInSchema {+                  name+                }+              }+            |]+                expected = Error+                    { message =+                        "Inline fragment is specified on type \"NotInSchema\" \+                        \which doesn't exist in the schema."+                    , locations = [AST.Location 3 17]+                    }+             in validate queryString `shouldBe` [expected]++        it "rejects fragments on scalar types" $+            let queryString = [r|+              {+                dog {+                  ...fragOnScalar+                }+              }+              fragment fragOnScalar on Int {+                name+              }+            |]+                expected = Error+                    { message =+                        "Fragment cannot condition on non composite type \+                        \\"Int\"."+                    , locations = [AST.Location 7 15]+                    }+             in validate queryString `shouldContain` [expected]++        it "rejects inline fragments on scalar types" $+            let queryString = [r|+              {+                ... on Boolean {+                  name+                }+              }+            |]+                expected = Error+                    { message =+                        "Fragment cannot condition on non composite type \+                        \\"Boolean\"."+                    , locations = [AST.Location 3 17]+                    }+             in validate queryString `shouldContain` [expected]++        it "rejects unused fragments" $+            let queryString = [r|+              fragment nameFragment on Dog { # unused+                name+              }++              {+                dog {+                  name+                }+              }+            |]+                expected = Error+                    { message =+                        "Fragment \"nameFragment\" is never used."+                    , locations = [AST.Location 2 15]+                    }+             in validate queryString `shouldBe` [expected]++        it "rejects spreads that form cycles" $+            let queryString = [r|+              {+                dog {+                  ...nameFragment+                }+              }+              fragment nameFragment on Dog {+                name+                ...barkVolumeFragment+              }+              fragment barkVolumeFragment on Dog {+                barkVolume+                ...nameFragment+              }+            |]+                error1 = Error+                    { message =+                        "Cannot spread fragment \"barkVolumeFragment\" within \+                        \itself (via barkVolumeFragment -> nameFragment -> \+                        \barkVolumeFragment)."+                    , locations = [AST.Location 11 15]+                    }+                error2 = Error+                    { message =+                        "Cannot spread fragment \"nameFragment\" within itself \+                        \(via nameFragment -> barkVolumeFragment -> \+                        \nameFragment)."+                    , locations = [AST.Location 7 15]+                    }+             in validate queryString `shouldBe` [error1, error2]++        it "rejects duplicate field arguments" $ do+            let queryString = [r|+              {+                dog {+                  isHousetrained(atOtherHomes: true, atOtherHomes: true)+                }+              }+            |]+                expected = Error+                    { message =+                        "There can be only one argument named \"atOtherHomes\"."+                    , locations = [AST.Location 4 34, AST.Location 4 54]+                    }+             in validate queryString `shouldBe` [expected]++        it "rejects more than one directive per location" $ do+            let queryString = [r|+              query ($foo: Boolean = true, $bar: Boolean = false) {+                dog @skip(if: $foo) @skip(if: $bar) {+                  name+                }+              }+            |]+                expected = Error+                    { message =+                        "There can be only one directive named \"skip\"."+                    , locations = [AST.Location 3 21, AST.Location 3 37]+                    }+             in validate queryString `shouldBe` [expected]++        it "rejects duplicate variables" $+            let queryString = [r|+              query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) {+                dog {+                  isHousetrained(atOtherHomes: $atOtherHomes)+                }+              }+            |]+                expected = Error+                    { message =+                        "There can be only one variable named \"atOtherHomes\"."+                    , locations = [AST.Location 2 39, AST.Location 2 63]+                    }+             in validate queryString `shouldBe` [expected]++        it "rejects non-input types as variables" $+            let queryString = [r|+              query takesDogBang($dog: Dog!) {+                dog {+                  isHousetrained(atOtherHomes: $dog)+                }+              }+            |]+                expected = Error+                    { message =+                        "Variable \"$dog\" cannot be non-input type \"Dog\"."+                    , locations = [AST.Location 2 34]+                    }+             in validate queryString `shouldBe` [expected]++        it "rejects undefined variables" $+            let queryString = [r|+              query variableIsNotDefinedUsedInSingleFragment {+                dog {+                  ...isHousetrainedFragment+                }+              }++              fragment isHousetrainedFragment on Dog {+                isHousetrained(atOtherHomes: $atOtherHomes)+              }+            |]+                expected = Error+                    { message =+                        "Variable \"$atOtherHomes\" is not defined by \+                        \operation \+                        \\"variableIsNotDefinedUsedInSingleFragment\"."+                    , locations = [AST.Location 9 46]+                    }+             in validate queryString `shouldBe` [expected]++        it "rejects unused variables" $+            let queryString = [r|+              query variableUnused($atOtherHomes: Boolean) {+                dog {+                  isHousetrained+                }+              }+            |]+                expected = Error+                    { message =+                        "Variable \"$atOtherHomes\" is never used in operation \+                        \\"variableUnused\"."+                    , locations = [AST.Location 2 36]+                    }+             in validate queryString `shouldBe` [expected]++        it "rejects duplicate fields in input objects" $+            let queryString = [r|+              {+                findDog(complex: { name: "Fido", name: "Jack" }) {+                  name+                }+              }+            |]+                expected = Error+                    { message =+                        "There can be only one input field named \"name\"."+                    , locations = [AST.Location 3 36, AST.Location 3 50]+                    }+             in validate queryString `shouldBe` [expected]++        it "rejects undefined fields" $+            let queryString = [r|+              {+                dog {+                  meowVolume+                }+              }+            |]+                expected = Error+                    { message =+                        "Cannot query field \"meowVolume\" on type \"Dog\"."+                    , locations = [AST.Location 4 19]+                    }+             in validate queryString `shouldBe` [expected]++        it "rejects scalar fields with not empty selection set" $+            let queryString = [r|+              {+                dog {+                  barkVolume {+                    sinceWhen+                  }+                }+              }+            |]+                expected = Error+                    { message =+                        "Field \"barkVolume\" must not have a selection since \+                        \type \"Int\" has no subfields."+                    , locations = [AST.Location 4 19]+                    }+             in validate queryString `shouldBe` [expected]++        it "rejects field arguments missing in the type" $+            let queryString = [r|+              {+                dog {+                  doesKnowCommand(command: CLEAN_UP_HOUSE, dogCommand: SIT)+                }+              }+            |]+                expected = Error+                    { message =+                        "Unknown argument \"command\" on field \+                        \\"Dog.doesKnowCommand\"."+                    , locations = [AST.Location 4 35]+                    }+             in validate queryString `shouldBe` [expected]++        it "rejects directive arguments missing in the definition" $+            let queryString = [r|+              {+                dog {+                  isHousetrained(atOtherHomes: true) @include(unless: false, if: true)+                }+              }+            |]+                expected = Error+                    { message =+                        "Unknown argument \"unless\" on directive \"@include\"."+                    , locations = [AST.Location 4 63]+                    }+             in validate queryString `shouldBe` [expected]++        it "rejects undefined directives" $+            let queryString = [r|+              {+                dog {+                  isHousetrained(atOtherHomes: true) @ignore(if: true)+                }+              }+            |]+                expected = Error+                    { message = "Unknown directive \"@ignore\"."+                    , locations = [AST.Location 4 54]+                    }+             in validate queryString `shouldBe` [expected]++        it "rejects undefined input object fields" $+            let queryString = [r|+              {+                findDog(complex: { favoriteCookieFlavor: "Bacon", name: "Jack" }) {+                  name+                }+              }+            |]+                expected = Error+                    { message =+                        "Field \"favoriteCookieFlavor\" is not defined \+                        \by type \"DogData\"."+                    , locations = [AST.Location 3 36]+                    }+             in validate queryString `shouldBe` [expected]++        it "rejects directives in invalid locations" $+            let queryString = [r|+              query @skip(if: $foo) {+                dog {+                  name+                }+              }+            |]+                expected = Error+                    { message = "Directive \"@skip\" may not be used on QUERY."+                    , locations = [AST.Location 2 21]+                    }+             in validate queryString `shouldBe` [expected]++        it "rejects missing required input fields" $+            let queryString = [r|+              {+                findDog(complex: { name: null }) {+                  name+                }+              }+            |]+                expected = Error+                    { message =+                        "Input field \"name\" of type \"DogData\" is required, \+                        \but it was not provided."+                    , locations = [AST.Location 3 34]+                    }+             in validate queryString `shouldBe` [expected]++        it "finds corresponding subscription fragment" $+            let queryString = [r|+              subscription sub {+                ...anotherSubscription+                ...multipleSubscriptions+              }+              fragment multipleSubscriptions on Subscription {+                newMessage {+                  body+                }+                disallowedSecondRootField {+                  sender+                }+              }+              fragment anotherSubscription on Subscription {+                newMessage {+                  body+                  sender+                }+              }+            |]+                expected = Error+                    { message =+                        "Subscription \"sub\" must select only one top level \+                        \field."+                    , locations = [AST.Location 2 15]+                    }+             in validate queryString `shouldBe` [expected]

@@ -19,8 +19,7 @@ import Text.RawString.QQ (r)  experimentalResolver :: Schema IO-experimentalResolver = Schema-    { query = queryType, mutation = Nothing, subscription = Nothing }+experimentalResolver = schema queryType Nothing Nothing mempty   where     queryType = Out.ObjectType "Query" Nothing []         $ HashMap.singleton "experimentalField"@@ -72,7 +71,7 @@                 ...experimentalFragment @skip(if: true)               } -              fragment experimentalFragment on ExperimentalType {+              fragment experimentalFragment on Query {                 experimentalField               }             |]@@ -83,7 +82,7 @@         it "should be able to @skip an inline fragment" $ do             let sourceQuery = [r|               {-                ... on ExperimentalType @skip(if: true) {+                ... on Query @skip(if: true) {                   experimentalField                 }               }

@@ -46,18 +46,15 @@ }|]  shirtType :: Out.ObjectType IO-shirtType = Out.ObjectType "Shirt" Nothing []-    $ HashMap.fromList-        [ ("size", sizeFieldType)-        , ("circumference", circumferenceFieldType)-        ]+shirtType = Out.ObjectType "Shirt" Nothing [] $ HashMap.fromList+    [ ("size", sizeFieldType)+    ]  hatType :: Out.ObjectType IO-hatType = Out.ObjectType "Hat" Nothing []-    $ HashMap.fromList-        [ ("size", sizeFieldType)-        , ("circumference", circumferenceFieldType)-        ]+hatType = Out.ObjectType "Hat" Nothing [] $ HashMap.fromList+    [ ("size", sizeFieldType)+    , ("circumference", circumferenceFieldType)+    ]  circumferenceFieldType :: Out.Resolver IO circumferenceFieldType@@ -70,12 +67,11 @@     $ pure $ snd size  toSchema :: Text -> (Text, Value) -> Schema IO-toSchema t (_, resolve) = Schema-    { query = queryType, mutation = Nothing, subscription = Nothing }+toSchema t (_, resolve) = schema queryType Nothing Nothing mempty   where-    unionMember = if t == "Hat" then hatType else shirtType+    garmentType = Out.UnionType "Garment" Nothing [hatType, shirtType]     typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty-    garmentField = Out.Field Nothing (Out.NamedObjectType unionMember) mempty+    garmentField = Out.Field Nothing (Out.NamedUnionType garmentType) mempty     queryType =         case t of             "circumference" -> hatType@@ -111,22 +107,16 @@          it "embeds inline fragments without type" $ do             let sourceQuery = [r|{-              garment {-                circumference-                ... {-                  size-                }+              circumference+              ... {+                size               }             }|]-                resolvers = ("garment", Object $ HashMap.fromList [circumference,  size])--            actual <- graphql (toSchema "garment" resolvers) sourceQuery+            actual <- graphql (toSchema "circumference" circumference) sourceQuery             let expected = HashMap.singleton "data"                     $ Aeson.object-                        [ "garment" .= Aeson.object-                            [ "circumference" .= (60 :: Int)-                            , "size" .= ("L" :: Text)-                            ]+                        [ "circumference" .= (60 :: Int)+                        , "size" .= ("L" :: Text)                         ]              in actual `shouldResolveTo` expected @@ -182,21 +172,6 @@                             ]                         ]              in actual `shouldResolveTo` expected--        it "rejects recursive fragments" $ do-            let expected = HashMap.singleton "data" $ Aeson.object []-                sourceQuery = [r|-              {-                ...circumferenceFragment-              }--              fragment circumferenceFragment on Hat {-                ...circumferenceFragment-              }-            |]--            actual <- graphql (toSchema "circumference" circumference) sourceQuery-            actual `shouldResolveTo` expected          it "considers type condition" $ do             let sourceQuery = [r|

@@ -23,13 +23,11 @@     $ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)     $ pure $ Int 60 -schema :: Schema IO-schema = Schema-    { query = Out.ObjectType "Query" Nothing [] hatFieldResolver-    , mutation = Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver-    , subscription = Nothing-    }+garmentSchema :: Schema IO+garmentSchema = schema queryType (Just mutationType) Nothing mempty   where+    queryType = Out.ObjectType "Query" Nothing [] hatFieldResolver+    mutationType = Out.ObjectType "Mutation" Nothing [] incrementFieldResolver     garment = pure $ Object $ HashMap.fromList         [ ("circumference", Int 60)         ]@@ -57,7 +55,7 @@                             [ "circumference" .= (60 :: Int)                             ]                         ]-            actual <- graphql schema querySource+            actual <- graphql garmentSchema querySource             actual `shouldResolveTo` expected          it "chooses Mutation" $ do@@ -70,5 +68,5 @@                     $ object                         [ "incrementCircumference" .= (61 :: Int)                         ]-            actual <- graphql schema querySource+            actual <- graphql garmentSchema querySource             actual `shouldResolveTo` expected

@@ -1,204 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Test.StarWars.Data-    ( Character-    , StarWarsException(..)-    , appearsIn-    , artoo-    , getDroid-    , getDroid'-    , getEpisode-    , getFriends-    , getHero-    , getHuman-    , id_-    , homePlanet-    , name_-    , secretBackstory-    , typeName-    ) where--import Control.Monad.Catch (Exception(..), MonadThrow(..), SomeException)-import Control.Applicative (Alternative(..), liftA2)-import Data.Maybe (catMaybes)-import Data.Text (Text)-import Data.Typeable (cast)-import Language.GraphQL.Error-import Language.GraphQL.Type---- * Data--- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js---- ** Characters--type ID = Text--data CharCommon = CharCommon-  { _id_        :: ID-  , _name       :: Text-  , _friends    :: [ID]-  , _appearsIn  :: [Int]-  } deriving (Show)---data Human = Human-  { _humanChar  :: CharCommon-  , homePlanet :: Text-  }--data Droid = Droid-  { _droidChar       :: CharCommon-  , primaryFunction :: Text-  }--type Character = Either Droid Human--id_ :: Character -> ID-id_ (Left  x) = _id_ . _droidChar $ x-id_ (Right x) = _id_ . _humanChar $ x--name_ :: Character -> Text-name_ (Left  x) = _name . _droidChar $ x-name_ (Right x) = _name . _humanChar $ x--friends :: Character -> [ID]-friends (Left  x) = _friends . _droidChar $ x-friends (Right x) = _friends . _humanChar $ x--appearsIn :: Character -> [Int]-appearsIn (Left  x) = _appearsIn . _droidChar $ x-appearsIn (Right x) = _appearsIn . _humanChar $ x--data StarWarsException = SecretBackstory | InvalidArguments--instance Show StarWarsException where-    show SecretBackstory = "secretBackstory is secret."-    show InvalidArguments = "Invalid arguments."--instance Exception StarWarsException where-    toException = toException . ResolverException-    fromException e = do-        ResolverException resolverException <- fromException e-        cast resolverException--secretBackstory :: Resolve (Either SomeException)-secretBackstory = throwM SecretBackstory--typeName :: Character -> Text-typeName = either (const "Droid") (const "Human")--luke :: Character-luke = Right luke'--luke' :: Human-luke' = Human-  { _humanChar = CharCommon-      { _id_        = "1000"-      , _name       = "Luke Skywalker"-      , _friends    = ["1002","1003","2000","2001"]-      , _appearsIn  = [4,5,6]-      }-  , homePlanet = "Tatooine"-  }--vader :: Human-vader = Human-  { _humanChar = CharCommon-      { _id_        = "1001"-      , _name       = "Darth Vader"-      , _friends    = ["1004"]-      , _appearsIn  = [4,5,6]-      }-  , homePlanet = "Tatooine"-  }--han :: Human-han = Human-  { _humanChar = CharCommon-      { _id_        = "1002"-      , _name       = "Han Solo"-      , _friends    = ["1000","1003","2001" ]-      , _appearsIn  = [4,5,6]-      }-  , homePlanet = mempty-  }--leia :: Human-leia = Human-  { _humanChar = CharCommon-      { _id_        = "1003"-      , _name       = "Leia Organa"-      , _friends    = ["1000","1002","2000","2001"]-      , _appearsIn  = [4,5,6]-      }-  , homePlanet = "Alderaan"-  }--tarkin :: Human-tarkin = Human-  { _humanChar = CharCommon-    { _id_        = "1004"-    , _name       = "Wilhuff Tarkin"-    , _friends    = ["1001"]-    , _appearsIn  = [4]-    }-  , homePlanet = mempty-  }--threepio :: Droid-threepio = Droid-  { _droidChar = CharCommon-      { _id_ = "2000"-      , _name = "C-3PO"-      , _friends = ["1000","1002","1003","2001" ]-      , _appearsIn = [ 4, 5, 6 ]-      }-  , primaryFunction = "Protocol"-  }--artoo :: Character-artoo = Left artoo'--artoo' :: Droid-artoo' = Droid-  { _droidChar = CharCommon-      { _id_        = "2001"-      , _name       = "R2-D2"-      , _friends    = ["1000","1002","1003"]-      , _appearsIn  = [4,5,6]-      }-  , primaryFunction = "Astrometch"-  }---- ** Helper functions--getHero :: Int -> Character-getHero 5 = luke-getHero _ = artoo--getHuman :: ID -> Maybe Character-getHuman = fmap Right . getHuman'--getHuman' :: ID -> Maybe Human-getHuman' "1000" = pure luke'-getHuman' "1001" = pure vader-getHuman' "1002" = pure han-getHuman' "1003" = pure leia-getHuman' "1004" = pure tarkin-getHuman' _      = empty--getDroid :: ID -> Maybe Character-getDroid = fmap Left . getDroid'--getDroid' :: ID -> Maybe Droid-getDroid' "2000" = pure threepio-getDroid' "2001" = pure artoo'-getDroid' _      = empty--getFriends :: Character -> [Character]-getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char--getEpisode :: Int -> Maybe Text-getEpisode 4 = pure "NEW_HOPE"-getEpisode 5 = pure "EMPIRE"-getEpisode 6 = pure "JEDI"-getEpisode _ = empty

@@ -1,366 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-module Test.StarWars.QuerySpec-    ( spec-    ) where--import qualified Data.Aeson as Aeson-import Data.Aeson ((.=))-import qualified Data.HashMap.Strict as HashMap-import Data.Text (Text)-import Language.GraphQL-import Text.RawString.QQ (r)-import Test.Hspec.Expectations (Expectation, shouldBe)-import Test.Hspec (Spec, describe, it)-import Test.StarWars.Schema---- * Test--- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsQueryTests.js--spec :: Spec-spec = describe "Star Wars Query Tests" $ do-    describe "Basic Queries" $ do-      it "R2-D2 hero" $ testQuery-        [r| query HeroNameQuery {-            hero {-                id-            }-            }-        |]-        $ Aeson.object-            [ "data" .= Aeson.object-                [ "hero" .= Aeson.object ["id" .= ("2001" :: Text)]-                ]-            ]-      it "R2-D2 ID and friends" $ testQuery-        [r| query HeroNameAndFriendsQuery {-            hero {-                id-                name-                friends {-                  name-                }-            }-            }-        |]-        $ Aeson.object [ "data" .= Aeson.object [-            "hero" .= Aeson.object-                [ "id" .= ("2001" :: Text)-                , r2d2Name-                , "friends" .=-                    [ Aeson.object [lukeName]-                    , Aeson.object [hanName]-                    , Aeson.object [leiaName]-                    ]-                ]-        ]]--    describe "Nested Queries" $ do-      it "R2-D2 friends" $ testQuery-        [r| query NestedQuery {-              hero {-                name-                friends {-                  name-                  appearsIn-                  friends {-                    name-                  }-                }-              }-            }-        |]-        $ Aeson.object [ "data" .= Aeson.object [-          "hero" .= Aeson.object [-              "name" .= ("R2-D2" :: Text)-            , "friends" .= [-                  Aeson.object [-                      "name" .= ("Luke Skywalker" :: Text)-                    , "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]-                    , "friends" .= [-                          Aeson.object [hanName]-                        , Aeson.object [leiaName]-                        , Aeson.object [c3poName]-                        , Aeson.object [r2d2Name]-                        ]-                    ]-                , Aeson.object [-                      hanName-                    , "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]-                    , "friends" .=-                        [ Aeson.object [lukeName]-                        , Aeson.object [leiaName]-                        , Aeson.object [r2d2Name]-                        ]-                    ]-                , Aeson.object [-                      leiaName-                    , "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]-                    , "friends" .=-                        [ Aeson.object [lukeName]-                        , Aeson.object [hanName]-                        , Aeson.object [c3poName]-                        , Aeson.object [r2d2Name]-                        ]-                    ]-                ]-            ]-        ]]-      it "Luke ID" $ testQuery-        [r| query FetchLukeQuery {-              human(id: "1000") {-                name-              }-            }-        |]-        $ Aeson.object [ "data" .= Aeson.object-            [ "human" .= Aeson.object [lukeName]-            ]]--    it "Luke ID with variable" $ testQueryParams-      (HashMap.singleton "someId" "1000")-      [r| query FetchSomeIDQuery($someId: String!) {-            human(id: $someId) {-              name-            }-          }-      |]-      $ Aeson.object [ "data" .= Aeson.object [-        "human" .= Aeson.object [lukeName]-      ]]-    it "Han ID with variable" $ testQueryParams-      (HashMap.singleton "someId" "1002")-      [r| query FetchSomeIDQuery($someId: String!) {-            human(id: $someId) {-              name-            }-          }-      |]-      $ Aeson.object [ "data" .= Aeson.object [-        "human" .= Aeson.object [hanName]-      ]]-    it "Invalid ID" $ testQueryParams-      (HashMap.singleton "id" "Not a valid ID")-      [r| query humanQuery($id: String!) {-            human(id: $id) {-              name-            }-          }-      |] $ Aeson.object ["data" .= Aeson.object ["human" .= Aeson.Null]]-    it "Luke aliased" $ testQuery-      [r| query FetchLukeAliased {-            luke: human(id: "1000") {-              name-            }-          }-      |]-      $ Aeson.object [ "data" .= Aeson.object [-       "luke" .= Aeson.object [lukeName]-      ]]-    it "R2-D2 ID and friends aliased" $ testQuery-      [r| query HeroNameAndFriendsQuery {-            hero {-              id-              name-              friends {-                friendName: name-              }-            }-          }-      |]-      $ Aeson.object [ "data" .= Aeson.object [-        "hero" .= Aeson.object [-            "id" .= ("2001" :: Text)-          , r2d2Name-          , "friends" .=-              [ Aeson.object ["friendName" .= ("Luke Skywalker" :: Text)]-              , Aeson.object ["friendName" .= ("Han Solo" :: Text)]-              , Aeson.object ["friendName" .= ("Leia Organa" :: Text)]-              ]-          ]-      ]]-    it "Luke and Leia aliased" $ testQuery-      [r| query FetchLukeAndLeiaAliased {-            luke: human(id: "1000") {-              name-            }-            leia: human(id: "1003") {-              name-            }-          }-      |]-      $ Aeson.object [ "data" .= Aeson.object-        [ "luke" .= Aeson.object [lukeName]-        , "leia" .= Aeson.object [leiaName]-      ]]--    describe "Fragments for complex queries" $ do-      it "Aliases to query for duplicate content" $ testQuery-        [r| query DuplicateFields {-              luke: human(id: "1000") {-                name-                homePlanet-              }-              leia: human(id: "1003") {-                name-                homePlanet-              }-            }-        |]-        $ Aeson.object [ "data" .= Aeson.object [-          "luke" .= Aeson.object [lukeName, tatooine]-        , "leia" .= Aeson.object [leiaName, alderaan]-        ]]-      it "Fragment for duplicate content" $ testQuery-        [r|  query UseFragment {-              luke: human(id: "1000") {-                ...HumanFragment-              }-              leia: human(id: "1003") {-                ...HumanFragment-              }-            }-            fragment HumanFragment on Human {-              name-              homePlanet-            }-        |]-        $ Aeson.object [ "data" .= Aeson.object [-          "luke" .= Aeson.object [lukeName, tatooine]-        , "leia" .= Aeson.object [leiaName, alderaan]-        ]]--    describe "__typename" $ do-      it "R2D2 is a Droid" $ testQuery-        [r| query CheckTypeOfR2 {-              hero {-                __typename-                name-              }-            }-          |]-        $ Aeson.object ["data" .= Aeson.object [-            "hero" .= Aeson.object-                [ "__typename" .= ("Droid" :: Text)-                , r2d2Name-                ]-        ]]-      it "Luke is a human" $ testQuery-        [r| query CheckTypeOfLuke {-              hero(episode: EMPIRE) {-                __typename-                name-              }-            }-          |]-        $ Aeson.object ["data" .= Aeson.object [-            "hero" .= Aeson.object-                [ "__typename" .= ("Human" :: Text)-                , lukeName-                ]-        ]]--    describe "Errors in resolvers" $ do-        it "error on secretBackstory" $ testQuery-          [r|-            query HeroNameQuery {-              hero {-                name-                  secretBackstory-              }-            }-          |]-          $ Aeson.object-              [ "data" .= Aeson.object-                  [ "hero" .= Aeson.object-                      [ "name" .= ("R2-D2" :: Text)-                      , "secretBackstory" .= Aeson.Null-                      ]-                  ]-              , "errors" .=-                  [ Aeson.object-                      ["message" .= ("secretBackstory is secret." :: Text)]-                  ]-              ]-        it "Error in a list" $ testQuery-          [r| query HeroNameQuery {-                hero {-                  name-                  friends {-                    name-                    secretBackstory-                  }-                }-              }-            |]-          $ Aeson.object ["data" .= Aeson.object-            [ "hero" .= Aeson.object-                [ "name" .= ("R2-D2" :: Text)-                , "friends" .=-                    [ Aeson.object-                        [ "name" .= ("Luke Skywalker" :: Text)-                        , "secretBackstory" .= Aeson.Null-                        ]-                    , Aeson.object-                        [ "name" .= ("Han Solo" :: Text)-                        , "secretBackstory" .= Aeson.Null-                        ]-                    , Aeson.object-                        [ "name" .= ("Leia Organa" :: Text)-                        , "secretBackstory" .= Aeson.Null-                        ]-                    ]-                ]-            ]-            , "errors" .=-                [ Aeson.object-                    [ "message" .= ("secretBackstory is secret." :: Text)-                    ]-                , Aeson.object-                    [ "message" .= ("secretBackstory is secret." :: Text)-                    ]-                , Aeson.object-                    [ "message" .= ("secretBackstory is secret." :: Text)-                    ]-                ]-            ]-        it "error on secretBackstory with alias" $ testQuery-          [r| query HeroNameQuery {-                mainHero: hero {-                  name-                  story: secretBackstory-                }-              }-            |]-          $ Aeson.object-              [ "data" .= Aeson.object-                  [ "mainHero" .= Aeson.object-                      [ "name" .= ("R2-D2" :: Text)-                      , "story" .= Aeson.Null-                      ]-                  ]-              , "errors" .=-                  [ Aeson.object-                    [ "message" .= ("secretBackstory is secret." :: Text)-                    ]-                  ]-              ]--  where-    lukeName = "name" .= ("Luke Skywalker" :: Text)-    leiaName = "name" .= ("Leia Organa" :: Text)-    hanName = "name" .= ("Han Solo" :: Text)-    r2d2Name = "name" .= ("R2-D2" :: Text)-    c3poName = "name" .= ("C-3PO" :: Text)-    tatooine = "homePlanet" .= ("Tatooine" :: Text)-    alderaan = "homePlanet" .= ("Alderaan" :: Text)--testQuery :: Text -> Aeson.Value -> Expectation-testQuery q expected =-    let Right (Right actual) = graphql schema q-     in Aeson.Object actual `shouldBe` expected--testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation-testQueryParams f q expected =-    let Right (Right actual) = graphqlSubs schema Nothing f q-     in Aeson.Object actual `shouldBe` expected

@@ -1,154 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Test.StarWars.Schema-    ( schema-    ) where--import Control.Monad.Catch (MonadThrow(..), SomeException)-import Control.Monad.Trans.Reader (asks)-import qualified Data.HashMap.Strict as HashMap-import Data.Maybe (catMaybes)-import Data.Text (Text)-import Language.GraphQL.Type-import qualified Language.GraphQL.Type.In as In-import qualified Language.GraphQL.Type.Out as Out-import Test.StarWars.Data-import Prelude hiding (id)---- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js--schema :: Schema (Either SomeException)-schema = Schema-    { query = queryType-    , mutation = Nothing-    , subscription = Nothing-    }-  where-    queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList-        [ ("hero", heroFieldResolver)-        , ("human", humanFieldResolver)-        , ("droid", droidFieldResolver)-        ]-    heroField = Out.Field Nothing (Out.NamedObjectType heroObject)-        $ HashMap.singleton "episode"-        $ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing-    heroFieldResolver = ValueResolver heroField hero-    humanField = Out.Field Nothing (Out.NamedObjectType heroObject)-        $ HashMap.singleton "id"-        $ In.Argument Nothing (In.NonNullScalarType string) Nothing-    humanFieldResolver = ValueResolver humanField human-    droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty-    droidFieldResolver = ValueResolver droidField droid--heroObject :: Out.ObjectType (Either SomeException)-heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList-    [ ("id", idFieldType)-    , ("name", nameFieldType)-    , ("friends", friendsFieldType)-    , ("appearsIn", appearsInField)-    , ("homePlanet", homePlanetFieldType)-    , ("secretBackstory", secretBackstoryFieldType)-    , ("__typename", typenameFieldType)-    ]-  where-    homePlanetFieldType-      = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)-      $ idField "homePlanet"--droidObject :: Out.ObjectType (Either SomeException)-droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList-    [ ("id", idFieldType)-    , ("name", nameFieldType)-    , ("friends", friendsFieldType)-    , ("appearsIn", appearsInField)-    , ("primaryFunction", primaryFunctionFieldType)-    , ("secretBackstory", secretBackstoryFieldType)-    , ("__typename", typenameFieldType)-    ]-  where-    primaryFunctionFieldType-        = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)-        $ idField "primaryFunction"--typenameFieldType :: Resolver (Either SomeException)-typenameFieldType-    = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)-    $ idField "__typename"--idFieldType :: Resolver (Either SomeException)-idFieldType-    = ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)-    $ idField "id"--nameFieldType :: Resolver (Either SomeException)-nameFieldType-    = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)-    $ idField "name"--friendsFieldType :: Resolver (Either SomeException)-friendsFieldType-    = ValueResolver (Out.Field Nothing fieldType mempty)-    $ idField "friends"-  where-    fieldType = Out.ListType $ Out.NamedObjectType droidObject--appearsInField :: Resolver (Either SomeException)-appearsInField-    = ValueResolver (Out.Field (Just description) fieldType mempty)-    $ idField "appearsIn"-  where-    fieldType = Out.ListType $ Out.NamedEnumType episodeEnum-    description = "Which movies they appear in."--secretBackstoryFieldType :: Resolver (Either SomeException)-secretBackstoryFieldType = ValueResolver field secretBackstory-  where-    field = Out.Field Nothing (Out.NamedScalarType string) mempty--idField :: Text -> Resolve (Either SomeException)-idField f = do-    v <- asks values-    let (Object v') = v-    pure $ v' HashMap.! f--episodeEnum :: EnumType-episodeEnum = EnumType "Episode" (Just description)-    $ HashMap.fromList [newHope, empire, jedi]-  where-    description = "One of the films in the Star Wars Trilogy"-    newHope = ("NEW_HOPE", EnumValue $ Just "Released in 1977.")-    empire = ("EMPIRE", EnumValue $ Just "Released in 1980.")-    jedi = ("JEDI", EnumValue $ Just "Released in 1983.")--hero :: Resolve (Either SomeException)-hero = do-  episode <- argument "episode"-  pure $ character $ case episode of-      Enum "NEW_HOPE" -> getHero 4-      Enum "EMPIRE" -> getHero 5-      Enum "JEDI" -> getHero 6-      _ -> artoo--human :: Resolve (Either SomeException)-human = do-    id' <- argument "id"-    case id' of-        String i -> pure $ maybe Null character $ getHuman i >>= Just-        _ -> throwM InvalidArguments--droid :: Resolve (Either SomeException)-droid = do-    id' <- argument "id"-    case id' of-        String i -> pure $ maybe Null character $ getDroid i >>= Just-        _ -> throwM InvalidArguments--character :: Character -> Value-character char = Object $ HashMap.fromList-    [ ("id", String $ id_ char)-    , ("name", String $ name_ char)-    , ("friends", List $ character <$> getFriends char)-    , ("appearsIn", List $ Enum <$> catMaybes (getEpisode <$> appearsIn char))-    , ("homePlanet", String $ either mempty homePlanet char)-    , ("__typename", String $ typeName char)-    ]