├── ci ├── 9.0.2 │ ├── ci.project │ ├── ci.project.local │ └── ci.project.freeze ├── 9.2.2 │ ├── ci.project │ ├── ci.project.local │ └── ci.project.freeze └── 8.10.7 │ ├── ci.project │ ├── weeder.project │ ├── ci.project.local │ ├── weeder.project.local │ ├── ci.project.freeze │ └── weeder.project.freeze ├── .envrc ├── shell.nix ├── .gitignore ├── weeder.dhall ├── src └── Language │ └── GraphQL │ └── Draft │ ├── Syntax │ ├── Name.hs-boot │ ├── Internal.hs │ ├── QQ.hs │ └── Name.hs │ ├── Syntax.hs-boot │ ├── Printer.hs-boot │ ├── Parser.hs-boot │ ├── Generator.hs │ ├── Printer.hs │ ├── Parser.hs │ └── Syntax.hs ├── cabal.project ├── .github └── workflows │ ├── format.yml │ ├── lint.yml │ ├── ci.yml │ └── weeder.yml ├── README.md ├── flake.lock ├── LICENSE ├── flake.nix ├── Makefile ├── bench └── Benchmark.hs ├── test ├── BlockStrings.hs ├── Spec.hs └── Keywords.hs └── graphql-parser.cabal /ci/9.0.2/ci.project: -------------------------------------------------------------------------------- 1 | ../../cabal.project -------------------------------------------------------------------------------- /ci/9.2.2/ci.project: -------------------------------------------------------------------------------- 1 | ../../cabal.project -------------------------------------------------------------------------------- /ci/8.10.7/ci.project: -------------------------------------------------------------------------------- 1 | ../../cabal.project -------------------------------------------------------------------------------- /ci/8.10.7/weeder.project: -------------------------------------------------------------------------------- 1 | ../../cabal.project -------------------------------------------------------------------------------- /.envrc: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | source_env_if_exists .envrc.local 4 | -------------------------------------------------------------------------------- /ci/9.0.2/ci.project.local: -------------------------------------------------------------------------------- 1 | with-compiler: ghc-9.0.2 2 | 3 | package graphql-parser 4 | ghc-options: -Werror 5 | -------------------------------------------------------------------------------- /ci/9.2.2/ci.project.local: -------------------------------------------------------------------------------- 1 | with-compiler: ghc-9.2.2 2 | 3 | package graphql-parser 4 | ghc-options: -Werror 5 | -------------------------------------------------------------------------------- /ci/8.10.7/ci.project.local: -------------------------------------------------------------------------------- 1 | with-compiler: ghc-8.10.7 2 | 3 | package graphql-parser 4 | ghc-options: -Werror 5 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { system ? builtins.currentSystem }: 2 | 3 | (builtins.getFlake (toString ./.)).devShells.${system} 4 | -------------------------------------------------------------------------------- /ci/8.10.7/weeder.project.local: -------------------------------------------------------------------------------- 1 | with-compiler: ghc-8.10.7 2 | 3 | allow-newer: 4 | weeder:optparse-applicative 5 | 6 | package * 7 | optimization: 0 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Haskell 2 | /dist-newstyle 3 | cabal.project.local 4 | 5 | # direnv 6 | /.direnv 7 | /.envrc.local 8 | 9 | # Nix 10 | /result 11 | /result-* 12 | -------------------------------------------------------------------------------- /weeder.dhall: -------------------------------------------------------------------------------- 1 | { roots = 2 | [ "Language.GraphQL.Draft.Generator" 3 | , "Language.GraphQL.Draft.Parser" 4 | , "Language.GraphQL.Draft.Printer" 5 | , "Language.GraphQL.Draft.Syntax" 6 | ] 7 | , type-class-roots = False 8 | } 9 | -------------------------------------------------------------------------------- /src/Language/GraphQL/Draft/Syntax/Name.hs-boot: -------------------------------------------------------------------------------- 1 | module Language.GraphQL.Draft.Syntax.Name (Name) where 2 | 3 | import Data.Kind (Type) 4 | 5 | ------------------------------------------------------------------------------- 6 | 7 | type Name :: Type 8 | data Name 9 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./ 2 | 3 | package * 4 | optimization: 2 5 | 6 | ghc-options: -fwrite-ide-info 7 | 8 | haddock-html: true 9 | haddock-hoogle: true 10 | haddock-hyperlink-source: true 11 | haddock-quickjump: true 12 | 13 | package graphql-parser 14 | ghc-options: -j 15 | -------------------------------------------------------------------------------- /.github/workflows/format.yml: -------------------------------------------------------------------------------- 1 | name: Check formatting 2 | 3 | on: 4 | push: { branches: [ main ] } 5 | pull_request: { branches: [ main ] } 6 | 7 | jobs: 8 | ormolu: 9 | runs-on: ubuntu-latest 10 | steps: 11 | - uses: actions/checkout@v2 12 | - uses: mrkkrp/ormolu-action@v4 13 | -------------------------------------------------------------------------------- /src/Language/GraphQL/Draft/Syntax.hs-boot: -------------------------------------------------------------------------------- 1 | module Language.GraphQL.Draft.Syntax 2 | ( ExecutableDocument, 3 | SchemaDocument, 4 | ) 5 | where 6 | 7 | import Data.Kind (Type) 8 | 9 | ------------------------------------------------------------------------------- 10 | 11 | type role ExecutableDocument nominal 12 | 13 | type ExecutableDocument :: Type -> Type 14 | data ExecutableDocument var 15 | 16 | type SchemaDocument :: Type 17 | data SchemaDocument 18 | -------------------------------------------------------------------------------- /src/Language/GraphQL/Draft/Printer.hs-boot: -------------------------------------------------------------------------------- 1 | module Language.GraphQL.Draft.Printer 2 | ( renderExecutableDoc, 3 | ) 4 | where 5 | 6 | ------------------------------------------------------------------------------- 7 | 8 | import Data.Text (Text) 9 | import {-# SOURCE #-} Language.GraphQL.Draft.Syntax (ExecutableDocument) 10 | import Language.GraphQL.Draft.Syntax.Name (Name) 11 | 12 | ------------------------------------------------------------------------------- 13 | 14 | renderExecutableDoc :: ExecutableDocument Name -> Text 15 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # graphql-parser 2 | 3 | [![build status](https://img.shields.io/github/workflow/status/hasura/graphql-parser-hs/ci/main?label=build%20status&logo=github&style=flat-square)](https://github.com/hasura/graphql-parser-hs/actions?query=workflow%3Aci+branch%3Amain) 4 | 5 | A GraphQL parsing library for Haskell. Used at Hasura in various production 6 | projects. 7 | 8 | The code for this library has now moved to another git repository, and can be 9 | found in the 10 | [graphql-engine](https://github.com/hasura/graphql-engine/tree/master/server/lib/graphql-parser-hs) repository. 11 | 12 | -------------------------------------------------------------------------------- /src/Language/GraphQL/Draft/Parser.hs-boot: -------------------------------------------------------------------------------- 1 | module Language.GraphQL.Draft.Parser 2 | ( parseExecutableDoc, 3 | parseSchemaDocument, 4 | ) 5 | where 6 | 7 | ------------------------------------------------------------------------------- 8 | 9 | import Data.Text (Text) 10 | import {-# SOURCE #-} Language.GraphQL.Draft.Syntax qualified as AST 11 | import Language.GraphQL.Draft.Syntax.Name (Name) 12 | import Prelude (Either) 13 | 14 | ------------------------------------------------------------------------------- 15 | 16 | parseExecutableDoc :: Text -> Either Text (AST.ExecutableDocument Name) 17 | parseSchemaDocument :: Text -> Either Text AST.SchemaDocument 18 | -------------------------------------------------------------------------------- /.github/workflows/lint.yml: -------------------------------------------------------------------------------- 1 | name: lint 2 | 3 | on: 4 | push: { branches: [ "main" ] } 5 | pull_request: { branches: [ "main" ] } 6 | 7 | jobs: 8 | lint: 9 | runs-on: ubuntu-latest 10 | 11 | steps: 12 | - name: Checkout this repository. 13 | uses: actions/checkout@v3 14 | 15 | - name: Set up hlint. 16 | uses: haskell/actions/hlint-setup@v2 17 | with: { version: 3.4 } 18 | 19 | - name: Run hlint 20 | uses: haskell/actions/hlint-run@v2 21 | with: 22 | # NOTE: This _must_ be a stringified array, not an _actual_ array. 23 | path: '[ "bench/", "src/", "test/" ]' 24 | fail-on: warning 25 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "locked": { 5 | "lastModified": 1656928814, 6 | "narHash": "sha256-RIFfgBuKz6Hp89yRr7+NR5tzIAbn52h8vT6vXkYjZoM=", 7 | "owner": "numtide", 8 | "repo": "flake-utils", 9 | "rev": "7e2a3b3dfd9af950a856d66b0a7d01e3c18aa249", 10 | "type": "github" 11 | }, 12 | "original": { 13 | "owner": "numtide", 14 | "repo": "flake-utils", 15 | "type": "github" 16 | } 17 | }, 18 | "nixpkgs": { 19 | "locked": { 20 | "lastModified": 1656754140, 21 | "narHash": "sha256-8thJUtZWIimyBtkYQ0tdmmnH0yJvOaw1K5W3OgKc6/A=", 22 | "owner": "NixOS", 23 | "repo": "nixpkgs", 24 | "rev": "09c32b0bda4db98d6454e910206188e85d5b04cc", 25 | "type": "github" 26 | }, 27 | "original": { 28 | "owner": "NixOS", 29 | "ref": "nixos-22.05", 30 | "repo": "nixpkgs", 31 | "type": "github" 32 | } 33 | }, 34 | "root": { 35 | "inputs": { 36 | "flake-utils": "flake-utils", 37 | "nixpkgs": "nixpkgs" 38 | } 39 | } 40 | }, 41 | "root": "root", 42 | "version": 7 43 | } 44 | -------------------------------------------------------------------------------- /src/Language/GraphQL/Draft/Syntax/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} 4 | 5 | -- | Internal GraphQL AST functionality. 6 | -- 7 | -- This module is primarily necessary due to an incorrect 8 | -- @-Wredundant-constraints@ warning emitted by GHC when compiling 9 | -- 'liftTypedHashMap'. 10 | module Language.GraphQL.Draft.Syntax.Internal 11 | ( liftTypedHashMap, 12 | ) 13 | where 14 | 15 | ------------------------------------------------------------------------------- 16 | 17 | import Data.HashMap.Strict (HashMap) 18 | import Data.HashMap.Strict qualified as HashMap 19 | import Data.Hashable (Hashable) 20 | import Language.Haskell.TH.Syntax (Lift, liftTyped) 21 | import Language.Haskell.TH.Syntax qualified as TH 22 | import Prelude 23 | 24 | ------------------------------------------------------------------------------- 25 | 26 | -- | Lift a 'HashMap' into a Template Haskell splice via list conversion. 27 | #if MIN_VERSION_template_haskell(2,17,0) 28 | liftTypedHashMap :: 29 | ( Eq k, 30 | Hashable k, 31 | Lift k, 32 | Lift v, 33 | TH.Quote m 34 | ) => 35 | HashMap k v -> 36 | TH.Code m (HashMap k v) 37 | #else 38 | liftTypedHashMap :: 39 | ( Eq k, 40 | Hashable k, 41 | Lift k, 42 | Lift v 43 | ) => 44 | HashMap k v -> 45 | TH.Q (TH.TExp (HashMap k v)) 46 | #endif 47 | liftTypedHashMap hm = 48 | [||HashMap.fromList $$(liftTyped $ HashMap.toList hm)||] 49 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2018–2020 Hasura Inc., 2015 J. Daniel Navarro 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of J. Daniel Navarro nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | # To automatically load this flake into your shell: 2 | # 1. Set up direnv and nix-direnv. 3 | # 2. Create a file named ".envrc.local", with the contents `use flake`. 4 | 5 | { 6 | description = "Hasura GraphQL Engine"; 7 | 8 | inputs = { 9 | nixpkgs = { 10 | url = github:NixOS/nixpkgs/nixos-22.05; 11 | }; 12 | 13 | flake-utils = { 14 | url = github:numtide/flake-utils; 15 | }; 16 | }; 17 | 18 | outputs = 19 | { self 20 | , nixpkgs 21 | , flake-utils 22 | }: 23 | let 24 | ghcVersion = "8.10.7"; 25 | ghcName = "ghc${builtins.replaceStrings ["."] [""] ghcVersion}"; 26 | in 27 | flake-utils.lib.eachDefaultSystem (system: 28 | let 29 | pkgs = import nixpkgs { 30 | inherit system; 31 | }; 32 | haskellCompiler = pkgs.haskell.compiler."${ghcName}"; 33 | haskellPackages = pkgs.haskell.packages."${ghcName}"; 34 | in 35 | { 36 | packages.default = (haskellPackages.callCabal2nix "graphql-parser" ./. { }).overrideScope ( 37 | self: super: { 38 | hedgehog = self.hedgehog_1_1_1; 39 | } 40 | ); 41 | 42 | pkgs.formatter = nixpkgs.legacyPackages."${system}".nixpkgs-fmt; 43 | 44 | devShells.default = pkgs.mkShell { 45 | name = "graphql-parser-hs"; 46 | 47 | # We list top-level packages before packages scoped to the GHC version, so 48 | # that they appear first in the PATH. Otherwise we might end up with older 49 | # versions of transitive dependencies (e.g. HLS depending on Ormolu). 50 | buildInputs = [ 51 | pkgs.cabal-install 52 | pkgs.hlint 53 | pkgs.ormolu 54 | haskellCompiler 55 | haskellPackages.ghcid 56 | haskellPackages.haskell-language-server 57 | ]; 58 | }; 59 | } 60 | ); 61 | } 62 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: ci 2 | 3 | on: 4 | push: { branches: [ "main" ] } 5 | pull_request: { branches: [ "main" ] } 6 | 7 | jobs: 8 | ci: 9 | runs-on: ubuntu-latest 10 | env: 11 | # TODO: We should add CI-specific build, test, etc. actions to the 12 | # 'Makefile' rather than relying on an environment variable. 13 | CABAL: cabal --project-file=./ci/ci.project 14 | strategy: 15 | matrix: 16 | ghc: [ "8.10.7", "9.0.2", "9.2.2" ] 17 | cabal: [ "latest" ] 18 | 19 | steps: 20 | - name: Checkout this repository. 21 | uses: actions/checkout@v2 22 | 23 | - name: Set up Haskell tooling. 24 | uses: haskell/actions/setup@v1 25 | id: set-up-haskell-tooling 26 | with: 27 | ghc-version: ${{ matrix.ghc }} 28 | cabal-version: ${{ matrix.cabal }} 29 | 30 | - name: Cache compiled dependency artifacts. 31 | uses: actions/cache@v3 32 | with: 33 | path: | 34 | ${{ steps.set-up-haskell-tooling.outputs.cabal-store }} 35 | key: ${{ runner.os }}-cabal-${{ matrix.ghc }}-${{ hashFiles('./ci/${{ matrix.ghc }}/ci.project.freeze') }}-0 36 | restore-keys: | 37 | ${{ runner.os }}-cabal-${{ matrix.ghc }}-${{ hashFiles('./ci/${{ matrix.ghc }}/ci.project.freeze') }}-0 38 | 39 | - name: Compile dependencies. 40 | run: | 41 | make update \ 42 | PROJECT='ci/${{ matrix.ghc }}/ci.project' 43 | make build-deps \ 44 | PROJECT='ci/${{ matrix.ghc }}/ci.project' 45 | 46 | - name: Compile library, tests, and benchmarks. 47 | run: | 48 | make build-all \ 49 | PROJECT='ci/${{ matrix.ghc }}/ci.project' 50 | 51 | - name: Run tests. 52 | run: | 53 | make test-all \ 54 | PROJECT='ci/${{ matrix.ghc }}/ci.project' 55 | 56 | - name: Run benchmarks. 57 | run: | 58 | make bench-all \ 59 | PROJECT='ci/${{ matrix.ghc }}/ci.project' 60 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: format 2 | format: 3 | cabal-fmt -i graphql-parser.cabal 4 | find src test bench \ 5 | -type f \( -name "*.hs" -o -name "*.hs-boot" \) | \ 6 | xargs ormolu -ie 7 | 8 | PROJECT ?= cabal.project 9 | CABAL = cabal --project=$(PROJECT) 10 | 11 | .PHONY: freeze 12 | freeze: 13 | $(CABAL) freeze \ 14 | --enable-tests \ 15 | --enable-benchmarks 16 | 17 | .PHONY: configure 18 | configure: 19 | $(CABAL) configure \ 20 | --enable-tests \ 21 | --enable-benchmarks 22 | 23 | .PHONY: update 24 | update: 25 | $(CABAL) update 26 | 27 | .PHONY: build-deps 28 | build-deps: 29 | $(CABAL) build \ 30 | --only-dependencies \ 31 | --enable-tests \ 32 | --enable-benchmarks \ 33 | all 34 | 35 | .PHONY: build 36 | build: 37 | $(CABAL) build \ 38 | --enable-tests \ 39 | --enable-benchmarks \ 40 | graphql-parser 41 | 42 | .PHONY: build-all 43 | build-all: 44 | $(CABAL) build \ 45 | --enable-tests \ 46 | --enable-benchmarks \ 47 | all 48 | 49 | .PHONY: test-all 50 | test-all: 51 | $(CABAL) test \ 52 | --enable-tests \ 53 | --enable-benchmarks \ 54 | all 55 | 56 | .PHONY: bench-all 57 | bench-all: 58 | $(CABAL) bench \ 59 | --enable-tests \ 60 | --enable-benchmarks \ 61 | all 62 | 63 | .PHONY: repl 64 | repl: 65 | $(CABAL) repl \ 66 | --repl-option='-fobject-code' \ 67 | --repl-option='-O0' \ 68 | graphql-parser 69 | 70 | .PHONY: ghcid 71 | ghcid: 72 | ghcid --command "\ 73 | $(CABAL) repl \ 74 | --repl-option='-fobject-code' \ 75 | --repl-option='-O0' \ 76 | graphql-parser \ 77 | " 78 | 79 | .PHONY: ghcid-test 80 | ghcid-test: 81 | ghcid \ 82 | --command "\ 83 | $(CABAL) repl \ 84 | --repl-option '-fobject-code' \ 85 | --repl-option '-O0' \ 86 | graphql-parser-test \ 87 | " \ 88 | --test ":main" 89 | 90 | .PHONY: ghcid-bench 91 | ghcid-bench: 92 | ghcid \ 93 | --command "\ 94 | $(CABAL) repl \ 95 | --repl-option '-fobject-code' \ 96 | --repl-option '-O0' \ 97 | graphql-parser-bench \ 98 | " 99 | 100 | .PHONY: lint 101 | lint: 102 | hlint src/ 103 | 104 | .PHONY: lint-all 105 | lint-all: 106 | hlint src/ test/ bench/ 107 | -------------------------------------------------------------------------------- /src/Language/GraphQL/Draft/Syntax/QQ.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TemplateHaskellQuotes #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | -- | Quasiquotation for 'Language.GraphQL.Draft.Syntax' types. 7 | -- 8 | -- These quasiquoters can be used to construct GraphQL literal values at 9 | -- compile-time. 10 | module Language.GraphQL.Draft.Syntax.QQ 11 | ( name, 12 | executableDoc, 13 | ) 14 | where 15 | 16 | ------------------------------------------------------------------------------- 17 | 18 | import Data.Text qualified as Text 19 | import Language.GraphQL.Draft.Parser (parseExecutableDoc) 20 | import Language.GraphQL.Draft.Syntax qualified as Syntax 21 | import Language.Haskell.TH.Quote (QuasiQuoter (..)) 22 | import Prelude 23 | 24 | ------------------------------------------------------------------------------- 25 | 26 | -- | Construct 'Syntax.Name' literals at compile-time via quasiquotation. 27 | -- 28 | -- For example: 29 | -- 30 | -- @ 31 | -- [name|foo_bar|] 32 | -- @ 33 | -- 34 | -- ... would produce a 'Syntax.Name' value with the value @foo_bar@. 35 | name :: QuasiQuoter 36 | name = 37 | QuasiQuoter {quoteExp, quotePat, quoteType, quoteDec} 38 | where 39 | quotePat _ = error "'name' does not support quoting patterns" 40 | quoteType _ = error "'name' does not support quoting types" 41 | quoteDec _ = error "'name' does not support quoting declarations" 42 | quoteExp str = case Syntax.mkName (Text.pack str) of 43 | Nothing -> error $ str <> " is not a valid GraphQL Name" 44 | Just result -> [|result|] 45 | 46 | -- | Construct @'Syntax.ExecutableDocument' 'Syntax.Name'@ literals at compile 47 | -- time via quasiquotation. 48 | -- 49 | -- For example: 50 | -- 51 | -- @ 52 | -- [executableDoc| 53 | -- { 54 | -- hero { 55 | -- name 56 | -- age 57 | -- } 58 | -- } 59 | -- |] 60 | -- @ 61 | executableDoc :: QuasiQuoter 62 | executableDoc = 63 | QuasiQuoter {quoteExp, quotePat, quoteType, quoteDec} 64 | where 65 | quotePat _ = error "'executableDoc' does not support quoting patterns" 66 | quoteType _ = error "'executableDoc' does not support quoting types" 67 | quoteDec _ = error "'executableDoc' does not support quoting declarations" 68 | quoteExp str = case parseExecutableDoc (Text.pack str) of 69 | Left err -> fail . show $ err 70 | Right doc -> [|doc|] 71 | -------------------------------------------------------------------------------- /.github/workflows/weeder.yml: -------------------------------------------------------------------------------- 1 | name: weeder 2 | 3 | on: 4 | push: { branches: [ "main" ] } 5 | pull_request: { branches: [ "main" ] } 6 | 7 | jobs: 8 | ci: 9 | runs-on: ubuntu-latest 10 | strategy: 11 | matrix: 12 | ghc: [ "8.10.7" ] 13 | cabal: [ "latest" ] 14 | 15 | steps: 16 | - name: Checkout this repository. 17 | uses: actions/checkout@v2 18 | 19 | - name: Set up Haskell tooling. 20 | uses: haskell/actions/setup@v1 21 | id: set-up-haskell-tooling 22 | with: 23 | ghc-version: ${{ matrix.ghc }} 24 | cabal-version: ${{ matrix.cabal }} 25 | 26 | - name: Set up weeder store directory. 27 | id: set-up-weeder-store 28 | run: | 29 | mkdir -p /tmp/weeder-store 30 | 31 | cabal \ 32 | --store-dir="/tmp/weeder-store" \ 33 | update \ 34 | --project='./ci/${{ matrix.ghc }}/weeder.project' 35 | 36 | echo '::set-output name=weeder-store::/tmp/weeder-store' 37 | 38 | - name: Cache weeder. 39 | uses: actions/cache@v3 40 | with: 41 | path: | 42 | ${{ steps.set-up-weeder-store.outputs.weeder-store }} 43 | key: ${{ runner.os }}-cabal-${{ matrix.ghc }}-${{ hashFiles('./ci/${{ matrix.ghc }}/weeder.project.freeze') }}-1 44 | restore-keys: | 45 | ${{ runner.os }}-cabal-${{ matrix.ghc }}-${{ hashFiles('./ci/${{ matrix.ghc }}/weeder.project.freeze') }}-1 46 | 47 | - name: Install weeder. 48 | run: | 49 | cabal \ 50 | --store-dir="${{ steps.set-up-weeder-store.outputs.weeder-store }}" \ 51 | install \ 52 | --project='./ci/${{ matrix.ghc }}/weeder.project' \ 53 | weeder 54 | 55 | - name: Cache compiled dependency artifacts. 56 | uses: actions/cache@v3 57 | with: 58 | path: | 59 | ${{ steps.set-up-haskell-tooling.outputs.cabal-store }} 60 | key: ${{ runner.os }}-cabal-${{ matrix.ghc }}-${{ hashFiles('./ci/${{ matrix.ghc }}/ci.project.freeze') }}-0 61 | restore-keys: | 62 | ${{ runner.os }}-cabal-${{ matrix.ghc }}-${{ hashFiles('./ci/${{ matrix.ghc }}/ci.project.freeze') }}-0 63 | 64 | - name: Compile dependencies. 65 | run: | 66 | make update \ 67 | PROJECT='ci/${{ matrix.ghc }}/ci.project' 68 | make build-deps \ 69 | PROJECT='ci/${{ matrix.ghc }}/ci.project' 70 | 71 | - name: Compile library. 72 | run: | 73 | make build \ 74 | PROJECT='ci/${{ matrix.ghc }}/ci.project' 75 | 76 | - name: Run weeder. 77 | run: | 78 | ${HOME}/.cabal/bin/weeder 79 | -------------------------------------------------------------------------------- /bench/Benchmark.hs: -------------------------------------------------------------------------------- 1 | module Main 2 | ( main, 3 | ) 4 | where 5 | 6 | ------------------------------------------------------------------------------- 7 | 8 | import Data.Bifunctor (second) 9 | import Data.ByteString.Builder qualified as BS 10 | import Data.Function ((&)) 11 | import Data.Maybe (mapMaybe) 12 | import Data.Text (Text) 13 | import Data.Text.Lazy.Builder qualified as LTB 14 | import Data.Traversable (for) 15 | import Language.GraphQL.Draft.Generator (genExecutableDocument, genText, generate) 16 | import Language.GraphQL.Draft.Parser (parseExecutableDoc) 17 | import Language.GraphQL.Draft.Printer (executableDocument, renderExecutableDoc) 18 | import Language.GraphQL.Draft.Syntax (ExecutableDocument, Name, mkName) 19 | import Prettyprinter qualified as PP 20 | import Prettyprinter.Render.Text qualified as PP 21 | import Test.Tasty.Bench (bench, bgroup, defaultMain, nf, whnf) 22 | import Text.Builder qualified as STB -- Strict Text Builder 23 | import Prelude 24 | 25 | ------------------------------------------------------------------------------- 26 | 27 | genDocs :: Int -> IO [(Int, ExecutableDocument Name)] 28 | genDocs num = 29 | for [1 .. num] $ \n -> (n,) <$> generate genExecutableDocument 30 | 31 | genTexts :: Int -> IO [(Int, [Text])] 32 | genTexts num = 33 | for [1 .. num] $ \n -> do 34 | texts <- for [1 .. 500 :: Int] \_ -> generate genText 35 | pure (n, texts) 36 | 37 | main :: IO () 38 | main = do 39 | docs <- genDocs 10 40 | texts <- genTexts 10 41 | let grp1 = mkPPGrp docs 42 | grp2 = mkBBGrp docs 43 | grp3 = mkTBGrp docs 44 | grp4 = mkTLBGrp docs 45 | renderedDocs = map (second renderExecutableDoc) docs 46 | grp5 = mkPGrp renderedDocs 47 | grp6 = mkNGrp texts 48 | defaultMain [grp1, grp2, grp3, grp4, grp5, grp6] 49 | where 50 | mkNGrp texts = 51 | bgroup "checking name validity" $ 52 | texts & map \(n, t) -> 53 | bench (show n) $ nf (length . mapMaybe mkName) t 54 | 55 | mkPGrp qs = 56 | bgroup "parsing executableDocument" $ 57 | qs & map \(n, q) -> 58 | bench (show n) $ whnf parseExecutableDoc q 59 | 60 | mkPPGrp gqs = 61 | bgroup "rendering executableDocument (prettyprinter)" $ 62 | gqs & map \(n, gq) -> 63 | bench (show n) $ nf (renderPP . executableDocument) gq 64 | 65 | mkBBGrp gqs = 66 | bgroup "rendering executableDocument (bytestring builder)" $ 67 | gqs & map \(n, gq) -> 68 | bench (show n) $ nf (renderBB . executableDocument) gq 69 | 70 | mkTBGrp gqs = 71 | bgroup "rendering executableDocument (text builder)" $ 72 | gqs & map \(n, gq) -> 73 | bench (show n) $ nf (renderTB . executableDocument) gq 74 | 75 | mkTLBGrp gqs = 76 | bgroup "rendering executableDocument (lazy text builder)" $ 77 | gqs & map \(n, gq) -> 78 | bench (show n) $ nf (renderTLB . executableDocument) gq 79 | 80 | renderPP :: PP.Doc Text -> Text 81 | renderPP = PP.renderStrict . PP.layoutPretty PP.defaultLayoutOptions 82 | renderBB = BS.toLazyByteString 83 | renderTB = STB.run 84 | renderTLB = LTB.toLazyText 85 | -------------------------------------------------------------------------------- /test/BlockStrings.hs: -------------------------------------------------------------------------------- 1 | -- | Regression tests for issue #20 https://github.com/hasura/graphql-parser-hs/issues/20 2 | module BlockStrings 3 | ( blockTest, 4 | ) 5 | where 6 | 7 | ------------------------------------------------------------------------------- 8 | 9 | import Data.Text (Text) 10 | import Data.Text qualified as T 11 | import Hedgehog 12 | ( Group (..), 13 | Property, 14 | checkParallel, 15 | failure, 16 | footnote, 17 | property, 18 | success, 19 | withTests, 20 | (===), 21 | ) 22 | import Language.GraphQL.Draft.Parser (blockString, runParser) 23 | import Prelude 24 | 25 | ------------------------------------------------------------------------------- 26 | 27 | blockTest :: IO Bool 28 | blockTest = do 29 | checkParallel $ 30 | Group 31 | "Test.parser.block-string.unit" 32 | [ ("parses the specExample", "\n Hello,\n World!\n\n Yours,\n GraphQL.\n " `shouldParseTo` "Hello,\n World!\n\nYours,\n GraphQL."), 33 | ("do not remove WS from the end of lines", "\nFoo \nbar " `shouldParseTo` "Foo \nbar "), 34 | ("tabs are WS as well", "\n\t\tFoo\n\t\tbar\n\t\t\tqux" `shouldParseTo` "Foo\nbar\n\tqux"), 35 | ("tabs work with spaces", "\n\t Foo\n \tbar\n\t\t qux" `shouldParseTo` "Foo\nbar\n qux"), 36 | ("parses newline", "\n" `shouldParseTo` ""), 37 | ("parses very simples not-empty block", "x" `shouldParseTo` "x"), 38 | ("common indentation is removed", "\n a \n b \n c " `shouldParseTo` "a \n b \nc "), 39 | ("zero common indentation is possible", "\na \n b \nc " `shouldParseTo` "a \n b \nc "), 40 | ("no whitespace is removed from the first line", " abc " `shouldParseTo` " abc "), 41 | ("ignores escaping", " \\ " `shouldParseTo` " \\ "), -- this is a single \ 42 | ("\n in first characters is parsed", "\n hey " `shouldParseTo` "hey "), 43 | ("simple case", "\nx\n" `shouldParseTo` "x"), 44 | ("empty single line", "" `shouldParseTo` ""), 45 | ("empty two lines", "\n" `shouldParseTo` ""), 46 | ("empty three lines", "\n\n" `shouldParseTo` ""), 47 | ("empty X lines", "\n\n\n\n\n\n" `shouldParseTo` ""), 48 | ("preserves escaped newlines", "\nhello\\nworld\n" `shouldParseTo` "hello\\nworld"), 49 | ("double-quotes are parsed normally", "\n\"\n" `shouldParseTo` "\""), 50 | ("escaped triple-quotes are ignored as block terminator", "\n \\\"\"\"hey\n friends\n" `shouldParseTo` "\"\"\"hey\nfriends"), 51 | ("fails for normal string", blockParseFail "\"hey\""), 52 | ("fails for block string that is not closed", blockParseFail "\"\"\" hey"), 53 | ("fails for block string that is not closed when there are escaped triple-quotes", blockParseFail "\"\"\" hey\\\"\"\"hey"), 54 | ("does not ignore escaping when it's part of an escaped triple-quotes", blockParseFail "\"\"\"\\\"\"\"") -- this is a single \, but it touches the """ at the end 55 | ] 56 | 57 | -- | We use this function to tests cases that we know should 58 | -- fail, when we pass a function to construct wrapped the 59 | -- body in a delimiter, where we will probably be testing 60 | -- for errors using it. 61 | blockParseFail :: Text -> Property 62 | blockParseFail unparsed = withTests 1 $ 63 | property $ do 64 | case runParser blockString ("\"\"\"" <> unparsed <> "\"\"\"") of 65 | Left _ -> success 66 | Right _ -> do 67 | footnote ("Should have failed for: " <> T.unpack ("\"\"\"" <> unparsed <> "\"\"\"")) 68 | failure 69 | 70 | -- | Test whether certain block string content parses to the expected value. 71 | shouldParseTo :: Text -> Text -> Property 72 | shouldParseTo unparsed expected = withTests 1 $ 73 | property $ do 74 | case runParser blockString ("\"\"\"" <> unparsed <> "\"\"\"") of 75 | Right r -> expected === r 76 | Left l -> do 77 | footnote $ T.unpack $ "Block parser failed: " <> l 78 | failure 79 | -------------------------------------------------------------------------------- /graphql-parser.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: graphql-parser 3 | version: 0.2.0.0 4 | synopsis: A native Haskell GraphQL parser. 5 | homepage: https://github.com/hasura/graphql-parser-hs 6 | bug-reports: https://github.com/hasura/graphql-parser-hs/issues 7 | author: Vamshi Surabhi 8 | maintainer: vamshi@hasura.io 9 | copyright: 2018–2022 Hasura Inc., 2015 J. Daniel Navarro 10 | license: BSD-3-Clause 11 | license-file: LICENSE 12 | build-type: Simple 13 | tested-with: GHC ==8.10.7 || ==9.0.2 || ==9.2.2 14 | 15 | source-repository head 16 | type: git 17 | location: https://github.com/hasura/graphql-parser-hs 18 | 19 | common common-all 20 | -- This warning strategy was inspired by Max Tagher's 'Enable All the 21 | -- Warnings' blog post. 22 | -- 23 | -- NOTE: '-Wno-prepositive-qualified-module' is currently a workaround for 24 | -- https://github.com/haskell/cabal/pull/7352 25 | ghc-options: 26 | -Weverything -Wno-missing-exported-signatures 27 | -Wno-missing-import-lists -Wno-missing-export-lists 28 | -Wno-missed-specialisations -Wno-all-missed-specializations 29 | -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode 30 | -Wno-missing-local-signatures -Wno-monomorphism-restriction 31 | -Wno-prepositive-qualified-module 32 | 33 | if impl(ghc >=9.2) 34 | ghc-options: -Wno-implicit-lift 35 | 36 | default-language: Haskell2010 37 | default-extensions: 38 | NoImplicitPrelude 39 | BlockArguments 40 | ConstraintKinds 41 | DeriveAnyClass 42 | DeriveFunctor 43 | DeriveGeneric 44 | DeriveLift 45 | DeriveTraversable 46 | DerivingStrategies 47 | EmptyCase 48 | EmptyDataDeriving 49 | FlexibleContexts 50 | FlexibleInstances 51 | FunctionalDependencies 52 | GeneralizedNewtypeDeriving 53 | ImportQualifiedPost 54 | LambdaCase 55 | NamedFieldPuns 56 | OverloadedStrings 57 | RankNTypes 58 | RecordWildCards 59 | RoleAnnotations 60 | StandaloneKindSignatures 61 | StrictData 62 | TupleSections 63 | 64 | library 65 | import: common-all 66 | hs-source-dirs: src 67 | build-depends: 68 | , aeson >=1.5 69 | , attoparsec >=0.14 70 | , base >=4.7 71 | , bytestring >=0.10 72 | , deepseq >=1.4 73 | , hashable >=1.3 74 | , hedgehog >=1.1 75 | , prettyprinter >=1.7 76 | , scientific >=0.3 77 | , template-haskell >=2.16 78 | , text >=1.2 79 | , text-builder >=0.6 80 | , th-compat >=0.1 81 | , th-lift-instances >=0.1 82 | , unordered-containers >=0.2 83 | 84 | exposed-modules: 85 | Language.GraphQL.Draft.Generator 86 | Language.GraphQL.Draft.Parser 87 | Language.GraphQL.Draft.Printer 88 | Language.GraphQL.Draft.Syntax 89 | Language.GraphQL.Draft.Syntax.Internal 90 | Language.GraphQL.Draft.Syntax.QQ 91 | 92 | other-modules: 93 | Language.GraphQL.Draft.Syntax.Name 94 | 95 | test-suite graphql-parser-test 96 | import: common-all 97 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 98 | type: exitcode-stdio-1.0 99 | hs-source-dirs: test 100 | main-is: Spec.hs 101 | other-modules: 102 | BlockStrings 103 | Keywords 104 | 105 | build-depends: 106 | , base 107 | , bytestring 108 | , graphql-parser 109 | , hedgehog 110 | , prettyprinter 111 | , text 112 | , text-builder 113 | 114 | benchmark graphql-parser-bench 115 | import: common-all 116 | type: exitcode-stdio-1.0 117 | hs-source-dirs: bench 118 | main-is: Benchmark.hs 119 | build-depends: 120 | , base 121 | , bytestring 122 | , graphql-parser 123 | , prettyprinter 124 | , tasty-bench 125 | , text 126 | , text-builder 127 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | 3 | module Main 4 | ( main, 5 | ) 6 | where 7 | 8 | ------------------------------------------------------------------------------- 9 | 10 | import BlockStrings (blockTest) 11 | import Control.Monad (unless) 12 | import Data.ByteString.Builder qualified as BSB 13 | import Data.ByteString.Lazy qualified as LBS 14 | import Data.Kind (Type) 15 | import Data.Text (Text) 16 | import Data.Text qualified as T 17 | import Data.Text.Encoding.Error qualified as TEE 18 | import Data.Text.Lazy qualified as LT 19 | import Data.Text.Lazy.Builder qualified as LTB 20 | import Data.Text.Lazy.Encoding qualified as LTE 21 | import Hedgehog 22 | ( Group (..), 23 | Property, 24 | TestLimit, 25 | checkParallel, 26 | failure, 27 | footnote, 28 | forAll, 29 | property, 30 | withTests, 31 | (===), 32 | ) 33 | import Keywords qualified 34 | import Language.GraphQL.Draft.Generator 35 | import Language.GraphQL.Draft.Parser qualified as Input 36 | import Language.GraphQL.Draft.Printer qualified as Output 37 | import Language.GraphQL.Draft.Syntax 38 | import Prettyprinter qualified as PP 39 | import Prettyprinter.Render.Text qualified as PP 40 | import System.Environment (getArgs) 41 | import System.Exit (exitFailure) 42 | import Text.Builder qualified as TB 43 | import Prelude 44 | 45 | ------------------------------------------------------------------------------- 46 | 47 | type TestMode :: Type 48 | data TestMode = TMDev | TMQuick | TMRelease 49 | deriving stock (Show) 50 | 51 | main :: IO () 52 | main = do 53 | args <- getArgs 54 | case parseArgs args of 55 | TMQuick -> runTest 100 56 | TMDev -> runTest 500 57 | TMRelease -> runTest 1000 58 | where 59 | parseArgs = foldr parseArg TMDev 60 | parseArg str _ = case str of 61 | "quick" -> TMQuick 62 | "release" -> TMRelease 63 | _ -> TMDev 64 | 65 | runTest :: TestLimit -> IO () 66 | runTest limit = do 67 | allGood1 <- tests limit 68 | allGood2 <- blockTest 69 | unless (allGood1 && allGood2) exitFailure 70 | 71 | tests :: TestLimit -> IO Bool 72 | tests nTests = 73 | checkParallel $ 74 | Group "Test.printer.parser" $ 75 | [ ("property [ parse (prettyPrint ast) == ast ]", propParserPrettyPrinter nTests), 76 | ("property [ parse (textBuilderPrint ast) == ast ]", propParserTextPrinter nTests), 77 | ("property [ parse (lazyTextBuilderPrint ast) == ast ]", propParserLazyTextPrinter nTests), 78 | ("property [ parse (bytestringBuilderPrint ast) == ast ]", propParserBSPrinter nTests) 79 | ] 80 | ++ Keywords.primitiveTests 81 | 82 | propParserPrettyPrinter :: TestLimit -> Property 83 | propParserPrettyPrinter = mkPropParserPrinter $ prettyPrinter . Output.executableDocument 84 | where 85 | prettyPrinter :: PP.Doc Text -> Text 86 | prettyPrinter = PP.renderStrict . PP.layoutPretty PP.defaultLayoutOptions 87 | 88 | propParserTextPrinter :: TestLimit -> Property 89 | propParserTextPrinter = mkPropParserPrinter $ TB.run . Output.executableDocument 90 | 91 | propParserLazyTextPrinter :: TestLimit -> Property 92 | propParserLazyTextPrinter = 93 | mkPropParserPrinter $ 94 | LT.toStrict 95 | . LTB.toLazyText 96 | . Output.executableDocument 97 | 98 | propParserBSPrinter :: TestLimit -> Property 99 | propParserBSPrinter = 100 | mkPropParserPrinter $ 101 | bsToTxt 102 | . BSB.toLazyByteString 103 | . Output.executableDocument 104 | 105 | mkPropParserPrinter :: (ExecutableDocument Name -> Text) -> (TestLimit -> Property) 106 | mkPropParserPrinter printer = \space -> 107 | withTests space $ 108 | property $ do 109 | xs <- forAll genExecutableDocument 110 | let rendered = printer xs 111 | either onError (xs ===) $ Input.parseExecutableDoc rendered 112 | where 113 | onError (T.unpack -> errorMsg) = do 114 | footnote errorMsg 115 | failure 116 | 117 | bsToTxt :: LBS.ByteString -> Text 118 | bsToTxt = LT.toStrict . LTE.decodeUtf8With TEE.lenientDecode 119 | -------------------------------------------------------------------------------- /test/Keywords.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | ------------------------------------------------------------------------------- 5 | 6 | -- | Regression tests for issue #20 https://github.com/hasura/graphql-parser-hs/issues/20 7 | module Keywords 8 | ( primitiveTests, 9 | ) 10 | where 11 | 12 | ------------------------------------------------------------------------------- 13 | 14 | import Data.Foldable (for_) 15 | import Data.Text (Text, singleton) 16 | import Data.Void (Void) 17 | import Hedgehog 18 | ( MonadTest, 19 | Property, 20 | PropertyName, 21 | liftTest, 22 | property, 23 | tripping, 24 | withTests, 25 | ) 26 | import Language.GraphQL.Draft.Parser (Parser, nameParser, runParser, value) 27 | import Language.GraphQL.Draft.Printer qualified as Printer 28 | import Language.GraphQL.Draft.Syntax (EnumValue (..), Value (..), addSuffixes, litName, litSuffix) 29 | import Text.Builder (Builder, run) 30 | import Prelude 31 | 32 | ------------------------------------------------------------------------------- 33 | 34 | primitiveTests :: [(PropertyName, Property)] 35 | primitiveTests = 36 | [ ("a \"null\" prefix doesn't prevent parsing a name", withTests 1 propNullNameName), 37 | ("a \"null\" prefix doesn't prevent parsing an enum name", withTests 1 propNullNameValue), 38 | ("a \"true\" prefix doesn't prevent parsing an enum name", withTests 1 propBoolNameValue), 39 | ("a string containing \\NUL is handled correctly", withTests 1 propHandleNulString), 40 | ("a string containing \\n is handled correctly", withTests 1 propHandleNewlineString), 41 | ("a string containing \\x0011 is handled correctly", withTests 1 propHandleControlString), 42 | ("all unicode characters are supported", withTests 1 propHandleUnicodeCharacters), 43 | ("triple quotes is a valid string", withTests 1 propHandleTripleQuote), 44 | ("name with a suffix should be a valid name", withTests 1 propNameWithSuffix) 45 | ] 46 | 47 | propNullNameValue :: Property 48 | propNullNameValue = 49 | property . roundtripValue $ 50 | VList [VEnum $ EnumValue $$(litName "nullColumn")] 51 | 52 | propBoolNameValue :: Property 53 | propBoolNameValue = 54 | property . roundtripValue $ 55 | VList [VEnum $ EnumValue $$(litName "trueColumn")] 56 | 57 | propNullNameName :: Property 58 | propNullNameName = 59 | property $ 60 | roundtripParser nameParser Printer.nameP $$(litName "nullColumntwo") 61 | 62 | propHandleNulString :: Property 63 | propHandleNulString = property . roundtripValue $ VString "\NUL" 64 | 65 | propHandleNewlineString :: Property 66 | propHandleNewlineString = property . roundtripValue $ VString "\n" 67 | 68 | propHandleControlString :: Property 69 | propHandleControlString = property . roundtripValue $ VString "\x0011" 70 | 71 | -- NB: 'liftTest' is explicitly used to restrict the 'for_' block to operate in 72 | -- the 'Test' type (i.e. 'type Test = TestT Identity'), as opposed to 'PropertyT 73 | -- IO'. The 'Test' monad is a thinner monad stack & therefore doesn't suffer 74 | -- from memory leakage caused by, among others, Hedgehog's 'TreeT', which is 75 | -- used for automatic shrinking (which we don't need in this test). 76 | propHandleUnicodeCharacters :: Property 77 | propHandleUnicodeCharacters = property . liftTest $ 78 | for_ [minBound .. maxBound] $ \char -> 79 | roundtripValue . VString $ singleton char 80 | 81 | propHandleTripleQuote :: Property 82 | propHandleTripleQuote = property . roundtripValue $ VString "\"\"\"" 83 | 84 | propNameWithSuffix :: Property 85 | propNameWithSuffix = 86 | property . roundtripValue $ 87 | VList [VEnum $ EnumValue (addSuffixes $$(litName "prefix") [$$(litSuffix "1suffix"), $$(litSuffix "2suffix")])] 88 | 89 | -- | Test that a given 'Value'@ @'Void' passes round-trip tests as expected. 90 | roundtripValue :: (MonadTest m) => Value Void -> m () 91 | roundtripValue = roundtripParser value Printer.value 92 | 93 | -- | Test that a pair of parsing/printing functions are compatible with one 94 | -- another. 95 | -- 96 | -- That is: given a 'Parser'@ a@ and some @a -> @'Builder', ensure that any 97 | -- valid @a@ round-trips through the printer and parser to yield the same @a@. 98 | roundtripParser :: 99 | forall a m. 100 | (MonadTest m, Eq a, Show a) => 101 | Parser a -> 102 | (a -> Builder) -> 103 | a -> 104 | m () 105 | roundtripParser parser printer ast = tripping ast printAST parseAST 106 | where 107 | parseAST :: Text -> Either Text a 108 | parseAST = runParser parser 109 | 110 | printAST :: a -> Text 111 | printAST = run . printer 112 | -------------------------------------------------------------------------------- /src/Language/GraphQL/Draft/Syntax/Name.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskellQuotes #-} 2 | 3 | -- | Internal functionality for Name values. 4 | -- 5 | -- This module is necessary to avoid exposing `unName` and friends to the outside world. 6 | module Language.GraphQL.Draft.Syntax.Name 7 | ( Name (..), 8 | NameSuffix (..), 9 | mkName, 10 | unsafeMkName, 11 | parseName, 12 | mkNameSuffix, 13 | parseSuffix, 14 | isValidName, 15 | addSuffixes, 16 | convertNameToSuffix, 17 | litName, 18 | litSuffix, 19 | litGQLIdentifier, 20 | ) 21 | where 22 | 23 | ------------------------------------------------------------------------------- 24 | 25 | import Control.DeepSeq (NFData) 26 | import Data.Aeson qualified as J 27 | import Data.Char qualified as C 28 | import Data.Coerce (coerce) 29 | import Data.Hashable (Hashable) 30 | import Data.Kind (Type) 31 | import Data.Text (Text) 32 | import Data.Text qualified as T 33 | import Instances.TH.Lift () 34 | import Language.Haskell.TH.Syntax (Lift) 35 | import Language.Haskell.TH.Syntax.Compat (SpliceQ, examineSplice, liftSplice) 36 | import Prettyprinter (Pretty (..)) 37 | import Prelude 38 | 39 | ------------------------------------------------------------------------------- 40 | 41 | -- Defined here and re-exported in the public module to avoid exporting `unName`.` 42 | type Name :: Type 43 | newtype Name = Name {unName :: Text} 44 | deriving stock (Eq, Lift, Ord, Show) 45 | deriving newtype (Semigroup, Hashable, NFData, Pretty, J.ToJSONKey, J.ToJSON) 46 | 47 | -- | @NameSuffix@ is essentially a GQL identifier that can be used as Suffix 48 | -- It is slightely different from @Name@ as it relaxes the criteria that a 49 | -- @Name@ cannot start with a digit. 50 | type NameSuffix :: Type 51 | newtype NameSuffix = Suffix {unNameSuffix :: Text} 52 | deriving stock (Eq, Lift, Ord, Show) 53 | deriving newtype (Semigroup, Hashable, NFData, Pretty, J.ToJSONKey, J.ToJSON) 54 | 55 | parseName :: MonadFail m => Text -> m Name 56 | parseName text = maybe (fail errorMessage) pure $ mkName text 57 | where 58 | errorMessage = T.unpack text <> " is not valid GraphQL name" 59 | 60 | -- | @matchFirst@ verifies if the starting character is according to the 61 | -- graphql spec (refer https://spec.graphql.org/October2021/#NameStart). 62 | matchFirst :: Char -> Bool 63 | matchFirst c = c == '_' || C.isAsciiUpper c || C.isAsciiLower c 64 | 65 | -- | @matchBody@ verifies if the continuing character is according to the 66 | -- graphql spec (refer https://spec.graphql.org/October2021/#NameContinue). 67 | matchBody :: Char -> Bool 68 | matchBody c = c == '_' || C.isAsciiUpper c || C.isAsciiLower c || C.isDigit c 69 | 70 | -- | @isValidName@ verifies if a text is a valid @Name@ as per the graphql 71 | -- spec (refer https://spec.graphql.org/October2021/#Name) 72 | isValidName :: Text -> Bool 73 | isValidName text = 74 | case T.uncons text of 75 | Nothing -> False 76 | Just (first, body) -> 77 | matchFirst first && T.all matchBody body 78 | 79 | mkName :: Text -> Maybe Name 80 | mkName text = 81 | if isValidName text 82 | then Just (Name text) 83 | else Nothing 84 | 85 | mkNameSuffix :: Text -> Maybe NameSuffix 86 | mkNameSuffix text = 87 | if T.all matchBody text 88 | then Just (Suffix text) 89 | else Nothing 90 | 91 | addSuffixes :: Name -> [NameSuffix] -> Name 92 | addSuffixes prefix [] = prefix 93 | addSuffixes (Name prefix) suffs = Name $ T.concat (prefix : suffsT) 94 | where 95 | suffsT = map unNameSuffix suffs 96 | 97 | -- | All @Name@s are @Suffix@, so this function won't fail 98 | convertNameToSuffix :: Name -> NameSuffix 99 | convertNameToSuffix = coerce 100 | 101 | unsafeMkName :: Text -> Name 102 | unsafeMkName = Name 103 | 104 | parseSuffix :: MonadFail m => Text -> m NameSuffix 105 | parseSuffix text = maybe (fail errorMessage) pure $ mkNameSuffix text 106 | where 107 | errorMessage = T.unpack text <> " is not valid GraphQL suffix" 108 | 109 | -- | Construct a 'Name' value at compile-time. 110 | litName :: Text -> SpliceQ Name 111 | litName txt = liftSplice do 112 | name <- parseName txt 113 | examineSplice [||name||] 114 | 115 | -- | Construct a 'NameSuffix' value at compile-time. 116 | litSuffix :: Text -> SpliceQ NameSuffix 117 | litSuffix txt = liftSplice do 118 | name <- parseSuffix txt 119 | examineSplice [||name||] 120 | 121 | -- | Construct prefix-suffix tuple at compile-time from a list. 122 | litGQLIdentifier :: [Text] -> SpliceQ (Name, [NameSuffix]) 123 | litGQLIdentifier [] = liftSplice $ fail "GQL identifier cannot be empty" 124 | litGQLIdentifier (x : xs) = liftSplice do 125 | pref <- parseName x 126 | suffs <- traverse parseSuffix xs 127 | examineSplice [||(pref, suffs)||] 128 | 129 | instance J.FromJSON Name where 130 | parseJSON = J.withText "Name" parseName 131 | 132 | instance J.FromJSONKey Name where 133 | fromJSONKey = J.FromJSONKeyTextParser parseName 134 | -------------------------------------------------------------------------------- /ci/9.0.2/ci.project.freeze: -------------------------------------------------------------------------------- 1 | active-repositories: hackage.haskell.org:merge 2 | constraints: any.OneTuple ==0.3.1, 3 | any.PyF ==0.10.2.0, 4 | PyF -python_test, 5 | any.QuickCheck ==2.14.2, 6 | QuickCheck -old-random +templatehaskell, 7 | any.StateVar ==1.2.2, 8 | any.aeson ==2.0.3.0, 9 | aeson -cffi +ordered-keymap, 10 | any.ansi-terminal ==0.11.3, 11 | ansi-terminal -example, 12 | any.ansi-wl-pprint ==0.6.9, 13 | ansi-wl-pprint -example, 14 | any.array ==0.5.4.0, 15 | any.assoc ==1.0.2, 16 | any.async ==2.2.4, 17 | async -bench, 18 | any.attoparsec ==0.14.4, 19 | attoparsec -developer, 20 | any.barbies ==2.0.3.1, 21 | any.base ==4.15.1.0, 22 | any.base-compat ==0.12.1, 23 | any.base-compat-batteries ==0.12.1, 24 | any.base-orphans ==0.8.6, 25 | any.bifunctors ==5.5.11, 26 | bifunctors +semigroups +tagged, 27 | any.binary ==0.8.8.0, 28 | any.bytestring ==0.10.12.1, 29 | any.clock ==0.8.3, 30 | clock -llvm, 31 | any.colour ==2.3.6, 32 | any.comonad ==5.0.8, 33 | comonad +containers +distributive +indexed-traversable, 34 | any.concurrent-output ==1.10.15, 35 | any.constraints ==0.13.3, 36 | any.containers ==0.6.4.1, 37 | any.contravariant ==1.5.5, 38 | contravariant +semigroups +statevar +tagged, 39 | any.data-fix ==0.3.2, 40 | any.deepseq ==1.4.5.0, 41 | any.deferred-folds ==0.9.18.1, 42 | any.directory ==1.3.6.2, 43 | any.distributive ==0.6.2.1, 44 | distributive +semigroups +tagged, 45 | any.dlist ==1.0, 46 | dlist -werror, 47 | any.erf ==2.0.0.0, 48 | any.exceptions ==0.10.4, 49 | any.filepath ==1.4.2.1, 50 | any.foldl ==1.4.12, 51 | any.ghc ==9.0.2, 52 | any.ghc-bignum ==1.1, 53 | any.ghc-boot ==9.0.2, 54 | any.ghc-boot-th ==9.0.2, 55 | any.ghc-heap ==9.0.2, 56 | any.ghc-prim ==0.7.0, 57 | any.ghci ==9.0.2, 58 | any.happy ==1.20.0, 59 | any.hashable ==1.4.0.2, 60 | hashable +containers +integer-gmp -random-initial-seed, 61 | any.haskell-lexer ==1.1, 62 | any.hedgehog ==1.1.1, 63 | any.hpc ==0.6.1.0, 64 | any.hsc2hs ==0.68.8, 65 | hsc2hs -in-ghc-tree, 66 | any.indexed-traversable ==0.1.2, 67 | any.indexed-traversable-instances ==0.1.1, 68 | any.integer-logarithms ==1.0.3.1, 69 | integer-logarithms -check-bounds +integer-gmp, 70 | any.lifted-async ==0.10.2.2, 71 | any.lifted-base ==0.2.3.12, 72 | any.mmorph ==1.2.0, 73 | any.monad-control ==1.0.3.1, 74 | any.mtl ==2.2.2, 75 | any.optparse-applicative ==0.17.0.0, 76 | optparse-applicative +process, 77 | any.parsec ==3.1.14.0, 78 | any.pretty ==1.1.3.6, 79 | any.pretty-show ==1.10, 80 | any.prettyprinter ==1.7.1, 81 | prettyprinter -buildreadme +text, 82 | any.primitive ==0.7.3.0, 83 | any.process ==1.6.13.2, 84 | any.profunctors ==5.6.2, 85 | any.random ==1.2.1, 86 | any.resourcet ==1.2.4.3, 87 | any.rts ==1.0.2, 88 | any.scientific ==0.3.7.0, 89 | scientific -bytestring-builder -integer-simple, 90 | any.semialign ==1.2.0.1, 91 | semialign +semigroupoids, 92 | any.semigroupoids ==5.3.7, 93 | semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, 94 | any.split ==0.2.3.4, 95 | any.splitmix ==0.1.0.4, 96 | splitmix -optimised-mixer, 97 | any.stm ==2.5.0.0, 98 | any.strict ==0.4.0.1, 99 | strict +assoc, 100 | any.tagged ==0.8.6.1, 101 | tagged +deepseq +transformers, 102 | any.tasty ==1.4.2.1, 103 | tasty +clock +unix, 104 | any.tasty-bench ==0.3.1, 105 | tasty-bench -debug +tasty, 106 | any.template-haskell ==2.17.0.0, 107 | any.terminal-size ==0.3.3, 108 | any.terminfo ==0.4.1.5, 109 | any.text ==1.2.5.0, 110 | any.text-builder ==0.6.7, 111 | any.text-builder-dev ==0.3.1, 112 | any.text-short ==0.1.5, 113 | text-short -asserts, 114 | any.th-abstraction ==0.4.3.0, 115 | any.th-compat ==0.1.3, 116 | any.th-lift ==0.8.2, 117 | any.th-lift-instances ==0.1.19, 118 | any.these ==1.1.1.1, 119 | these +assoc, 120 | any.time ==1.9.3, 121 | any.time-compat ==1.9.6.1, 122 | time-compat -old-locale, 123 | any.transformers ==0.5.6.2, 124 | any.transformers-base ==0.4.6, 125 | transformers-base +orphaninstances, 126 | any.transformers-compat ==0.7.1, 127 | transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, 128 | any.type-equality ==1, 129 | any.unbounded-delays ==0.1.1.1, 130 | any.unix ==2.7.2.2, 131 | any.unliftio-core ==0.2.0.1, 132 | any.unordered-containers ==0.2.19.1, 133 | unordered-containers -debug, 134 | any.uuid-types ==1.0.5, 135 | any.vector ==0.12.3.1, 136 | vector +boundschecks -internalchecks -unsafechecks -wall, 137 | any.wcwidth ==0.0.2, 138 | wcwidth -cli +split-base, 139 | any.witherable ==0.4.2, 140 | any.wl-pprint-annotated ==0.1.0.1 141 | index-state: hackage.haskell.org 2022-05-02T18:30:49Z 142 | -------------------------------------------------------------------------------- /ci/9.2.2/ci.project.freeze: -------------------------------------------------------------------------------- 1 | active-repositories: hackage.haskell.org:merge 2 | constraints: any.OneTuple ==0.3.1, 3 | any.PyF ==0.10.2.0, 4 | PyF -python_test, 5 | any.QuickCheck ==2.14.2, 6 | QuickCheck -old-random +templatehaskell, 7 | any.StateVar ==1.2.2, 8 | any.aeson ==2.0.3.0, 9 | aeson -cffi +ordered-keymap, 10 | any.ansi-terminal ==0.11.3, 11 | ansi-terminal -example, 12 | any.ansi-wl-pprint ==0.6.9, 13 | ansi-wl-pprint -example, 14 | any.array ==0.5.4.0, 15 | any.assoc ==1.0.2, 16 | any.async ==2.2.4, 17 | async -bench, 18 | any.attoparsec ==0.14.4, 19 | attoparsec -developer, 20 | any.barbies ==2.0.3.1, 21 | any.base ==4.16.1.0, 22 | any.base-compat ==0.12.1, 23 | any.base-compat-batteries ==0.12.1, 24 | any.base-orphans ==0.8.6, 25 | any.bifunctors ==5.5.11, 26 | bifunctors +semigroups +tagged, 27 | any.binary ==0.8.9.0, 28 | any.bytestring ==0.11.3.0, 29 | any.clock ==0.8.3, 30 | clock -llvm, 31 | any.colour ==2.3.6, 32 | any.comonad ==5.0.8, 33 | comonad +containers +distributive +indexed-traversable, 34 | any.concurrent-output ==1.10.15, 35 | any.constraints ==0.13.3, 36 | any.containers ==0.6.5.1, 37 | any.contravariant ==1.5.5, 38 | contravariant +semigroups +statevar +tagged, 39 | any.data-fix ==0.3.2, 40 | any.deepseq ==1.4.6.1, 41 | any.deferred-folds ==0.9.18.1, 42 | any.directory ==1.3.6.2, 43 | any.distributive ==0.6.2.1, 44 | distributive +semigroups +tagged, 45 | any.dlist ==1.0, 46 | dlist -werror, 47 | any.erf ==2.0.0.0, 48 | any.exceptions ==0.10.4, 49 | any.filepath ==1.4.2.2, 50 | any.foldl ==1.4.12, 51 | any.ghc ==9.2.2, 52 | any.ghc-bignum ==1.2, 53 | any.ghc-boot ==9.2.2, 54 | any.ghc-boot-th ==9.2.2, 55 | any.ghc-heap ==9.2.2, 56 | any.ghc-prim ==0.8.0, 57 | any.ghci ==9.2.2, 58 | any.happy ==1.20.0, 59 | any.hashable ==1.4.0.2, 60 | hashable +containers +integer-gmp -random-initial-seed, 61 | any.haskell-lexer ==1.1, 62 | any.hedgehog ==1.1.1, 63 | any.hpc ==0.6.1.0, 64 | any.hsc2hs ==0.68.8, 65 | hsc2hs -in-ghc-tree, 66 | any.indexed-traversable ==0.1.2, 67 | any.indexed-traversable-instances ==0.1.1, 68 | any.integer-logarithms ==1.0.3.1, 69 | integer-logarithms -check-bounds +integer-gmp, 70 | any.lifted-async ==0.10.2.2, 71 | any.lifted-base ==0.2.3.12, 72 | any.mmorph ==1.2.0, 73 | any.monad-control ==1.0.3.1, 74 | any.mtl ==2.2.2, 75 | any.optparse-applicative ==0.17.0.0, 76 | optparse-applicative +process, 77 | any.parsec ==3.1.15.0, 78 | any.pretty ==1.1.3.6, 79 | any.pretty-show ==1.10, 80 | any.prettyprinter ==1.7.1, 81 | prettyprinter -buildreadme +text, 82 | any.primitive ==0.7.3.0, 83 | any.process ==1.6.13.2, 84 | any.profunctors ==5.6.2, 85 | any.random ==1.2.1, 86 | any.resourcet ==1.2.4.3, 87 | any.rts ==1.0.2, 88 | any.scientific ==0.3.7.0, 89 | scientific -bytestring-builder -integer-simple, 90 | any.semialign ==1.2.0.1, 91 | semialign +semigroupoids, 92 | any.semigroupoids ==5.3.7, 93 | semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, 94 | any.split ==0.2.3.4, 95 | any.splitmix ==0.1.0.4, 96 | splitmix -optimised-mixer, 97 | any.stm ==2.5.0.2, 98 | any.strict ==0.4.0.1, 99 | strict +assoc, 100 | any.tagged ==0.8.6.1, 101 | tagged +deepseq +transformers, 102 | any.tasty ==1.4.2.1, 103 | tasty +clock +unix, 104 | any.tasty-bench ==0.3.1, 105 | tasty-bench -debug +tasty, 106 | any.template-haskell ==2.18.0.0, 107 | any.terminal-size ==0.3.3, 108 | any.terminfo ==0.4.1.5, 109 | any.text ==1.2.5.0, 110 | any.text-builder ==0.6.7, 111 | any.text-builder-dev ==0.3.1, 112 | any.text-short ==0.1.5, 113 | text-short -asserts, 114 | any.th-abstraction ==0.4.3.0, 115 | any.th-compat ==0.1.3, 116 | any.th-lift ==0.8.2, 117 | any.th-lift-instances ==0.1.19, 118 | any.these ==1.1.1.1, 119 | these +assoc, 120 | any.time ==1.11.1.1, 121 | any.time-compat ==1.9.6.1, 122 | time-compat -old-locale, 123 | any.transformers ==0.5.6.2, 124 | any.transformers-base ==0.4.6, 125 | transformers-base +orphaninstances, 126 | any.transformers-compat ==0.7.1, 127 | transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, 128 | any.type-equality ==1, 129 | any.unbounded-delays ==0.1.1.1, 130 | any.unix ==2.7.2.2, 131 | any.unliftio-core ==0.2.0.1, 132 | any.unordered-containers ==0.2.19.1, 133 | unordered-containers -debug, 134 | any.uuid-types ==1.0.5, 135 | any.vector ==0.12.3.1, 136 | vector +boundschecks -internalchecks -unsafechecks -wall, 137 | any.wcwidth ==0.0.2, 138 | wcwidth -cli +split-base, 139 | any.witherable ==0.4.2, 140 | any.wl-pprint-annotated ==0.1.0.1 141 | index-state: hackage.haskell.org 2022-05-06T13:54:12Z 142 | -------------------------------------------------------------------------------- /ci/8.10.7/ci.project.freeze: -------------------------------------------------------------------------------- 1 | active-repositories: hackage.haskell.org:merge 2 | constraints: any.OneTuple ==0.3.1, 3 | any.PyF ==0.10.2.0, 4 | PyF -python_test, 5 | any.QuickCheck ==2.14.2, 6 | QuickCheck -old-random +templatehaskell, 7 | any.StateVar ==1.2.2, 8 | any.aeson ==2.0.3.0, 9 | aeson -cffi +ordered-keymap, 10 | any.ansi-terminal ==0.11.3, 11 | ansi-terminal -example, 12 | any.ansi-wl-pprint ==0.6.9, 13 | ansi-wl-pprint -example, 14 | any.array ==0.5.4.0, 15 | any.assoc ==1.0.2, 16 | any.async ==2.2.4, 17 | async -bench, 18 | any.attoparsec ==0.14.4, 19 | attoparsec -developer, 20 | any.barbies ==2.0.3.1, 21 | any.base ==4.14.3.0, 22 | any.base-compat ==0.12.1, 23 | any.base-compat-batteries ==0.12.1, 24 | any.base-orphans ==0.8.6, 25 | any.bifunctors ==5.5.11, 26 | bifunctors +semigroups +tagged, 27 | any.binary ==0.8.8.0, 28 | any.bytestring ==0.10.12.0, 29 | any.clock ==0.8.3, 30 | clock -llvm, 31 | any.colour ==2.3.6, 32 | any.comonad ==5.0.8, 33 | comonad +containers +distributive +indexed-traversable, 34 | any.concurrent-output ==1.10.15, 35 | any.constraints ==0.13.3, 36 | any.containers ==0.6.5.1, 37 | any.contravariant ==1.5.5, 38 | contravariant +semigroups +statevar +tagged, 39 | any.data-fix ==0.3.2, 40 | any.deepseq ==1.4.4.0, 41 | any.deferred-folds ==0.9.18.1, 42 | any.directory ==1.3.6.0, 43 | any.distributive ==0.6.2.1, 44 | distributive +semigroups +tagged, 45 | any.dlist ==1.0, 46 | dlist -werror, 47 | any.erf ==2.0.0.0, 48 | any.exceptions ==0.10.4, 49 | any.filepath ==1.4.2.1, 50 | any.foldl ==1.4.12, 51 | any.ghc ==8.10.7, 52 | any.ghc-boot ==8.10.7, 53 | any.ghc-boot-th ==8.10.7, 54 | any.ghc-heap ==8.10.7, 55 | any.ghc-prim ==0.6.1, 56 | any.ghci ==8.10.7, 57 | any.happy ==1.20.0, 58 | any.hashable ==1.4.0.2, 59 | hashable +containers +integer-gmp -random-initial-seed, 60 | any.haskell-lexer ==1.1, 61 | any.hedgehog ==1.1.1, 62 | any.hpc ==0.6.1.0, 63 | any.hsc2hs ==0.68.8, 64 | hsc2hs -in-ghc-tree, 65 | any.indexed-traversable ==0.1.2, 66 | any.indexed-traversable-instances ==0.1.1, 67 | any.integer-gmp ==1.0.3.0, 68 | any.integer-logarithms ==1.0.3.1, 69 | integer-logarithms -check-bounds +integer-gmp, 70 | any.lifted-async ==0.10.2.2, 71 | any.lifted-base ==0.2.3.12, 72 | any.mmorph ==1.2.0, 73 | any.monad-control ==1.0.3.1, 74 | any.mtl ==2.2.2, 75 | any.optparse-applicative ==0.17.0.0, 76 | optparse-applicative +process, 77 | any.parsec ==3.1.14.0, 78 | any.pretty ==1.1.3.6, 79 | any.pretty-show ==1.10, 80 | any.prettyprinter ==1.7.1, 81 | prettyprinter -buildreadme +text, 82 | any.primitive ==0.7.3.0, 83 | any.process ==1.6.13.2, 84 | any.profunctors ==5.6.2, 85 | any.random ==1.2.1, 86 | any.resourcet ==1.2.4.3, 87 | any.rts ==1.0.1, 88 | any.scientific ==0.3.7.0, 89 | scientific -bytestring-builder -integer-simple, 90 | any.semialign ==1.2.0.1, 91 | semialign +semigroupoids, 92 | any.semigroupoids ==5.3.7, 93 | semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, 94 | any.split ==0.2.3.4, 95 | any.splitmix ==0.1.0.4, 96 | splitmix -optimised-mixer, 97 | any.stm ==2.5.0.1, 98 | any.strict ==0.4.0.1, 99 | strict +assoc, 100 | any.tagged ==0.8.6.1, 101 | tagged +deepseq +transformers, 102 | any.tasty ==1.4.2.1, 103 | tasty +clock +unix, 104 | any.tasty-bench ==0.3.1, 105 | tasty-bench -debug +tasty, 106 | any.template-haskell ==2.16.0.0, 107 | any.terminal-size ==0.3.3, 108 | any.terminfo ==0.4.1.4, 109 | any.text ==1.2.4.1, 110 | any.text-builder ==0.6.7, 111 | any.text-builder-dev ==0.3.1, 112 | any.text-short ==0.1.5, 113 | text-short -asserts, 114 | any.th-abstraction ==0.4.3.0, 115 | any.th-compat ==0.1.3, 116 | any.th-lift ==0.8.2, 117 | any.th-lift-instances ==0.1.19, 118 | any.these ==1.1.1.1, 119 | these +assoc, 120 | any.time ==1.9.3, 121 | any.time-compat ==1.9.6.1, 122 | time-compat -old-locale, 123 | any.transformers ==0.5.6.2, 124 | any.transformers-base ==0.4.6, 125 | transformers-base +orphaninstances, 126 | any.transformers-compat ==0.7.1, 127 | transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, 128 | any.type-equality ==1, 129 | any.unbounded-delays ==0.1.1.1, 130 | any.unix ==2.7.2.2, 131 | any.unliftio-core ==0.2.0.1, 132 | any.unordered-containers ==0.2.19.1, 133 | unordered-containers -debug, 134 | any.uuid-types ==1.0.5, 135 | any.vector ==0.12.3.1, 136 | vector +boundschecks -internalchecks -unsafechecks -wall, 137 | any.wcwidth ==0.0.2, 138 | wcwidth -cli +split-base, 139 | any.witherable ==0.4.2, 140 | any.wl-pprint-annotated ==0.1.0.1 141 | index-state: hackage.haskell.org 2022-05-02T18:30:49Z 142 | -------------------------------------------------------------------------------- /ci/8.10.7/weeder.project.freeze: -------------------------------------------------------------------------------- 1 | active-repositories: hackage.haskell.org:merge 2 | constraints: any.OneTuple ==0.3.1, 3 | any.PyF ==0.10.2.0, 4 | PyF -python_test, 5 | any.QuickCheck ==2.14.2, 6 | QuickCheck -old-random +templatehaskell, 7 | any.StateVar ==1.2.2, 8 | any.aeson ==2.0.3.0, 9 | aeson -cffi +ordered-keymap, 10 | any.ansi-terminal ==0.11.3, 11 | ansi-terminal -example, 12 | any.ansi-wl-pprint ==0.6.9, 13 | ansi-wl-pprint -example, 14 | any.array ==0.5.4.0, 15 | any.assoc ==1.0.2, 16 | any.async ==2.2.4, 17 | async -bench, 18 | any.attoparsec ==0.14.4, 19 | attoparsec -developer, 20 | any.barbies ==2.0.3.1, 21 | any.base ==4.14.3.0, 22 | any.base-compat ==0.12.1, 23 | any.base-compat-batteries ==0.12.1, 24 | any.base-orphans ==0.8.6, 25 | any.bifunctors ==5.5.11, 26 | bifunctors +semigroups +tagged, 27 | any.binary ==0.8.8.0, 28 | any.bytestring ==0.10.12.0, 29 | any.clock ==0.8.3, 30 | clock -llvm, 31 | any.colour ==2.3.6, 32 | any.comonad ==5.0.8, 33 | comonad +containers +distributive +indexed-traversable, 34 | any.concurrent-output ==1.10.15, 35 | any.constraints ==0.13.3, 36 | any.containers ==0.6.5.1, 37 | any.contravariant ==1.5.5, 38 | contravariant +semigroups +statevar +tagged, 39 | any.data-fix ==0.3.2, 40 | any.deepseq ==1.4.4.0, 41 | any.deferred-folds ==0.9.18.1, 42 | any.directory ==1.3.6.0, 43 | any.distributive ==0.6.2.1, 44 | distributive +semigroups +tagged, 45 | any.dlist ==1.0, 46 | dlist -werror, 47 | any.erf ==2.0.0.0, 48 | any.exceptions ==0.10.4, 49 | any.filepath ==1.4.2.1, 50 | any.foldl ==1.4.12, 51 | any.ghc ==8.10.7, 52 | any.ghc-boot ==8.10.7, 53 | any.ghc-boot-th ==8.10.7, 54 | any.ghc-heap ==8.10.7, 55 | any.ghc-prim ==0.6.1, 56 | any.ghci ==8.10.7, 57 | any.happy ==1.20.0, 58 | any.hashable ==1.4.0.2, 59 | hashable +containers +integer-gmp -random-initial-seed, 60 | any.haskell-lexer ==1.1, 61 | any.hedgehog ==1.1.1, 62 | any.hpc ==0.6.1.0, 63 | any.hsc2hs ==0.68.8, 64 | hsc2hs -in-ghc-tree, 65 | any.indexed-traversable ==0.1.2, 66 | any.indexed-traversable-instances ==0.1.1, 67 | any.integer-gmp ==1.0.3.0, 68 | any.integer-logarithms ==1.0.3.1, 69 | integer-logarithms -check-bounds +integer-gmp, 70 | any.lifted-async ==0.10.2.2, 71 | any.lifted-base ==0.2.3.12, 72 | any.mmorph ==1.2.0, 73 | any.monad-control ==1.0.3.1, 74 | any.mtl ==2.2.2, 75 | any.optparse-applicative ==0.17.0.0, 76 | optparse-applicative +process, 77 | any.parsec ==3.1.14.0, 78 | any.pretty ==1.1.3.6, 79 | any.pretty-show ==1.10, 80 | any.prettyprinter ==1.7.1, 81 | prettyprinter -buildreadme +text, 82 | any.primitive ==0.7.3.0, 83 | any.process ==1.6.13.2, 84 | any.profunctors ==5.6.2, 85 | any.random ==1.2.1, 86 | any.resourcet ==1.2.4.3, 87 | any.rts ==1.0.1, 88 | any.scientific ==0.3.7.0, 89 | scientific -bytestring-builder -integer-simple, 90 | any.semialign ==1.2.0.1, 91 | semialign +semigroupoids, 92 | any.semigroupoids ==5.3.7, 93 | semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, 94 | any.split ==0.2.3.4, 95 | any.splitmix ==0.1.0.4, 96 | splitmix -optimised-mixer, 97 | any.stm ==2.5.0.1, 98 | any.strict ==0.4.0.1, 99 | strict +assoc, 100 | any.tagged ==0.8.6.1, 101 | tagged +deepseq +transformers, 102 | any.tasty ==1.4.2.1, 103 | tasty +clock +unix, 104 | any.tasty-bench ==0.3.1, 105 | tasty-bench -debug +tasty, 106 | any.template-haskell ==2.16.0.0, 107 | any.terminal-size ==0.3.3, 108 | any.terminfo ==0.4.1.4, 109 | any.text ==1.2.4.1, 110 | any.text-builder ==0.6.7, 111 | any.text-builder-dev ==0.3.1, 112 | any.text-short ==0.1.5, 113 | text-short -asserts, 114 | any.th-abstraction ==0.4.3.0, 115 | any.th-compat ==0.1.3, 116 | any.th-lift ==0.8.2, 117 | any.th-lift-instances ==0.1.19, 118 | any.these ==1.1.1.1, 119 | these +assoc, 120 | any.time ==1.9.3, 121 | any.time-compat ==1.9.6.1, 122 | time-compat -old-locale, 123 | any.transformers ==0.5.6.2, 124 | any.transformers-base ==0.4.6, 125 | transformers-base +orphaninstances, 126 | any.transformers-compat ==0.7.1, 127 | transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, 128 | any.type-equality ==1, 129 | any.unbounded-delays ==0.1.1.1, 130 | any.unix ==2.7.2.2, 131 | any.unliftio-core ==0.2.0.1, 132 | any.unordered-containers ==0.2.19.1, 133 | unordered-containers -debug, 134 | any.uuid-types ==1.0.5, 135 | any.vector ==0.12.3.1, 136 | vector +boundschecks -internalchecks -unsafechecks -wall, 137 | any.wcwidth ==0.0.2, 138 | wcwidth -cli +split-base, 139 | any.weeder ==2.2.0, 140 | any.witherable ==0.4.2, 141 | any.wl-pprint-annotated ==0.1.0.1 142 | index-state: hackage.haskell.org 2022-05-02T18:30:49Z 143 | -------------------------------------------------------------------------------- /src/Language/GraphQL/Draft/Generator.hs: -------------------------------------------------------------------------------- 1 | module Language.GraphQL.Draft.Generator 2 | ( -- * Generator 3 | Generator (..), 4 | generate, 5 | 6 | -- * Document 7 | genDocument, 8 | genExecutableDocument, 9 | 10 | -- * Identifiers 11 | genText, 12 | alpha_, 13 | alphaNum_, 14 | genGraphqlName, 15 | genName, 16 | genNullability, 17 | genType, 18 | genDescription, 19 | genValueWith, 20 | genEnumValue, 21 | genListValue, 22 | genObjectValue, 23 | genBlockText, 24 | genMinIndentedText, 25 | genIndentation, 26 | 27 | -- * Definitions 28 | genDefinition, 29 | genExecutableDefinition, 30 | genOperationDefinition, 31 | genTypedOperationDefinition, 32 | genVariableDefinition, 33 | genFragmentDefinition, 34 | genTypeSystemDefinition, 35 | genSchemaDefinition, 36 | genRootOperationTypeDefinition, 37 | genOperationType, 38 | genTypeDefinition, 39 | genScalarTypeDefinition, 40 | genObjectTypeDefinition, 41 | genInterfaceTypeDefinition, 42 | genUnionTypeDefinition, 43 | genEnumTypeDefinition, 44 | genInputObjectTypeDefinition, 45 | genInputValueDefinition, 46 | genEnumValueDefinition, 47 | genFieldDefinition, 48 | genFieldDefinitions, 49 | genDirectiveDefinition, 50 | genArgumentsDefinition, 51 | genDirectiveLocation, 52 | genExecutableDirectiveLocation, 53 | genTypeSystemDirectiveLocation, 54 | 55 | -- * Structure 56 | genSelectionSet, 57 | genSelection, 58 | genFragmentSpread, 59 | genInlineFragment, 60 | genField, 61 | genDirective, 62 | genDirectives, 63 | genArgument, 64 | 65 | -- * Helpers 66 | mkList, 67 | mkListNonEmpty, 68 | ) 69 | where 70 | 71 | ------------------------------------------------------------------------------- 72 | 73 | import Control.Monad.IO.Class (MonadIO) 74 | import Data.HashMap.Strict as M 75 | import Data.Kind (Constraint, Type) 76 | import Data.Scientific (fromFloatDigits) 77 | import Data.Text (Text) 78 | import Data.Text qualified as T 79 | import Data.Void (Void) 80 | import Hedgehog (Gen) 81 | import Hedgehog.Gen qualified as Gen 82 | import Hedgehog.Range qualified as Range 83 | import Language.GraphQL.Draft.Syntax 84 | import Prelude 85 | 86 | ------------------------------------------------------------------------------- 87 | 88 | -- | *Generator* 89 | type Generator :: Type -> Constraint 90 | class Generator a where 91 | genValue :: Gen (Value a) 92 | 93 | instance Generator Void where 94 | genValue = genValueWith [] 95 | 96 | instance Generator Name where 97 | genValue = genValueWith [genName] 98 | 99 | generate :: MonadIO m => Gen a -> m a 100 | generate = Gen.sample 101 | 102 | ------------------------------------------------------------------------------- 103 | 104 | -- Document 105 | 106 | genDocument :: Gen Document 107 | genDocument = 108 | Document <$> Gen.list (Range.linear 0 3) genDefinition 109 | 110 | genExecutableDocument :: Generator a => Gen (ExecutableDocument a) 111 | genExecutableDocument = 112 | ExecutableDocument <$> Gen.list (Range.linear 1 3) genExecutableDefinition 113 | 114 | ------------------------------------------------------------------------------- 115 | 116 | -- Identifiers 117 | 118 | genText :: Gen Text 119 | genText = Gen.text (Range.linear 0 11) Gen.unicode 120 | 121 | alpha_ :: Gen Char 122 | alpha_ = Gen.choice [Gen.alpha, pure '_'] 123 | 124 | alphaNum_ :: Gen Char 125 | alphaNum_ = Gen.choice [Gen.alphaNum, pure '_'] 126 | 127 | genGraphqlName :: Gen Text 128 | genGraphqlName = 129 | Gen.text (Range.singleton 1) alpha_ 130 | <> Gen.text (Range.linear 0 11) alphaNum_ 131 | 132 | genName :: Gen Name 133 | genName = unsafeMkName <$> genGraphqlName 134 | 135 | genNullability :: Gen Nullability 136 | genNullability = Nullability <$> Gen.bool 137 | 138 | genType :: Gen GType 139 | genType = 140 | Gen.recursive 141 | Gen.choice 142 | [TypeNamed <$> genNullability <*> genName] 143 | [TypeList <$> genNullability <*> genType] 144 | 145 | genDescription :: Gen Description 146 | genDescription = Description <$> Gen.choice [genText, genBlockText] 147 | 148 | ------------------------------------------------------------------------------- 149 | 150 | -- Values 151 | 152 | genValueWith :: [Gen a] -> Gen (Value a) 153 | genValueWith varGens = Gen.recursive Gen.choice nonRecursive recursive 154 | where 155 | recursive = 156 | [ VList <$> genListValue (genValueWith varGens), 157 | VObject <$> genObjectValue (genValueWith varGens) 158 | ] 159 | -- TODO: use maxbound of int32/double or something? 160 | nonRecursive = 161 | [ pure VNull, 162 | VInt . fromIntegral <$> Gen.int32 (Range.linear 1 99999), 163 | VEnum <$> genEnumValue, 164 | VFloat . fromFloatDigits <$> Gen.double (Range.linearFrac 1.1 999999.99999), 165 | VString <$> Gen.choice [genText, genBlockText], 166 | VBoolean <$> Gen.bool 167 | ] 168 | <> [VVariable <$> var | var <- varGens] 169 | 170 | genEnumValue :: Gen EnumValue 171 | genEnumValue = EnumValue <$> genName 172 | 173 | genListValue :: Gen (Value a) -> Gen [Value a] 174 | genListValue = mkList 175 | 176 | genObjectValue :: Gen (Value a) -> Gen (M.HashMap Name (Value a)) 177 | genObjectValue genVal = M.fromList <$> mkList genObjectField 178 | where 179 | genObjectField = (,) <$> genName <*> genVal 180 | 181 | genBlockText :: Gen Text 182 | genBlockText = T.unlines <$> Gen.list (Range.linear 0 20) line 183 | where 184 | line = do 185 | Gen.frequency 186 | [ (10, Gen.text (Range.linear 1 10) Gen.unicode), 187 | (10, return "\n"), 188 | (6, genIndentation), 189 | (5, genMinIndentedText 10), 190 | (4, return ""), 191 | (3, return " "), 192 | (6, return "\t"), 193 | (3, return "\""), -- " 194 | (3, return "\\") -- \ 195 | ] 196 | 197 | -- | Like `genText` but with random indentation in the start of the string according 198 | -- to a minimum value. 199 | genMinIndentedText :: Int -> Gen Text 200 | genMinIndentedText min_ = do 201 | let minIndent = T.replicate min_ " " 202 | i <- genIndentation 203 | t <- genText 204 | return (minIndent <> i <> t) 205 | 206 | genIndentation :: Gen Text 207 | genIndentation = do 208 | Gen.text (Range.linear 0 100) (return ' ') 209 | 210 | ------------------------------------------------------------------------------- 211 | 212 | -- Definitions 213 | 214 | genDefinition :: Gen Definition 215 | genDefinition = 216 | Gen.choice 217 | [ DefinitionExecutable <$> genExecutableDefinition, 218 | DefinitionTypeSystem <$> genTypeSystemDefinition 219 | ] 220 | 221 | genExecutableDefinition :: Generator a => Gen (ExecutableDefinition a) 222 | genExecutableDefinition = 223 | Gen.choice 224 | [ ExecutableDefinitionOperation <$> genOperationDefinition, 225 | ExecutableDefinitionFragment <$> genFragmentDefinition 226 | ] 227 | 228 | genOperationDefinition :: Generator a => Gen (OperationDefinition FragmentSpread a) 229 | genOperationDefinition = 230 | Gen.choice 231 | [ OperationDefinitionTyped <$> genTypedOperationDefinition, 232 | OperationDefinitionUnTyped <$> genSelectionSet 233 | ] 234 | 235 | genTypedOperationDefinition :: Generator a => Gen (TypedOperationDefinition FragmentSpread a) 236 | genTypedOperationDefinition = 237 | TypedOperationDefinition 238 | <$> genOperationType 239 | <*> Gen.maybe genName 240 | <*> mkList genVariableDefinition 241 | <*> genDirectives 242 | <*> genSelectionSet 243 | 244 | genVariableDefinition :: Gen VariableDefinition 245 | genVariableDefinition = 246 | VariableDefinition 247 | <$> genName 248 | <*> genType 249 | <*> Gen.maybe genValue 250 | 251 | genFragmentDefinition :: Gen FragmentDefinition 252 | genFragmentDefinition = 253 | FragmentDefinition 254 | <$> genName 255 | <*> genName 256 | <*> genDirectives 257 | <*> genSelectionSet 258 | 259 | genTypeSystemDefinition :: Gen TypeSystemDefinition 260 | genTypeSystemDefinition = 261 | Gen.choice 262 | [ TypeSystemDefinitionSchema <$> genSchemaDefinition, 263 | TypeSystemDefinitionType <$> genTypeDefinition 264 | ] 265 | 266 | genSchemaDefinition :: Gen SchemaDefinition 267 | genSchemaDefinition = 268 | SchemaDefinition 269 | <$> Gen.maybe genDirectives 270 | <*> mkList genRootOperationTypeDefinition 271 | 272 | genRootOperationTypeDefinition :: Gen RootOperationTypeDefinition 273 | genRootOperationTypeDefinition = 274 | RootOperationTypeDefinition 275 | <$> genOperationType 276 | <*> genName 277 | 278 | genOperationType :: Gen OperationType 279 | genOperationType = 280 | Gen.element 281 | [ OperationTypeQuery, 282 | OperationTypeMutation, 283 | OperationTypeSubscription 284 | ] 285 | 286 | genTypeDefinition :: Gen (TypeDefinition () InputValueDefinition) 287 | genTypeDefinition = 288 | Gen.choice 289 | [ TypeDefinitionScalar <$> genScalarTypeDefinition, 290 | TypeDefinitionObject <$> genObjectTypeDefinition, 291 | TypeDefinitionInterface <$> genInterfaceTypeDefinition, 292 | TypeDefinitionUnion <$> genUnionTypeDefinition, 293 | TypeDefinitionEnum <$> genEnumTypeDefinition, 294 | TypeDefinitionInputObject <$> genInputObjectTypeDefinition 295 | ] 296 | 297 | genScalarTypeDefinition :: Gen ScalarTypeDefinition 298 | genScalarTypeDefinition = 299 | ScalarTypeDefinition 300 | <$> Gen.maybe genDescription 301 | <*> genName 302 | <*> genDirectives 303 | 304 | genObjectTypeDefinition :: Gen (ObjectTypeDefinition InputValueDefinition) 305 | genObjectTypeDefinition = 306 | ObjectTypeDefinition 307 | <$> Gen.maybe genDescription 308 | <*> genName 309 | <*> mkList genName 310 | <*> genDirectives 311 | <*> genFieldDefinitions 312 | 313 | genInterfaceTypeDefinition :: Gen (InterfaceTypeDefinition () InputValueDefinition) 314 | genInterfaceTypeDefinition = 315 | InterfaceTypeDefinition 316 | <$> Gen.maybe genDescription 317 | <*> genName 318 | <*> genDirectives 319 | <*> genFieldDefinitions 320 | <*> pure () 321 | 322 | genUnionTypeDefinition :: Gen UnionTypeDefinition 323 | genUnionTypeDefinition = 324 | UnionTypeDefinition 325 | <$> Gen.maybe genDescription 326 | <*> genName 327 | <*> genDirectives 328 | <*> mkList genName 329 | 330 | genEnumTypeDefinition :: Gen EnumTypeDefinition 331 | genEnumTypeDefinition = 332 | EnumTypeDefinition 333 | <$> Gen.maybe genDescription 334 | <*> genName 335 | <*> genDirectives 336 | <*> mkList genEnumValueDefinition 337 | 338 | genInputObjectTypeDefinition :: Gen (InputObjectTypeDefinition InputValueDefinition) 339 | genInputObjectTypeDefinition = 340 | InputObjectTypeDefinition 341 | <$> Gen.maybe genDescription 342 | <*> genName 343 | <*> genDirectives 344 | <*> mkList genInputValueDefinition 345 | 346 | genInputValueDefinition :: Gen InputValueDefinition 347 | genInputValueDefinition = 348 | InputValueDefinition 349 | <$> Gen.maybe genDescription 350 | <*> genName 351 | <*> genType 352 | <*> Gen.maybe genValue 353 | <*> genDirectives 354 | 355 | genEnumValueDefinition :: Gen EnumValueDefinition 356 | genEnumValueDefinition = 357 | EnumValueDefinition 358 | <$> Gen.maybe genDescription 359 | <*> genEnumValue 360 | <*> genDirectives 361 | 362 | genFieldDefinition :: Gen (FieldDefinition InputValueDefinition) 363 | genFieldDefinition = 364 | FieldDefinition 365 | <$> Gen.maybe genDescription 366 | <*> genName 367 | <*> mkList genInputValueDefinition 368 | <*> genType 369 | <*> genDirectives 370 | 371 | genFieldDefinitions :: Gen [FieldDefinition InputValueDefinition] 372 | genFieldDefinitions = mkList genFieldDefinition 373 | 374 | genDirectiveDefinition :: Gen (DirectiveDefinition InputValueDefinition) 375 | genDirectiveDefinition = 376 | DirectiveDefinition 377 | <$> Gen.maybe genDescription 378 | <*> genName 379 | <*> genArgumentsDefinition 380 | <*> Gen.list (Range.linear 1 10) genDirectiveLocation 381 | 382 | genArgumentsDefinition :: Gen (ArgumentsDefinition InputValueDefinition) 383 | genArgumentsDefinition = Gen.list (Range.linear 1 10) genInputValueDefinition 384 | 385 | genDirectiveLocation :: Gen DirectiveLocation 386 | genDirectiveLocation = 387 | Gen.choice 388 | [ DLExecutable <$> genExecutableDirectiveLocation, 389 | DLTypeSystem <$> genTypeSystemDirectiveLocation 390 | ] 391 | 392 | genExecutableDirectiveLocation :: Gen ExecutableDirectiveLocation 393 | genExecutableDirectiveLocation = 394 | Gen.element 395 | [ EDLQUERY, 396 | EDLMUTATION, 397 | EDLSUBSCRIPTION, 398 | EDLFIELD, 399 | EDLFRAGMENT_DEFINITION, 400 | EDLFRAGMENT_SPREAD, 401 | EDLINLINE_FRAGMENT 402 | ] 403 | 404 | genTypeSystemDirectiveLocation :: Gen TypeSystemDirectiveLocation 405 | genTypeSystemDirectiveLocation = 406 | Gen.element 407 | [ TSDLSCHEMA, 408 | TSDLSCALAR, 409 | TSDLOBJECT, 410 | TSDLFIELD_DEFINITION, 411 | TSDLARGUMENT_DEFINITION, 412 | TSDLINTERFACE, 413 | TSDLUNION, 414 | TSDLENUM, 415 | TSDLENUM_VALUE, 416 | TSDLINPUT_OBJECT, 417 | TSDLINPUT_FIELD_DEFINITION 418 | ] 419 | 420 | ------------------------------------------------------------------------------- 421 | 422 | -- Structure 423 | 424 | genSelectionSet :: Generator a => Gen (SelectionSet FragmentSpread a) 425 | genSelectionSet = mkListNonEmpty genSelection 426 | 427 | genSelection :: Generator a => Gen (Selection FragmentSpread a) 428 | genSelection = 429 | Gen.recursive 430 | Gen.choice 431 | [ SelectionFragmentSpread <$> genFragmentSpread 432 | ] 433 | [ SelectionField <$> genField, 434 | SelectionInlineFragment <$> genInlineFragment 435 | ] 436 | 437 | genFragmentSpread :: Generator a => Gen (FragmentSpread a) 438 | genFragmentSpread = 439 | FragmentSpread 440 | <$> genName 441 | <*> genDirectives 442 | 443 | genInlineFragment :: Generator a => Gen (InlineFragment FragmentSpread a) 444 | genInlineFragment = 445 | InlineFragment 446 | <$> Gen.maybe genName 447 | <*> genDirectives 448 | <*> genSelectionSet 449 | 450 | genField :: Generator a => Gen (Field FragmentSpread a) 451 | genField = 452 | Field 453 | <$> Gen.maybe genName 454 | <*> genName 455 | <*> (M.fromList <$> mkList genArgument) 456 | <*> genDirectives 457 | <*> genSelectionSet 458 | 459 | genDirective :: Generator a => Gen (Directive a) 460 | genDirective = 461 | Directive 462 | <$> genName 463 | <*> (M.fromList <$> mkList genArgument) 464 | 465 | genDirectives :: Generator a => Gen [Directive a] 466 | genDirectives = mkList genDirective 467 | 468 | genArgument :: Generator a => Gen (Name, Value a) 469 | genArgument = (,) <$> genName <*> genValue 470 | 471 | ------------------------------------------------------------------------------- 472 | 473 | -- Helpers 474 | 475 | mkList :: Gen a -> Gen [a] 476 | mkList = Gen.list $ Range.linear 0 11 477 | 478 | mkListNonEmpty :: Gen a -> Gen [a] 479 | mkListNonEmpty = Gen.list $ Range.linear 1 11 480 | -------------------------------------------------------------------------------- /src/Language/GraphQL/Draft/Printer.hs: -------------------------------------------------------------------------------- 1 | module Language.GraphQL.Draft.Printer where 2 | 3 | ------------------------------------------------------------------------------- 4 | 5 | import Data.Aeson qualified as J 6 | import Data.Bool (bool) 7 | import Data.ByteString.Builder qualified as BS 8 | import Data.ByteString.Builder.Scientific qualified as BSBS 9 | import Data.Char (isControl) 10 | import Data.HashMap.Strict (HashMap) 11 | import Data.HashMap.Strict qualified as M 12 | import Data.Kind (Constraint, Type) 13 | import Data.List (intersperse, sort) 14 | import Data.Scientific (Scientific) 15 | import Data.String (IsString) 16 | import Data.Text (Text) 17 | import Data.Text qualified as T 18 | import Data.Text.Lazy qualified as LT hiding (singleton) 19 | import Data.Text.Lazy.Builder qualified as LT (Builder) 20 | import Data.Text.Lazy.Builder qualified as LTB 21 | import Data.Text.Lazy.Builder.Int qualified as LTBI 22 | import Data.Text.Lazy.Builder.Scientific qualified as LTBS 23 | import Data.Text.Lazy.Encoding qualified as LTE 24 | import Data.Void (Void, absurd) 25 | import Language.GraphQL.Draft.Syntax 26 | import Language.GraphQL.Draft.Syntax.Name qualified as Name 27 | import Prettyprinter qualified as PP 28 | import Text.Builder qualified as Text 29 | import Prelude 30 | 31 | ------------------------------------------------------------------------------- 32 | 33 | type Printer :: Type -> Constraint 34 | class (Monoid a, IsString a) => Printer a where 35 | textP :: Text -> a 36 | charP :: Char -> a 37 | intP :: Integer -> a 38 | doubleP :: Scientific -> a 39 | 40 | {-# MINIMAL textP, charP, intP, doubleP #-} 41 | 42 | nameP :: Name -> a 43 | nameP = textP . Name.unName 44 | 45 | nodeP :: (Print (frag var), Print var) => TypedOperationDefinition frag var -> a 46 | nodeP = node 47 | 48 | selectionSetP :: (Print (frag var), Print var) => SelectionSet frag var -> a 49 | selectionSetP = selectionSet 50 | 51 | instance Printer BS.Builder where 52 | textP = LTE.encodeUtf8Builder . LT.fromStrict 53 | {-# INLINE textP #-} 54 | 55 | charP = BS.charUtf8 56 | {-# INLINE charP #-} 57 | 58 | intP = BS.integerDec 59 | {-# INLINE intP #-} 60 | 61 | doubleP = BSBS.scientificBuilder 62 | {-# INLINE doubleP #-} 63 | 64 | instance Printer LT.Builder where 65 | textP = LTB.fromText 66 | {-# INLINE textP #-} 67 | 68 | charP = LTB.singleton 69 | {-# INLINE charP #-} 70 | 71 | intP = LTBI.decimal 72 | {-# INLINE intP #-} 73 | 74 | doubleP = LTBS.scientificBuilder 75 | {-# INLINE doubleP #-} 76 | 77 | instance Printer (PP.Doc Text) where 78 | textP = PP.pretty 79 | {-# INLINE textP #-} 80 | 81 | charP = PP.pretty 82 | {-# INLINE charP #-} 83 | 84 | intP = PP.pretty 85 | {-# INLINE intP #-} 86 | 87 | -- NOTE: @prettyprinter@ constructs its 'Int', 'Float', etc. instances with 88 | -- 'unsafeViaShow', so it fine for us to use it here since 'Scientific' 89 | -- satisfies the requirement that the 'Show' instance must not have newlines. 90 | doubleP = PP.unsafeViaShow 91 | {-# INLINE doubleP #-} 92 | 93 | nameP = PP.pretty 94 | {-# INLINE nameP #-} 95 | 96 | instance Printer Text.Builder where 97 | textP = Text.text 98 | {-# INLINE textP #-} 99 | 100 | charP = Text.char 101 | {-# INLINE charP #-} 102 | 103 | intP = Text.decimal 104 | {-# INLINE intP #-} 105 | 106 | doubleP = Text.string . show 107 | {-# INLINE doubleP #-} 108 | 109 | type Print :: Type -> Constraint 110 | class Print a where 111 | printP :: Printer b => a -> b 112 | 113 | instance Print Void where 114 | printP = absurd 115 | 116 | instance Print Name where 117 | printP = nameP 118 | 119 | renderExecutableDoc :: ExecutableDocument Name -> Text 120 | renderExecutableDoc = Text.run . executableDocument 121 | 122 | -- | the pretty printer implementation 123 | executableDocument :: (Print var, Printer a) => ExecutableDocument var -> a 124 | executableDocument ed = 125 | mconcat $ 126 | intersperse (charP '\n') $ 127 | map executableDefinition $ 128 | getExecutableDefinitions ed 129 | 130 | executableDefinition :: (Print var, Printer a) => ExecutableDefinition var -> a 131 | executableDefinition = \case 132 | ExecutableDefinitionOperation d -> operationDefinition d 133 | ExecutableDefinitionFragment d -> fragmentDefinition d 134 | 135 | operationDefinition :: (Print (frag var), Print var, Printer a) => OperationDefinition frag var -> a 136 | operationDefinition = \case 137 | OperationDefinitionUnTyped selSet -> selectionSetP selSet 138 | OperationDefinitionTyped op -> typedOperationDefinition op 139 | 140 | typedOperationDefinition :: (Print (frag var), Print var, Printer a) => TypedOperationDefinition frag var -> a 141 | typedOperationDefinition op = 142 | operationType (_todType op) <> charP ' ' <> nodeP op 143 | 144 | operationType :: Printer a => OperationType -> a 145 | operationType = \case 146 | OperationTypeQuery -> "query" 147 | OperationTypeMutation -> "mutation" 148 | OperationTypeSubscription -> "subscription" 149 | 150 | -- TODO: add horizontal nesting 151 | node :: (Print (frag var), Print var, Printer a) => TypedOperationDefinition frag var -> a 152 | node (TypedOperationDefinition _ name vars dirs sels) = 153 | maybe mempty nameP name 154 | <> optempty variableDefinitions vars 155 | <> optempty directives dirs 156 | <> charP ' ' 157 | <> selectionSetP sels 158 | 159 | -- TODO: add horizontal nesting 160 | selectionSet :: (Print (frag var), Print var, Printer a) => SelectionSet frag var -> a 161 | selectionSet [] = mempty 162 | selectionSet xs = 163 | "{ " <> mconcat (intersperse (charP ' ') (map selection xs)) <> " }" 164 | 165 | selection :: (Print (frag var), Print var, Printer a) => Selection frag var -> a 166 | selection = \case 167 | SelectionField fld -> field fld 168 | SelectionFragmentSpread fs -> printP fs 169 | SelectionInlineFragment ilf -> inlineFragment ilf 170 | 171 | field :: (Print (frag var), Print var, Printer a) => Field frag var -> a 172 | field (Field alias name args dirs selSets) = 173 | optAlias alias 174 | <> nameP name 175 | <> optempty arguments args 176 | <> optempty directives dirs 177 | <> charP ' ' 178 | <> selectionSetP selSets 179 | 180 | optAlias :: Printer a => Maybe Name -> a 181 | optAlias = maybe mempty (\a -> nameP a <> textP ": ") 182 | 183 | inlineFragment :: (Print (frag var), Print var, Printer a) => InlineFragment frag var -> a 184 | inlineFragment (InlineFragment tc ds sels) = 185 | "... " 186 | <> maybe mempty ((textP "on " <>) . nameP) tc 187 | <> optempty directives ds 188 | <> selectionSetP sels 189 | 190 | instance Print var => Print (FragmentSpread var) where 191 | printP (FragmentSpread name ds) = 192 | "..." <> nameP name <> optempty directives ds 193 | 194 | instance Print (NoFragments var) where 195 | printP = \case {} 196 | 197 | fragmentDefinition :: Printer a => FragmentDefinition -> a 198 | fragmentDefinition (FragmentDefinition name tc dirs sels) = 199 | "fragment " 200 | <> nameP name 201 | <> " on " 202 | <> nameP tc 203 | <> optempty directives dirs 204 | <> selectionSetP sels 205 | 206 | directives :: (Print var, Printer a) => [Directive var] -> a 207 | directives = mconcat . intersperse (charP ' ') . map directive 208 | 209 | directive :: (Print var, Printer a) => Directive var -> a 210 | directive (Directive name args) = 211 | charP '@' <> nameP name <> optempty arguments args 212 | 213 | arguments :: (Print var, Printer a) => HashMap Name (Value var) -> a 214 | arguments xs = charP '(' <> objectFields xs <> charP ')' 215 | 216 | variableDefinitions :: Printer a => [VariableDefinition] -> a 217 | variableDefinitions vars = 218 | mconcat 219 | [ charP '(', 220 | mconcat vars', 221 | charP ')' 222 | ] 223 | where 224 | vars' = intersperse (charP ',') $ map variableDefinition vars 225 | 226 | variableDefinition :: Printer a => VariableDefinition -> a 227 | variableDefinition (VariableDefinition var ty defVal) = 228 | variableP var <> ": " <> graphQLType ty <> maybe mempty defaultValue defVal 229 | 230 | defaultValue :: Printer a => Value Void -> a 231 | defaultValue v = " = " <> value v 232 | 233 | description :: Printer a => Maybe Description -> a 234 | description Nothing = mempty 235 | description (Just desc) = dispatchStringPrinter (unDescription desc) <> " \n" 236 | 237 | -- | Type Reference 238 | graphQLType :: Printer a => GType -> a 239 | graphQLType (TypeNamed n x) = nameP x <> nonNull n 240 | graphQLType (TypeList n x) = listType x <> nonNull n 241 | 242 | listType :: Printer a => GType -> a 243 | listType ty = charP '[' <> graphQLType ty <> charP ']' 244 | 245 | nonNull :: Printer a => Nullability -> a 246 | nonNull n = bool (charP '!') mempty $ unNullability n 247 | 248 | -- | Primitives 249 | variableP :: (Print a, Printer b) => a -> b 250 | variableP v = charP '$' <> printP v 251 | 252 | value :: (Print var, Printer a) => Value var -> a 253 | value = \case 254 | VVariable v -> variableP v 255 | VInt i -> intP i 256 | VFloat d -> doubleP d 257 | VString s -> dispatchStringPrinter s 258 | VBoolean b -> fromBool b 259 | VNull -> "null" 260 | VList xs -> listValue xs 261 | VObject o -> objectValue o 262 | VEnum ev -> nameP $ unEnumValue ev 263 | 264 | -- | Print a given text as a normal string or as a block string, depending on 265 | -- its content. 266 | dispatchStringPrinter :: Printer a => Text -> a 267 | dispatchStringPrinter t = 268 | if printAsBlockString then blockStringValue t else stringValue t 269 | where 270 | printAsBlockString = 271 | hasNewlines && onlySourceCharacter && not (hasWhitespaceEnd || hasZeroIndentation || hasTripleQuotes) 272 | -- Condition 1: if there are no newlines, there's no point to print a text 273 | -- as a block string 274 | hasNewlines = "\n" `T.isInfixOf` t 275 | -- Condition 2: block strings only support GraphQL's SourceCharacters 276 | -- http://spec.graphql.org/June2018/#SourceCharacter 277 | onlySourceCharacter = T.all isSourceCharacter t 278 | -- Condition 3: if the text ends in a line containing only whitespace, we 279 | -- can't print it as a block string 280 | hasWhitespaceEnd = T.all isWhitespace $ T.takeWhileEnd (/= '\n') t 281 | -- Condition 4: if none of the remaining lines (i.e. not the first line) 282 | -- contains nonzero indentation, we can't print it as a block string 283 | hasZeroIndentation = any lineZeroIndentation $ tail $ T.lines t 284 | where 285 | lineZeroIndentation line = case T.uncons line of 286 | Nothing -> False -- empty lines don't count 287 | Just (firstChar, _) -> not (isWhitespace firstChar) 288 | -- Condition 5: although """ is printable in block strings as \""", this 289 | -- isn't currently implemented 290 | hasTripleQuotes = "\"\"\"" `T.isInfixOf` t 291 | 292 | isWhitespace :: Char -> Bool 293 | isWhitespace c = c == ' ' || c == '\t' 294 | isSourceCharacter :: Char -> Bool 295 | isSourceCharacter = not . isControl 296 | 297 | -- | We use Aeson to decode string values, and therefore use Aeson to encode them back. 298 | stringValue :: Printer a => Text -> a 299 | stringValue s = textP $ LT.toStrict $ LTE.decodeUtf8 $ J.encode s 300 | 301 | blockStringValue :: Printer a => Text -> a 302 | blockStringValue t = textP "\"\"\"\n" <> textP t <> textP "\n\"\"\"" 303 | 304 | listValue :: (Print var, Printer a) => [Value var] -> a 305 | listValue xs = mconcat [charP '[', li, charP ']'] 306 | where 307 | li = mconcat $ intersperse (charP ',') $ map value xs 308 | 309 | objectValue :: (Print var, Printer a) => HashMap Name (Value var) -> a 310 | objectValue o = charP '{' <> objectFields o <> charP '}' 311 | 312 | objectFields :: (Print var, Printer a) => HashMap Name (Value var) -> a 313 | objectFields o = mconcat $ intersperse (charP ',') $ map objectField $ M.toList o 314 | where 315 | objectField (name, val) = nameP name <> ": " <> value val 316 | 317 | fromBool :: Printer a => Bool -> a 318 | fromBool True = "true" 319 | fromBool False = "false" 320 | 321 | optempty :: (Foldable f, Monoid b) => (f a -> b) -> f a -> b 322 | optempty f xs 323 | | null xs = mempty 324 | | otherwise = f xs 325 | 326 | schemaDefinition :: 327 | forall a. 328 | Printer a => 329 | SchemaDefinition -> 330 | a 331 | schemaDefinition (SchemaDefinition dirs rootOpDefs) = 332 | "schema " 333 | <> maybe mempty (optempty directives) dirs 334 | <> " { " 335 | <> mconcat (intersperse (charP ' ') (map rootOperationTypeDefinition rootOpDefs)) 336 | <> " }" 337 | 338 | rootOperationTypeDefinition :: Printer a => RootOperationTypeDefinition -> a 339 | rootOperationTypeDefinition (RootOperationTypeDefinition opType rootName) = 340 | operationType opType <> ": " <> nameP rootName 341 | 342 | typeSystemDefinition :: Printer a => TypeSystemDefinition -> a 343 | typeSystemDefinition (TypeSystemDefinitionSchema schemaDefn) = schemaDefinition schemaDefn 344 | typeSystemDefinition (TypeSystemDefinitionType typeDefn) = typeDefinitionP typeDefn 345 | 346 | schemaDocument :: Printer a => SchemaDocument -> a 347 | schemaDocument (SchemaDocument typeDefns) = 348 | mconcat $ intersperse (textP "\n\n") $ map typeSystemDefinition $ sort typeDefns 349 | 350 | typeDefinitionP :: Printer a => TypeDefinition () InputValueDefinition -> a 351 | typeDefinitionP (TypeDefinitionScalar scalarDefn) = scalarTypeDefinition scalarDefn 352 | typeDefinitionP (TypeDefinitionObject objDefn) = objectTypeDefinition objDefn 353 | typeDefinitionP (TypeDefinitionInterface interfaceDefn) = interfaceTypeDefinition interfaceDefn 354 | typeDefinitionP (TypeDefinitionUnion unionDefn) = unionTypeDefinition unionDefn 355 | typeDefinitionP (TypeDefinitionEnum enumDefn) = enumTypeDefinition enumDefn 356 | typeDefinitionP (TypeDefinitionInputObject inpObjDefn) = inputObjectTypeDefinition inpObjDefn 357 | 358 | scalarTypeDefinition :: Printer a => ScalarTypeDefinition -> a 359 | scalarTypeDefinition (ScalarTypeDefinition desc name dirs) = 360 | description desc 361 | <> "scalar " 362 | <> nameP name 363 | <> if null dirs 364 | then mempty 365 | else charP ' ' <> optempty directives dirs 366 | 367 | inputValueDefinition :: Printer a => InputValueDefinition -> a 368 | inputValueDefinition (InputValueDefinition desc name gType defVal dirs) = 369 | description desc 370 | <> nameP name 371 | <> textP ": " 372 | <> graphQLType gType 373 | <> maybe mempty defaultValue defVal 374 | <> if null dirs 375 | then mempty 376 | else charP ' ' <> optempty directives dirs 377 | 378 | fieldDefinition :: Printer a => FieldDefinition InputValueDefinition -> a 379 | fieldDefinition (FieldDefinition desc name args gType dirs) = 380 | description desc 381 | <> nameP name 382 | <> case args of 383 | [] -> mempty 384 | _ -> 385 | charP '(' 386 | <> mconcat (intersperse (textP ", ") $ map inputValueDefinition args) 387 | <> charP ')' 388 | <> textP ": " 389 | <> graphQLType gType 390 | <> optempty directives dirs 391 | 392 | objectTypeDefinition :: Printer a => ObjectTypeDefinition InputValueDefinition -> a 393 | objectTypeDefinition (ObjectTypeDefinition desc name ifaces dirs fieldDefinitions) = 394 | description desc 395 | <> "type " 396 | <> nameP name 397 | <> optempty directives dirs 398 | <> case ifaces of 399 | [] -> mempty 400 | _ -> " implements " <> mconcat (intersperse (textP " & ") $ map nameP ifaces) 401 | <> " { " 402 | <> ( mconcat 403 | . intersperse (textP "\n ") 404 | . map fieldDefinition 405 | . sort 406 | $ fieldDefinitions 407 | ) 408 | <> "\n" 409 | <> "}" 410 | 411 | interfaceTypeDefinition :: Printer a => InterfaceTypeDefinition () InputValueDefinition -> a 412 | interfaceTypeDefinition (InterfaceTypeDefinition desc name dirs fieldDefinitions _possibleTypes) = 413 | -- `possibleTypes` are not included with an interface definition in a GraphQL IDL 414 | description desc 415 | <> "interface " 416 | <> nameP name 417 | <> charP ' ' 418 | <> optempty directives dirs 419 | <> " { " 420 | <> mconcat 421 | ( intersperse (textP "\n ") 422 | . map fieldDefinition 423 | . sort 424 | $ fieldDefinitions 425 | ) 426 | <> "\n" 427 | <> "}" 428 | 429 | unionTypeDefinition :: Printer a => UnionTypeDefinition -> a 430 | unionTypeDefinition (UnionTypeDefinition desc name dirs members) = 431 | description desc 432 | <> "union " 433 | <> nameP name 434 | <> charP ' ' 435 | <> optempty directives dirs 436 | <> textP " = " 437 | <> mconcat (intersperse (textP " | ") $ map nameP $ sort members) 438 | 439 | enumValueDefinition :: Printer a => EnumValueDefinition -> a 440 | enumValueDefinition (EnumValueDefinition desc name dirs) = 441 | description desc 442 | <> nameP (unEnumValue name) 443 | <> charP ' ' 444 | <> optempty directives dirs 445 | 446 | enumTypeDefinition :: Printer a => EnumTypeDefinition -> a 447 | enumTypeDefinition (EnumTypeDefinition desc name dirs enumValDefns) = 448 | description desc 449 | <> "enum " 450 | <> nameP name 451 | <> optempty directives dirs 452 | <> " {" 453 | <> mconcat 454 | ( intersperse (textP "\n ") 455 | . map enumValueDefinition 456 | . sort 457 | $ enumValDefns 458 | ) 459 | <> "\n" 460 | <> "}" 461 | 462 | inputObjectTypeDefinition :: Printer a => InputObjectTypeDefinition InputValueDefinition -> a 463 | inputObjectTypeDefinition (InputObjectTypeDefinition desc name dirs valDefns) = 464 | description desc 465 | <> "input " 466 | <> nameP name 467 | <> optempty directives dirs 468 | <> " {" 469 | <> mconcat 470 | ( intersperse (textP "\n ") 471 | . map inputValueDefinition 472 | . sort 473 | $ valDefns 474 | ) 475 | <> "\n" 476 | <> "}" 477 | -------------------------------------------------------------------------------- /src/Language/GraphQL/Draft/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Description: Parse text into GraphQL ASTs 5 | module Language.GraphQL.Draft.Parser 6 | ( executableDocument, 7 | parseExecutableDoc, 8 | schemaDocument, 9 | parseTypeSystemDefinitions, 10 | parseSchemaDocument, 11 | Variable (..), 12 | value, 13 | PossibleTypes (..), 14 | nameParser, 15 | graphQLType, 16 | parseGraphQLType, 17 | Parser, 18 | runParser, 19 | blockString, 20 | field, 21 | ) 22 | where 23 | 24 | ------------------------------------------------------------------------------- 25 | 26 | import Control.Applicative (empty, many, optional, (<|>)) 27 | import Control.Monad (foldM, guard) 28 | import Data.Aeson.Parser (jstring) 29 | import Data.Attoparsec.ByteString qualified as A 30 | import Data.Attoparsec.Text 31 | ( Parser, 32 | anyChar, 33 | char, 34 | many1, 35 | match, 36 | option, 37 | scan, 38 | scientific, 39 | sepBy1, 40 | (), 41 | ) 42 | import Data.Attoparsec.Text qualified as AT 43 | import Data.Char 44 | ( isAsciiLower, 45 | isAsciiUpper, 46 | isDigit, 47 | ) 48 | import Data.Functor (($>)) 49 | import Data.HashMap.Strict (HashMap) 50 | import Data.HashMap.Strict qualified as M 51 | import Data.Kind (Constraint, Type) 52 | import Data.Maybe (fromMaybe) 53 | import Data.Scientific (Scientific) 54 | import Data.Text (Text, find) 55 | import Data.Text qualified as T 56 | import Data.Text.Encoding (encodeUtf8) 57 | import Data.Void (Void) 58 | import Language.GraphQL.Draft.Syntax qualified as AST 59 | import Language.GraphQL.Draft.Syntax.Name qualified as Name 60 | import Prelude 61 | 62 | ------------------------------------------------------------------------------- 63 | 64 | -- * Document 65 | 66 | executableDocument :: Parser (AST.ExecutableDocument AST.Name) 67 | executableDocument = whiteSpace *> (AST.ExecutableDocument <$> many1 definitionExecutable) 68 | 69 | runParser :: AT.Parser a -> Text -> Either Text a 70 | runParser parser t = 71 | either (Left . T.pack) return $ AT.parseOnly (parser <* AT.endOfInput) t 72 | 73 | parseExecutableDoc :: Text -> Either Text (AST.ExecutableDocument AST.Name) 74 | parseExecutableDoc = runParser executableDocument 75 | 76 | -- | Parser for a schema document. 77 | schemaDocument :: Parser AST.SchemaDocument 78 | schemaDocument = whiteSpace *> (AST.SchemaDocument <$> many1 typeSystemDefinition) 79 | 80 | parseSchemaDocument :: Text -> Either Text AST.SchemaDocument 81 | parseSchemaDocument = runParser schemaDocument 82 | 83 | definitionExecutable :: Parser (AST.ExecutableDefinition AST.Name) 84 | definitionExecutable = 85 | AST.ExecutableDefinitionOperation <$> operationDefinition 86 | <|> AST.ExecutableDefinitionFragment <$> fragmentDefinition 87 | 88 | operationDefinition :: Parser (AST.OperationDefinition AST.FragmentSpread AST.Name) 89 | operationDefinition = 90 | AST.OperationDefinitionTyped <$> typedOperationDef 91 | <|> (AST.OperationDefinitionUnTyped <$> selectionSet) 92 | 93 | operationTypeParser :: Parser AST.OperationType 94 | operationTypeParser = 95 | AST.OperationTypeQuery <$ tok "query" 96 | <|> AST.OperationTypeMutation <$ tok "mutation" 97 | <|> AST.OperationTypeSubscription <$ tok "subscription" 98 | 99 | typedOperationDef :: Parser (AST.TypedOperationDefinition AST.FragmentSpread AST.Name) 100 | typedOperationDef = 101 | AST.TypedOperationDefinition 102 | <$> operationTypeParser 103 | <*> optional nameParser 104 | <*> optempty variableDefinitions 105 | <*> optempty directives 106 | <*> selectionSet 107 | 108 | variableDefinitions :: Parser [AST.VariableDefinition] 109 | variableDefinitions = parens (many1 variableDefinition) 110 | 111 | variableDefinition :: Parser AST.VariableDefinition 112 | variableDefinition = 113 | AST.VariableDefinition <$> variable 114 | <* tok ":" 115 | <*> graphQLType 116 | <*> optional defaultValue 117 | 118 | defaultValue :: Parser (AST.Value Void) 119 | defaultValue = tok "=" *> value 120 | 121 | type Variable :: Type -> Constraint 122 | class Variable var where 123 | variable :: Parser var 124 | 125 | instance Variable Void where 126 | variable = empty 127 | 128 | instance Variable AST.Name where 129 | variable = tok "$" *> nameParser "variable" 130 | 131 | type PossibleTypes :: Type -> Constraint 132 | class PossibleTypes pos where 133 | possibleTypes :: Parser pos 134 | 135 | instance PossibleTypes () where 136 | possibleTypes = pure () 137 | 138 | selectionSet :: Variable var => Parser (AST.SelectionSet AST.FragmentSpread var) 139 | selectionSet = braces $ many1 selection 140 | 141 | selection :: Variable var => Parser (AST.Selection AST.FragmentSpread var) 142 | selection = 143 | AST.SelectionField <$> field 144 | -- Inline first to catch `on` case 145 | <|> AST.SelectionInlineFragment <$> inlineFragment 146 | <|> AST.SelectionFragmentSpread <$> fragmentSpread 147 | 148 | aliasAndFld :: Parser (Maybe AST.Name, AST.Name) 149 | aliasAndFld = do 150 | n <- nameParser 151 | colonM <- optional (tok ":") 152 | case colonM of 153 | Just _ -> (Just n,) <$> nameParser 154 | Nothing -> return (Nothing, n) 155 | {-# INLINE aliasAndFld #-} 156 | 157 | field :: Variable var => Parser (AST.Field AST.FragmentSpread var) 158 | field = do 159 | (alM, n) <- aliasAndFld 160 | AST.Field alM n 161 | <$> optempty arguments 162 | <*> optempty directives 163 | <*> optempty selectionSet 164 | 165 | -- * Fragments 166 | 167 | fragmentSpread :: Variable var => Parser (AST.FragmentSpread var) 168 | -- TODO: Make sure it fails when `... on`. 169 | -- See https://facebook.github.io/graphql/#FragmentSpread 170 | fragmentSpread = 171 | AST.FragmentSpread 172 | <$ tok "..." 173 | <*> nameParser 174 | <*> optempty directives 175 | 176 | -- InlineFragment tried first in order to guard against 'on' keyword 177 | inlineFragment :: Variable var => Parser (AST.InlineFragment AST.FragmentSpread var) 178 | inlineFragment = 179 | AST.InlineFragment 180 | <$ tok "..." 181 | <*> optional (tok "on" *> nameParser) 182 | <*> optempty directives 183 | <*> selectionSet 184 | 185 | fragmentDefinition :: Parser AST.FragmentDefinition 186 | fragmentDefinition = 187 | AST.FragmentDefinition 188 | <$ tok "fragment" 189 | <*> nameParser 190 | <* tok "on" 191 | <*> nameParser 192 | <*> optempty directives 193 | <*> selectionSet 194 | 195 | -- * Values 196 | 197 | number :: Parser (Either Scientific Integer) 198 | number = do 199 | (numText, num) <- match (tok scientific) 200 | pure $ case Data.Text.find (\c -> c == '.' || c == 'e' || c == 'E') numText of 201 | -- Number specified with decimals and/or scientific notation, so 202 | -- store as a 'Scientific'. 203 | Just _ -> Left num 204 | -- No '.' and not in scientific notation, so safe to convert to integer. 205 | Nothing -> Right (floor num) 206 | 207 | -- This will try to pick the first type it can runParser. If you are working with 208 | -- explicit types use the `typedValue` parser. 209 | value :: Variable var => Parser (AST.Value var) 210 | value = 211 | tok 212 | ( AST.VVariable <$> variable 213 | <|> (fmap (either AST.VFloat AST.VInt) number "number") 214 | <|> AST.VNull <$ literal "null" 215 | <|> AST.VBoolean <$> booleanLiteral 216 | <|> AST.VString <$> blockString 217 | <|> AST.VString <$> stringLiteral 218 | -- `true` and `false` have been tried before, so we can safely proceed with the enum parser 219 | <|> AST.VEnum <$> (fmap AST.EnumValue nameParser "name") 220 | <|> AST.VList <$> listLiteral 221 | <|> AST.VObject <$> objectLiteral 222 | "value" 223 | ) 224 | 225 | booleanLiteral :: Parser Bool 226 | booleanLiteral = 227 | True <$ literal "true" 228 | <|> False <$ literal "false" 229 | "boolean" 230 | 231 | stringLiteral :: Parser Text 232 | stringLiteral = unescapeText =<< (char '"' *> jstring_ "string") 233 | where 234 | -- Parse a string without a leading quote, ignoring any escaped characters. 235 | jstring_ :: Parser Text 236 | jstring_ = scan False go <* anyChar 237 | go :: Bool -> Char -> Maybe Bool 238 | go previousWasEscapingCharacter current 239 | -- if the previous character was an escaping character, we skip this one 240 | | previousWasEscapingCharacter = Just False 241 | -- otherwise, if we find an unescaped quote, we've reached the end 242 | | current == '"' = Nothing 243 | -- otherwise, we continue, and track whether the current character is an escaping backslash 244 | | otherwise = Just $ current == backslash 245 | where 246 | backslash = '\\' 247 | 248 | -- Unescape a string. 249 | -- 250 | -- Turns out this is really tricky, so we're going to cheat by 251 | -- reconstructing a literal string (by putting quotes around it) and 252 | -- delegating all the hard work to Aeson. 253 | unescapeText :: Text -> Parser Text 254 | unescapeText str = either fail pure $ A.parseOnly jstring ("\"" <> encodeUtf8 str <> "\"") 255 | 256 | listLiteral :: Variable var => Parser [AST.Value var] 257 | listLiteral = brackets (many value) "list" 258 | 259 | objectLiteral :: Variable var => Parser (HashMap AST.Name (AST.Value var)) 260 | objectLiteral = braces (objectFields many) "object" 261 | 262 | arguments :: Variable var => Parser (HashMap AST.Name (AST.Value var)) 263 | arguments = parens (objectFields many1) "arguments" 264 | 265 | objectFields :: 266 | Variable var => 267 | (forall b. Parser b -> Parser [b]) -> 268 | Parser (HashMap AST.Name (AST.Value var)) 269 | objectFields several = foldM insertField M.empty =<< several objectField 270 | where 271 | objectField = (,) <$> nameParser <* tok ":" <*> value 272 | insertField obj (k, v) 273 | | k `M.member` obj = fail $ "multiple “" <> T.unpack (Name.unName k) <> "” fields" 274 | | otherwise = pure (M.insert k v obj) 275 | 276 | -- * Directives 277 | 278 | directives :: Variable var => Parser [AST.Directive var] 279 | directives = many1 directive 280 | 281 | directive :: Variable var => Parser (AST.Directive var) 282 | directive = 283 | AST.Directive 284 | <$ tok "@" 285 | <*> nameParser 286 | <*> optempty arguments 287 | 288 | -- * Type Reference 289 | 290 | graphQLType :: Parser AST.GType 291 | graphQLType = 292 | (flip AST.TypeList <$> brackets graphQLType <*> nullability) 293 | <|> (flip AST.TypeNamed <$> nameParser <*> nullability) 294 | "type" 295 | 296 | parseGraphQLType :: Text -> Either Text AST.GType 297 | parseGraphQLType = runParser graphQLType 298 | 299 | nullability :: Parser AST.Nullability 300 | nullability = 301 | (tok "!" $> AST.Nullability False) 302 | <|> pure (AST.Nullability True) 303 | 304 | -- * Type Definition 305 | 306 | rootOperationTypeDefinition :: Parser AST.RootOperationTypeDefinition 307 | rootOperationTypeDefinition = 308 | AST.RootOperationTypeDefinition <$> operationTypeParser <* tok ":" <*> nameParser 309 | 310 | schemaDefinition :: Parser AST.SchemaDefinition 311 | schemaDefinition = 312 | AST.SchemaDefinition 313 | <$ tok "schema" 314 | <*> optional directives 315 | <*> rootOperationTypeDefinitions 316 | 317 | rootOperationTypeDefinitions :: Parser [AST.RootOperationTypeDefinition] 318 | rootOperationTypeDefinitions = braces $ many1 rootOperationTypeDefinition 319 | 320 | typeSystemDefinition :: Parser AST.TypeSystemDefinition 321 | typeSystemDefinition = 322 | AST.TypeSystemDefinitionSchema <$> schemaDefinition 323 | <|> AST.TypeSystemDefinitionType <$> typeDefinition 324 | 325 | parseTypeSystemDefinitions :: Text -> Either Text [AST.TypeSystemDefinition] 326 | parseTypeSystemDefinitions = runParser $ many1 typeSystemDefinition 327 | 328 | typeDefinition :: Parser (AST.TypeDefinition () AST.InputValueDefinition) 329 | typeDefinition = 330 | AST.TypeDefinitionObject <$> objectTypeDefinition 331 | <|> AST.TypeDefinitionInterface <$> interfaceTypeDefinition 332 | <|> AST.TypeDefinitionUnion <$> unionTypeDefinition 333 | <|> AST.TypeDefinitionScalar <$> scalarTypeDefinition 334 | <|> AST.TypeDefinitionEnum <$> enumTypeDefinition 335 | <|> AST.TypeDefinitionInputObject <$> inputObjectTypeDefinition 336 | "type definition" 337 | 338 | optDesc :: Parser (Maybe AST.Description) 339 | optDesc = optional (AST.Description <$> (blockString <|> stringLiteral)) 340 | 341 | objectTypeDefinition :: Parser (AST.ObjectTypeDefinition AST.InputValueDefinition) 342 | objectTypeDefinition = 343 | AST.ObjectTypeDefinition 344 | <$> optDesc 345 | <* whiteSpace 346 | <* tok "type" 347 | <*> nameParser 348 | <*> optempty interfaces 349 | <*> optempty directives 350 | <*> fieldDefinitions 351 | 352 | interfaces :: Parser [AST.Name] 353 | interfaces = tok "implements" *> nameParser `sepBy1` tok "&" 354 | 355 | fieldDefinitions :: Parser [AST.FieldDefinition AST.InputValueDefinition] 356 | fieldDefinitions = braces $ many1 fieldDefinition 357 | 358 | fieldDefinition :: Parser (AST.FieldDefinition AST.InputValueDefinition) 359 | fieldDefinition = 360 | AST.FieldDefinition 361 | <$> optDesc 362 | <* whiteSpace 363 | <*> nameParser 364 | <*> optempty argumentsDefinition 365 | <* tok ":" 366 | <*> graphQLType 367 | <*> optempty directives 368 | 369 | argumentsDefinition :: Parser (AST.ArgumentsDefinition AST.InputValueDefinition) 370 | argumentsDefinition = parens $ many1 inputValueDefinition 371 | 372 | interfaceTypeDefinition :: PossibleTypes pos => Parser (AST.InterfaceTypeDefinition pos AST.InputValueDefinition) 373 | interfaceTypeDefinition = 374 | AST.InterfaceTypeDefinition 375 | <$> optDesc 376 | <* whiteSpace 377 | <* tok "interface" 378 | <*> nameParser 379 | <*> optempty directives 380 | <*> fieldDefinitions 381 | <*> possibleTypes 382 | 383 | unionTypeDefinition :: Parser AST.UnionTypeDefinition 384 | unionTypeDefinition = 385 | AST.UnionTypeDefinition 386 | <$> optDesc 387 | <* whiteSpace 388 | <* tok "union" 389 | <*> nameParser 390 | <*> optempty directives 391 | <* tok "=" 392 | <*> unionMembers 393 | 394 | unionMembers :: Parser [AST.Name] 395 | unionMembers = nameParser `sepBy1` tok "|" 396 | 397 | scalarTypeDefinition :: Parser AST.ScalarTypeDefinition 398 | scalarTypeDefinition = 399 | AST.ScalarTypeDefinition 400 | <$> optDesc 401 | <* whiteSpace 402 | <* tok "scalar" 403 | <*> nameParser 404 | <*> optempty directives 405 | 406 | enumTypeDefinition :: Parser AST.EnumTypeDefinition 407 | enumTypeDefinition = 408 | AST.EnumTypeDefinition 409 | <$> optDesc 410 | <* whiteSpace 411 | <* tok "enum" 412 | <*> nameParser 413 | <*> optempty directives 414 | <*> enumValueDefinitions 415 | 416 | enumValueDefinitions :: Parser [AST.EnumValueDefinition] 417 | enumValueDefinitions = braces $ many1 enumValueDefinition 418 | 419 | enumValueDefinition :: Parser AST.EnumValueDefinition 420 | enumValueDefinition = 421 | AST.EnumValueDefinition 422 | <$> optDesc 423 | <* whiteSpace 424 | <*> enumValue 425 | <*> optempty directives 426 | 427 | -- TODO: should not be one of true/false/null 428 | enumValue :: Parser AST.EnumValue 429 | enumValue = AST.EnumValue <$> nameParser 430 | 431 | inputObjectTypeDefinition :: Parser (AST.InputObjectTypeDefinition AST.InputValueDefinition) 432 | inputObjectTypeDefinition = 433 | AST.InputObjectTypeDefinition 434 | <$> optDesc 435 | <* whiteSpace 436 | <* tok "input" 437 | <*> nameParser 438 | <*> optempty directives 439 | <*> inputValueDefinitions 440 | 441 | inputValueDefinitions :: Parser [AST.InputValueDefinition] 442 | inputValueDefinitions = braces $ many1 inputValueDefinition 443 | 444 | inputValueDefinition :: Parser AST.InputValueDefinition 445 | inputValueDefinition = 446 | AST.InputValueDefinition 447 | <$> optDesc 448 | <* whiteSpace 449 | <*> nameParser 450 | <* tok ":" 451 | <*> graphQLType 452 | <*> optional defaultValue 453 | <*> optempty directives 454 | 455 | -- * Internal 456 | 457 | tok :: AT.Parser a -> AT.Parser a 458 | tok p = p <* whiteSpace 459 | {-# INLINE tok #-} 460 | 461 | -- | 462 | -- Literal functions in the same fashion as `tok`, 463 | -- however there are issues using `tok` when the token may be followed by additional /a-z0-9/i characters. 464 | -- This manifests in bugs such as #20 where columns in on_conflict clauses prefixed with keywords 465 | -- e.g. "nullColumn" actually end up parsing as "[null, Column]". 466 | -- 467 | -- Adding in a seperate lexing pass would probably be the right way to resolve this behaviour. 468 | -- This is a simple initial fix to address the bug with more involved changes being able to be 469 | -- considered seperately. 470 | literal :: AT.Parser a -> AT.Parser a 471 | literal p = p <* ends <* whiteSpace 472 | {-# INLINE literal #-} 473 | 474 | ends :: AT.Parser () 475 | ends = do 476 | mc <- AT.peekChar 477 | case mc of 478 | Nothing -> pure () 479 | Just c -> guard (not (isNonFirstChar c)) 480 | 481 | comment :: Parser () 482 | comment = 483 | AT.char '#' 484 | *> AT.skipWhile (\c -> c /= '\n' && c /= '\r') 485 | {-# INLINE comment #-} 486 | 487 | isSpaceLike :: Char -> Bool 488 | isSpaceLike c = 489 | c == '\t' || c == ' ' || c == '\n' || c == '\r' || c == ',' 490 | {-# INLINE isSpaceLike #-} 491 | 492 | whiteSpace :: AT.Parser () 493 | whiteSpace = do 494 | AT.skipWhile isSpaceLike 495 | (comment *> whiteSpace) <|> pure () 496 | 497 | nameParser :: AT.Parser AST.Name 498 | nameParser = 499 | AST.unsafeMkName 500 | <$> tok 501 | ( (<>) <$> AT.takeWhile1 isFirstChar 502 | <*> AT.takeWhile isNonFirstChar 503 | ) 504 | {-# INLINE nameParser #-} 505 | 506 | isFirstChar :: Char -> Bool 507 | isFirstChar x = isAsciiLower x || isAsciiUpper x || x == '_' 508 | {-# INLINE isFirstChar #-} 509 | 510 | isNonFirstChar :: Char -> Bool 511 | isNonFirstChar x = isFirstChar x || isDigit x 512 | {-# INLINE isNonFirstChar #-} 513 | 514 | parens :: Parser a -> Parser a 515 | parens = between "(" ")" 516 | 517 | braces :: Parser a -> Parser a 518 | braces = between "{" "}" 519 | 520 | brackets :: Parser a -> Parser a 521 | brackets = between "[" "]" 522 | 523 | between :: Parser Text -> Parser Text -> Parser a -> Parser a 524 | between open close p = tok open *> p <* tok close 525 | 526 | -- `empty` /= `pure mempty` for `Parser`. 527 | optempty :: Monoid a => Parser a -> Parser a 528 | optempty = option mempty 529 | 530 | type Expecting :: Type 531 | data Expecting 532 | = Anything 533 | | Open 534 | | Closed 535 | 536 | type BlockState :: Type 537 | data BlockState 538 | = Escaped Expecting 539 | | Quoting Expecting 540 | | Continue 541 | | Done 542 | 543 | -- | Parses strings delimited by triple quotes. 544 | -- http://spec.graphql.org/June2018/#sec-String-Value 545 | blockString :: Parser Text 546 | blockString = extractText <$> ("\"\"\"" *> blockContents) 547 | where 548 | blockContents = 549 | AT.runScanner Continue scanner >>= \case 550 | -- this drop the parsed closing quotes (since we are using a different parser) 551 | (textBlock, Done) -> return $ T.lines (T.dropEnd 3 textBlock) 552 | -- there is only one way to get to a Done, so we need this here because runScanner never fails 553 | _ -> fail "couldn't parse block string" 554 | 555 | extractText = 556 | -- The reason we have this replace here is to convert 557 | -- an escaped triple-quotes to the way it should be 558 | -- represented in the parsed strings. The printer will 559 | -- deal with it normally. 560 | T.replace "\\\"\"\"" "\"\"\"" . \case 561 | [] -> "" 562 | -- we keep the first line apart as, per the specification, it should not count for 563 | -- the calculation of the common minimum indentation: 564 | -- see item 3.a in http://spec.graphql.org/June2018/#BlockStringValue() 565 | headline : indentedRemainder -> 566 | let commonIndentation = minimum $ (maxBound :) $ countIndentation <$> indentedRemainder 567 | rlines = T.drop commonIndentation <$> indentedRemainder 568 | in rebuild (sanitize $ headline : rlines) 569 | 570 | -- Take characters from the block string until the first 571 | -- non-escaped triple quotes. 572 | scanner :: BlockState -> Char -> Maybe BlockState 573 | scanner s ch = 574 | case s of 575 | Done -> Nothing 576 | Continue -> 577 | case ch of 578 | '\\' -> Just (Escaped Anything) 579 | '"' -> Just (Quoting Open) 580 | _ -> Just Continue 581 | -- we are counting " for a possible closing delimiter 582 | Quoting Open -> if ch == '"' then Just (Quoting Closed) else Just Continue 583 | Quoting Closed -> if ch == '"' then Just Done else Just Continue 584 | Quoting _ -> Just Continue 585 | -- we are counting escaped characters when " 586 | Escaped Anything -> if ch == '"' then Just (Escaped Open) else Just Continue 587 | Escaped Open -> if ch == '"' then Just (Escaped Closed) else Just Continue 588 | Escaped Closed -> Just Continue 589 | 590 | -- Joins all the lines into a single block of text 591 | -- we drop the last new line character that is added 592 | -- automatically by T.unlines 593 | rebuild :: [Text] -> Text 594 | rebuild = maybe "" fst . T.unsnoc . T.unlines 595 | 596 | sanitize :: [Text] -> [Text] 597 | sanitize = dropWhileEnd' onlyWhiteSpace . dropWhile onlyWhiteSpace 598 | 599 | onlyWhiteSpace :: Text -> Bool 600 | onlyWhiteSpace = T.all isWhitespace 601 | 602 | countIndentation :: Text -> Int 603 | countIndentation = fromMaybe maxBound . T.findIndex (not . isWhitespace) 604 | 605 | -- whitespace 606 | isWhitespace :: Char -> Bool 607 | isWhitespace c = c == ' ' || c == '\t' 608 | 609 | -- copied from https://hackage.haskell.org/package/extra-1.7.9/docs/src/Data.List.Extra.html 610 | dropWhileEnd' :: (a -> Bool) -> [a] -> [a] 611 | dropWhileEnd' p = foldr (\x xs -> if null xs && p x then [] else x : xs) [] 612 | -------------------------------------------------------------------------------- /src/Language/GraphQL/Draft/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | -- | Description: The GraphQL AST 5 | module Language.GraphQL.Draft.Syntax 6 | ( -- * Basics 7 | Name, 8 | unName, 9 | mkName, 10 | unsafeMkName, 11 | parseName, 12 | litName, 13 | isValidName, 14 | NameSuffix, 15 | unNameSuffix, 16 | mkNameSuffix, 17 | addSuffixes, 18 | convertNameToSuffix, 19 | parseSuffix, 20 | litSuffix, 21 | litGQLIdentifier, 22 | Description (..), 23 | Value (..), 24 | literal, 25 | EnumValue (..), 26 | Directive (..), 27 | 28 | -- * Types 29 | GType (..), 30 | getBaseType, 31 | Nullability (..), 32 | showGT, 33 | showLT, 34 | isNullable, 35 | isNotNull, 36 | isListType, 37 | 38 | -- * Documents 39 | Document (..), 40 | ExecutableDocument (..), 41 | SchemaDocument (..), 42 | SchemaIntrospection (..), 43 | 44 | -- * Definitions 45 | Definition (..), 46 | DirectiveDefinition (..), 47 | DirectiveLocation (..), 48 | 49 | -- ** Type system definitions 50 | TypeSystemDefinition (..), 51 | SchemaDefinition (..), 52 | RootOperationTypeDefinition (..), 53 | TypeDefinition (..), 54 | ObjectTypeDefinition (..), 55 | FieldDefinition (..), 56 | ArgumentsDefinition, 57 | InputValueDefinition (..), 58 | InterfaceTypeDefinition (..), 59 | UnionTypeDefinition (..), 60 | ScalarTypeDefinition (..), 61 | EnumTypeDefinition (..), 62 | EnumValueDefinition (..), 63 | InputObjectTypeDefinition (..), 64 | TypeSystemDirectiveLocation (..), 65 | 66 | -- ** Executable definitions 67 | ExecutableDefinition (..), 68 | partitionExDefs, 69 | OperationDefinition (..), 70 | OperationType (..), 71 | TypedOperationDefinition (..), 72 | VariableDefinition (..), 73 | ExecutableDirectiveLocation (..), 74 | FragmentDefinition (..), 75 | 76 | -- * Queries 77 | SelectionSet, 78 | Selection (..), 79 | Field (..), 80 | FragmentSpread (..), 81 | NoFragments, 82 | InlineFragment (..), 83 | 84 | -- ** Fragment conversion functions 85 | inline, 86 | fmapFieldFragment, 87 | fmapSelectionSetFragment, 88 | fmapSelectionFragment, 89 | fmapInlineFragment, 90 | ) 91 | where 92 | 93 | ------------------------------------------------------------------------------- 94 | 95 | import Control.DeepSeq (NFData) 96 | import Data.Aeson qualified as J 97 | import Data.Bifunctor (Bifunctor (bimap)) 98 | import Data.Bool (bool) 99 | import Data.HashMap.Strict (HashMap) 100 | import Data.Hashable (Hashable) 101 | import Data.Kind (Type) 102 | import Data.Scientific (Scientific) 103 | import Data.String (IsString (..)) 104 | import Data.Text (Text) 105 | import Data.Void (Void, absurd) 106 | import GHC.Generics (Generic) 107 | import Instances.TH.Lift () 108 | import {-# SOURCE #-} Language.GraphQL.Draft.Parser 109 | ( parseExecutableDoc, 110 | parseSchemaDocument, 111 | ) 112 | import {-# SOURCE #-} Language.GraphQL.Draft.Printer (renderExecutableDoc) 113 | import Language.GraphQL.Draft.Syntax.Internal (liftTypedHashMap) 114 | import Language.GraphQL.Draft.Syntax.Name 115 | import Language.Haskell.TH.Syntax (Lift) 116 | import Language.Haskell.TH.Syntax qualified as TH 117 | import Prelude 118 | 119 | ------------------------------------------------------------------------------- 120 | 121 | -- * Documents 122 | 123 | type Document :: Type 124 | newtype Document = Document {getDefinitions :: [Definition]} 125 | deriving stock (Eq, Lift, Ord, Show) 126 | 127 | type Definition :: Type 128 | data Definition 129 | = DefinitionExecutable (ExecutableDefinition Name) 130 | | DefinitionTypeSystem TypeSystemDefinition 131 | deriving stock (Eq, Generic, Lift, Ord, Show) 132 | 133 | instance Hashable Definition 134 | 135 | type ExecutableDocument :: Type -> Type 136 | newtype ExecutableDocument var = ExecutableDocument {getExecutableDefinitions :: [ExecutableDefinition var]} 137 | deriving stock (Eq, Lift, Ord, Show, Functor, Foldable, Traversable) 138 | deriving newtype (Hashable, NFData) 139 | 140 | instance J.FromJSON (ExecutableDocument Name) where 141 | parseJSON = J.withText "ExecutableDocument" $ \t -> 142 | case parseExecutableDoc t of 143 | Right a -> return a 144 | Left _ -> fail "parsing the graphql query failed" 145 | 146 | instance J.ToJSON (ExecutableDocument Name) where 147 | toJSON = J.String . renderExecutableDoc 148 | 149 | type ExecutableDefinition :: Type -> Type 150 | data ExecutableDefinition var 151 | = ExecutableDefinitionOperation (OperationDefinition FragmentSpread var) 152 | | ExecutableDefinitionFragment FragmentDefinition 153 | deriving stock (Eq, Generic, Lift, Ord, Show, Functor, Foldable, Traversable) 154 | 155 | instance Hashable var => Hashable (ExecutableDefinition var) 156 | 157 | instance NFData var => NFData (ExecutableDefinition var) 158 | 159 | partitionExDefs :: 160 | [ExecutableDefinition var] -> 161 | ( [SelectionSet FragmentSpread var], 162 | [TypedOperationDefinition FragmentSpread var], 163 | [FragmentDefinition] 164 | ) 165 | partitionExDefs = foldr f ([], [], []) 166 | where 167 | f d (selSets, ops, frags) = case d of 168 | ExecutableDefinitionOperation (OperationDefinitionUnTyped t) -> 169 | (t : selSets, ops, frags) 170 | ExecutableDefinitionOperation (OperationDefinitionTyped t) -> 171 | (selSets, t : ops, frags) 172 | ExecutableDefinitionFragment frag -> 173 | (selSets, ops, frag : frags) 174 | 175 | type TypeSystemDefinition :: Type 176 | data TypeSystemDefinition 177 | = TypeSystemDefinitionSchema SchemaDefinition 178 | | TypeSystemDefinitionType (TypeDefinition () InputValueDefinition) -- No 'possibleTypes' specified for interfaces 179 | deriving stock (Eq, Generic, Lift, Ord, Show) 180 | deriving anyclass (Hashable, NFData) 181 | 182 | type SchemaDefinition :: Type 183 | data SchemaDefinition = SchemaDefinition 184 | { _sdDirectives :: Maybe [Directive Void], 185 | _sdRootOperationTypeDefinitions :: [RootOperationTypeDefinition] 186 | } 187 | deriving stock (Eq, Generic, Lift, Ord, Show) 188 | deriving anyclass (Hashable, NFData) 189 | 190 | type RootOperationTypeDefinition :: Type 191 | data RootOperationTypeDefinition = RootOperationTypeDefinition 192 | { _rotdOperationType :: OperationType, 193 | _rotdOperationTypeType :: Name 194 | } 195 | deriving stock (Eq, Generic, Lift, Ord, Show) 196 | deriving anyclass (Hashable, NFData) 197 | 198 | type OperationType :: Type 199 | data OperationType 200 | = OperationTypeQuery 201 | | OperationTypeMutation 202 | | OperationTypeSubscription 203 | deriving stock (Eq, Generic, Lift, Ord, Show) 204 | deriving anyclass (Hashable, NFData) 205 | 206 | type SchemaDocument :: Type 207 | newtype SchemaDocument 208 | = SchemaDocument [TypeSystemDefinition] 209 | deriving stock (Eq, Generic, Lift, Ord, Show) 210 | deriving newtype (Hashable, NFData) 211 | 212 | instance J.FromJSON SchemaDocument where 213 | parseJSON = J.withText "SchemaDocument" $ \t -> 214 | case parseSchemaDocument t of 215 | Right schemaDoc -> return schemaDoc 216 | Left err -> fail $ "parsing the schema document: " <> show err 217 | 218 | -- | A variant of 'SchemaDocument' that additionally stores, for each interface, 219 | -- the list of object types that implement that interface. Types are indexed by 220 | -- their name for fast lookups. 221 | type SchemaIntrospection :: Type 222 | newtype SchemaIntrospection 223 | = SchemaIntrospection (HashMap Name (TypeDefinition [Name] InputValueDefinition)) 224 | deriving stock (Eq, Generic, Ord, Show) 225 | deriving newtype (Hashable) 226 | 227 | type OperationDefinition :: (Type -> Type) -> Type -> Type 228 | data OperationDefinition frag var 229 | = OperationDefinitionTyped (TypedOperationDefinition frag var) 230 | | OperationDefinitionUnTyped (SelectionSet frag var) 231 | deriving stock (Eq, Generic, Lift, Ord, Show, Functor, Foldable, Traversable) 232 | deriving anyclass (Hashable, NFData) 233 | 234 | type TypedOperationDefinition :: (Type -> Type) -> Type -> Type 235 | data TypedOperationDefinition frag var = TypedOperationDefinition 236 | { _todType :: OperationType, 237 | _todName :: Maybe Name, 238 | _todVariableDefinitions :: [VariableDefinition], 239 | _todDirectives :: [Directive var], 240 | _todSelectionSet :: SelectionSet frag var 241 | } 242 | deriving stock (Eq, Generic, Lift, Ord, Show, Functor, Foldable, Traversable) 243 | deriving anyclass (Hashable, NFData) 244 | 245 | type VariableDefinition :: Type 246 | data VariableDefinition = VariableDefinition 247 | { _vdName :: Name, 248 | _vdType :: GType, 249 | _vdDefaultValue :: Maybe (Value Void) 250 | } 251 | deriving stock (Eq, Generic, Lift, Ord, Show) 252 | deriving anyclass (Hashable, NFData) 253 | 254 | type SelectionSet :: (Type -> Type) -> Type -> Type 255 | type SelectionSet frag var = [Selection frag var] 256 | 257 | type Selection :: (Type -> Type) -> Type -> Type 258 | data Selection frag var 259 | = SelectionField (Field frag var) 260 | | SelectionFragmentSpread (frag var) 261 | | SelectionInlineFragment (InlineFragment frag var) 262 | deriving stock (Eq, Generic, Lift, Ord, Show, Functor, Foldable, Traversable) 263 | deriving anyclass (Hashable, NFData) 264 | 265 | type Field :: (Type -> Type) -> Type -> Type 266 | data Field frag var = Field 267 | { _fAlias :: Maybe Name, 268 | _fName :: Name, 269 | _fArguments :: HashMap Name (Value var), 270 | _fDirectives :: [Directive var], 271 | _fSelectionSet :: SelectionSet frag var 272 | } 273 | deriving stock (Eq, Generic, Ord, Show, Functor, Foldable, Traversable) 274 | deriving anyclass (Hashable, NFData) 275 | 276 | instance (Lift (frag var), Lift var) => Lift (Field frag var) where 277 | liftTyped Field {..} = 278 | [|| 279 | Field 280 | { _fAlias, 281 | _fName, 282 | _fDirectives, 283 | _fSelectionSet, 284 | _fArguments = $$(liftTypedHashMap _fArguments) 285 | } 286 | ||] 287 | 288 | -- * Fragments 289 | 290 | type FragmentSpread :: Type -> Type 291 | data FragmentSpread var = FragmentSpread 292 | { _fsName :: Name, 293 | _fsDirectives :: [Directive var] 294 | } 295 | deriving stock (Eq, Generic, Lift, Ord, Show, Functor, Foldable, Traversable) 296 | deriving anyclass (Hashable, NFData) 297 | 298 | -- | Can be used in place of the @frag@ parameter to various AST types to 299 | -- guarante that the AST does not include any fragment spreads. 300 | -- 301 | -- Note: This is equivalent to @'Const' 'Void'@, but annoyingly, 'Const' does 302 | -- not provide a 'Lift' instance as of GHC 8.6. 303 | type NoFragments :: Type -> Type 304 | data NoFragments var 305 | deriving stock (Eq, Generic, Lift, Ord, Show, Functor, Foldable, Traversable) 306 | deriving anyclass (Hashable, NFData) 307 | 308 | type InlineFragment :: (Type -> Type) -> Type -> Type 309 | data InlineFragment frag var = InlineFragment 310 | { _ifTypeCondition :: Maybe Name, 311 | _ifDirectives :: [Directive var], 312 | _ifSelectionSet :: SelectionSet frag var 313 | } 314 | deriving stock (Eq, Generic, Lift, Ord, Show, Functor, Foldable, Traversable) 315 | deriving anyclass (Hashable, NFData) 316 | 317 | type FragmentDefinition :: Type 318 | data FragmentDefinition = FragmentDefinition 319 | { _fdName :: Name, 320 | _fdTypeCondition :: Name, 321 | _fdDirectives :: [Directive Name], 322 | _fdSelectionSet :: SelectionSet FragmentSpread Name 323 | } 324 | deriving stock (Eq, Generic, Lift, Ord, Show) 325 | deriving anyclass (Hashable, NFData) 326 | 327 | -- * Values 328 | 329 | type Value :: Type -> Type 330 | data Value var 331 | = VVariable var 332 | | VNull 333 | | VInt Integer 334 | | VFloat Scientific 335 | | VString Text 336 | | VBoolean Bool 337 | | VEnum EnumValue 338 | | VList [Value var] 339 | | VObject (HashMap Name (Value var)) 340 | deriving stock (Eq, Generic, Ord, Show, Functor, Foldable, Traversable) 341 | deriving anyclass (Hashable, NFData) 342 | 343 | instance Lift var => Lift (Value var) where 344 | liftTyped (VVariable a) = [||VVariable a||] 345 | liftTyped VNull = [||VNull||] 346 | liftTyped (VInt a) = [||VInt a||] 347 | liftTyped (VFloat a) = [||VFloat $ fromRational $$(TH.liftTyped $ toRational a)||] 348 | liftTyped (VString a) = [||VString a||] 349 | liftTyped (VBoolean a) = [||VBoolean a||] 350 | liftTyped (VEnum a) = [||VEnum a||] 351 | liftTyped (VList a) = [||VList a||] 352 | liftTyped (VObject a) = [||VObject $$(liftTypedHashMap a)||] 353 | 354 | literal :: Value Void -> Value var 355 | literal = fmap absurd 356 | 357 | -- * Directives 358 | 359 | type Directive :: Type -> Type 360 | data Directive var = Directive 361 | { _dName :: Name, 362 | _dArguments :: HashMap Name (Value var) 363 | } 364 | deriving stock (Eq, Generic, Ord, Show, Functor, Foldable, Traversable) 365 | deriving anyclass (Hashable, NFData) 366 | 367 | instance Lift var => Lift (Directive var) where 368 | liftTyped Directive {..} = 369 | [|| 370 | Directive 371 | { _dName, 372 | _dArguments = $$(liftTypedHashMap _dArguments) 373 | } 374 | ||] 375 | 376 | -- * Type Reference 377 | 378 | type Nullability :: Type 379 | newtype Nullability = Nullability {unNullability :: Bool} 380 | deriving stock (Eq, Generic, Lift, Ord, Show) 381 | deriving newtype (Hashable, NFData) 382 | 383 | type GType :: Type 384 | data GType 385 | = TypeNamed Nullability Name 386 | | TypeList Nullability GType 387 | deriving stock (Eq, Generic, Lift, Ord, Show) 388 | deriving anyclass (Hashable, NFData) 389 | 390 | getBaseType :: GType -> Name 391 | getBaseType = \case 392 | TypeNamed _ namedType -> namedType 393 | TypeList _ listType -> getBaseType listType 394 | 395 | instance J.ToJSON GType where 396 | toJSON = J.toJSON . showGT 397 | 398 | showGT :: GType -> Text 399 | showGT = \case 400 | TypeNamed nullability nt -> unName nt <> showNullable nullability 401 | TypeList nullability lt -> showLT lt <> showNullable nullability 402 | 403 | showNullable :: Nullability -> Text 404 | showNullable = bool "!" "" . unNullability 405 | 406 | showLT :: GType -> Text 407 | showLT lt = "[" <> showGT lt <> "]" 408 | 409 | isNullable :: GType -> Bool 410 | isNullable = \case 411 | TypeNamed nullability _ -> unNullability nullability 412 | TypeList nullability _ -> unNullability nullability 413 | 414 | isListType :: GType -> Bool 415 | isListType = \case 416 | TypeList _ _ -> True 417 | TypeNamed _ _ -> False 418 | 419 | isNotNull :: GType -> Bool 420 | isNotNull = not . isNullable 421 | 422 | -- * Type definition 423 | 424 | type TypeDefinition :: Type -> Type -> Type 425 | data TypeDefinition possibleTypes inputType 426 | = TypeDefinitionScalar ScalarTypeDefinition 427 | | TypeDefinitionObject (ObjectTypeDefinition inputType) 428 | | TypeDefinitionInterface (InterfaceTypeDefinition possibleTypes inputType) 429 | | TypeDefinitionUnion UnionTypeDefinition 430 | | TypeDefinitionEnum EnumTypeDefinition 431 | | TypeDefinitionInputObject (InputObjectTypeDefinition inputType) 432 | deriving stock (Eq, Generic, Lift, Ord, Show, Functor) 433 | deriving anyclass (Hashable, NFData) 434 | 435 | instance Bifunctor TypeDefinition where 436 | bimap f g definition = case definition of 437 | TypeDefinitionScalar d -> TypeDefinitionScalar d 438 | TypeDefinitionObject d -> TypeDefinitionObject $ fmap g d 439 | TypeDefinitionInterface d -> TypeDefinitionInterface $ bimap f g d 440 | TypeDefinitionUnion d -> TypeDefinitionUnion d 441 | TypeDefinitionEnum d -> TypeDefinitionEnum d 442 | TypeDefinitionInputObject d -> TypeDefinitionInputObject $ fmap g d 443 | 444 | type Description :: Type 445 | newtype Description = Description {unDescription :: Text} 446 | deriving stock (Eq, Lift, Ord, Show) 447 | deriving newtype (Hashable, IsString, Monoid, NFData, Semigroup, J.FromJSON, J.ToJSON) 448 | 449 | type ObjectTypeDefinition :: Type -> Type 450 | data ObjectTypeDefinition inputType = ObjectTypeDefinition 451 | { _otdDescription :: Maybe Description, 452 | _otdName :: Name, 453 | _otdImplementsInterfaces :: [Name], 454 | _otdDirectives :: [Directive Void], 455 | _otdFieldsDefinition :: [FieldDefinition inputType] 456 | } 457 | deriving stock (Eq, Generic, Lift, Ord, Show, Functor) 458 | deriving anyclass (Hashable, NFData) 459 | 460 | type FieldDefinition :: Type -> Type 461 | data FieldDefinition inputType = FieldDefinition 462 | { _fldDescription :: Maybe Description, 463 | _fldName :: Name, 464 | _fldArgumentsDefinition :: ArgumentsDefinition inputType, 465 | _fldType :: GType, 466 | _fldDirectives :: [Directive Void] 467 | } 468 | deriving stock (Eq, Generic, Lift, Ord, Show, Functor) 469 | deriving anyclass (Hashable, NFData) 470 | 471 | type ArgumentsDefinition :: Type -> Type 472 | type ArgumentsDefinition inputType = [inputType] 473 | 474 | type InputValueDefinition :: Type 475 | data InputValueDefinition = InputValueDefinition 476 | { _ivdDescription :: Maybe Description, 477 | _ivdName :: Name, 478 | _ivdType :: GType, 479 | _ivdDefaultValue :: Maybe (Value Void), 480 | _ivdDirectives :: [Directive Void] 481 | } 482 | deriving stock (Eq, Generic, Lift, Ord, Show) 483 | deriving anyclass (Hashable, NFData) 484 | 485 | type InterfaceTypeDefinition :: Type -> Type -> Type 486 | data InterfaceTypeDefinition possibleTypes inputType = InterfaceTypeDefinition 487 | { _itdDescription :: Maybe Description, 488 | _itdName :: Name, 489 | _itdDirectives :: [Directive Void], 490 | _itdFieldsDefinition :: [FieldDefinition inputType], 491 | _itdPossibleTypes :: possibleTypes 492 | } 493 | deriving stock (Eq, Generic, Lift, Ord, Show, Functor) 494 | deriving anyclass (Hashable, NFData) 495 | 496 | instance Bifunctor InterfaceTypeDefinition where 497 | bimap f g InterfaceTypeDefinition {..} = 498 | InterfaceTypeDefinition 499 | { _itdFieldsDefinition = map (fmap g) _itdFieldsDefinition, 500 | _itdPossibleTypes = f _itdPossibleTypes, 501 | .. 502 | } 503 | 504 | type UnionTypeDefinition :: Type 505 | data UnionTypeDefinition = UnionTypeDefinition 506 | { _utdDescription :: Maybe Description, 507 | _utdName :: Name, 508 | _utdDirectives :: [Directive Void], 509 | _utdMemberTypes :: [Name] 510 | } 511 | deriving stock (Eq, Generic, Lift, Ord, Show) 512 | deriving anyclass (Hashable, NFData) 513 | 514 | type ScalarTypeDefinition :: Type 515 | data ScalarTypeDefinition = ScalarTypeDefinition 516 | { _stdDescription :: Maybe Description, 517 | _stdName :: Name, 518 | _stdDirectives :: [Directive Void] 519 | } 520 | deriving stock (Eq, Generic, Lift, Ord, Show) 521 | deriving anyclass (Hashable, NFData) 522 | 523 | type EnumTypeDefinition :: Type 524 | data EnumTypeDefinition = EnumTypeDefinition 525 | { _etdDescription :: Maybe Description, 526 | _etdName :: Name, 527 | _etdDirectives :: [Directive Void], 528 | _etdValueDefinitions :: [EnumValueDefinition] 529 | } 530 | deriving stock (Eq, Generic, Lift, Ord, Show) 531 | deriving anyclass (Hashable, NFData) 532 | 533 | type EnumValueDefinition :: Type 534 | data EnumValueDefinition = EnumValueDefinition 535 | { _evdDescription :: Maybe Description, 536 | _evdName :: EnumValue, 537 | _evdDirectives :: [Directive Void] 538 | } 539 | deriving stock (Eq, Generic, Lift, Ord, Show) 540 | deriving anyclass (Hashable, NFData) 541 | 542 | type EnumValue :: Type 543 | newtype EnumValue = EnumValue {unEnumValue :: Name} 544 | deriving stock (Eq, Lift, Ord, Show) 545 | deriving newtype (Hashable, NFData, J.ToJSON, J.FromJSON) 546 | 547 | type InputObjectTypeDefinition :: Type -> Type 548 | data InputObjectTypeDefinition inputType = InputObjectTypeDefinition 549 | { _iotdDescription :: Maybe Description, 550 | _iotdName :: Name, 551 | _iotdDirectives :: [Directive Void], 552 | _iotdValueDefinitions :: [inputType] 553 | } 554 | deriving stock (Eq, Generic, Lift, Ord, Show, Functor) 555 | deriving anyclass (Hashable, NFData) 556 | 557 | type DirectiveDefinition :: Type -> Type 558 | data DirectiveDefinition inputType = DirectiveDefinition 559 | { _ddDescription :: Maybe Description, 560 | _ddName :: Name, 561 | _ddArguments :: ArgumentsDefinition inputType, 562 | _ddLocations :: [DirectiveLocation] 563 | } 564 | deriving stock (Eq, Generic, Lift, Ord, Show, Functor) 565 | deriving anyclass (Hashable, NFData) 566 | 567 | type DirectiveLocation :: Type 568 | data DirectiveLocation 569 | = DLExecutable ExecutableDirectiveLocation 570 | | DLTypeSystem TypeSystemDirectiveLocation 571 | deriving stock (Eq, Generic, Lift, Ord, Show) 572 | deriving anyclass (Hashable, NFData) 573 | 574 | type ExecutableDirectiveLocation :: Type 575 | data ExecutableDirectiveLocation 576 | = EDLQUERY 577 | | EDLMUTATION 578 | | EDLSUBSCRIPTION 579 | | EDLFIELD 580 | | EDLFRAGMENT_DEFINITION 581 | | EDLFRAGMENT_SPREAD 582 | | EDLINLINE_FRAGMENT 583 | deriving stock (Eq, Generic, Lift, Ord, Show) 584 | deriving anyclass (Hashable, NFData) 585 | 586 | type TypeSystemDirectiveLocation :: Type 587 | data TypeSystemDirectiveLocation 588 | = TSDLSCHEMA 589 | | TSDLSCALAR 590 | | TSDLOBJECT 591 | | TSDLFIELD_DEFINITION 592 | | TSDLARGUMENT_DEFINITION 593 | | TSDLINTERFACE 594 | | TSDLUNION 595 | | TSDLENUM 596 | | TSDLENUM_VALUE 597 | | TSDLINPUT_OBJECT 598 | | TSDLINPUT_FIELD_DEFINITION 599 | deriving stock (Eq, Generic, Lift, Ord, Show) 600 | deriving anyclass (Hashable, NFData) 601 | 602 | inline :: NoFragments var -> FragmentSpread var 603 | inline x = case x of {} 604 | 605 | fmapFieldFragment :: (frag var -> frag' var) -> Field frag var -> Field frag' var 606 | fmapFieldFragment f field = 607 | field {_fSelectionSet = fmapSelectionSetFragment f (_fSelectionSet field)} 608 | 609 | fmapSelectionSetFragment :: (frag var -> frag' var) -> SelectionSet frag var -> SelectionSet frag' var 610 | fmapSelectionSetFragment f = fmap (fmapSelectionFragment f) 611 | 612 | fmapSelectionFragment :: (frag var -> frag' var) -> Selection frag var -> Selection frag' var 613 | fmapSelectionFragment f (SelectionField field) = SelectionField $ fmapFieldFragment f field 614 | fmapSelectionFragment f (SelectionFragmentSpread frag) = SelectionFragmentSpread $ f frag 615 | fmapSelectionFragment f (SelectionInlineFragment inlineFrag) = 616 | SelectionInlineFragment $ fmapInlineFragment f inlineFrag 617 | 618 | fmapInlineFragment :: (frag var -> frag' var) -> InlineFragment frag var -> InlineFragment frag' var 619 | fmapInlineFragment f inlineFragment = 620 | inlineFragment {_ifSelectionSet = fmapSelectionSetFragment f (_ifSelectionSet inlineFragment)} 621 | --------------------------------------------------------------------------------