hasura/graphql-engine
1
0
Fork 0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-09-11 10:46:25 +03:00
Code Issues Projects Releases Wiki Activity

server: merge graphql-parser-hs into the monorepo

Browse Source 
PR-URL: https://github.com/hasura/graphql-engine-mono/pull/5906
Co-authored-by: José Lorenzo Rodríguez <37621+lorenzo@users.noreply.github.com>
Co-authored-by: Vitali Barozzi <26206141+vitalibarozzi@users.noreply.github.com>
Co-authored-by: Karthikeyan Chinnakonda <15602904+codingkarthik@users.noreply.github.com>
Co-authored-by: Auke Booij <164426+abooij@users.noreply.github.com>
Co-authored-by: jkachmar <8461423+jkachmar@users.noreply.github.com>
Co-authored-by: Antoine Leblanc <1618949+nicuveo@users.noreply.github.com>
Co-authored-by: Solomon <24038+solomon-b@users.noreply.github.com>
Co-authored-by: paritosh-08 <85472423+paritosh-08@users.noreply.github.com>
Co-authored-by: Evie Ciobanu <1017953+eviefp@users.noreply.github.com>
Co-authored-by: Vamshi Surabhi <6562944+0x777@users.noreply.github.com>
Co-authored-by: Samir Talwar <47582+SamirTalwar@users.noreply.github.com>
GitOrigin-RevId: 4864173fd616fbbb2fe3a839d0c5eabd76a2e1f2
This commit is contained in:
kodiakhq[bot] 2022-09-26 11:21:48 +00:00 committed by hasura-bot
parent 90543c99ae
commit c5de79d10c
35 changed files with 3768 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
cabal.project
View File

@ -46,11 +46,6 @@ source-repository-package
location: https://github.com/hasura/kriti-lang.git
tag: v0.3.2
source-repository-package
type: git
location: https://github.com/hasura/graphql-parser-hs.git
tag: b65932b2dc40b90820c7be6a2aa2f6646a13b023
source-repository-package
type: git
location: https://github.com/hasura/ci-info-hs.git

11
server/lib/graphql-parser-hs/.gitignore vendored Normal file
View File

@ -0,0 +1,11 @@
# Haskell
/dist-newstyle
cabal.project.local
# direnv
/.direnv
/.envrc.local
# Nix
/result
/result-*

30
server/lib/graphql-parser-hs/LICENSE Normal file
View File

@ -0,0 +1,30 @@
Copyright 2018–2020 Hasura Inc., 2015 J. Daniel Navarro
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of J. Daniel Navarro nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

91
server/lib/graphql-parser-hs/Makefile Normal file
View File

@ -0,0 +1,91 @@
PROJECT ?= cabal.project
CABAL = cabal --project=$(PROJECT)
.PHONY: freeze
freeze:
$(CABAL) freeze \
--enable-tests \
--enable-benchmarks
.PHONY: configure
configure:
$(CABAL) configure \
--enable-tests \
--enable-benchmarks
.PHONY: update
update:
$(CABAL) update
.PHONY: build-deps
build-deps:
$(CABAL) build \
--only-dependencies \
--enable-tests \
--enable-benchmarks \
all
.PHONY: build
build:
$(CABAL) build \
--enable-tests \
--enable-benchmarks \
graphql-parser
.PHONY: build-all
build-all:
$(CABAL) build \
--enable-tests \
--enable-benchmarks \
all
.PHONY: test-all
test-all:
$(CABAL) test \
--enable-tests \
--enable-benchmarks \
all
.PHONY: bench-all
bench-all:
$(CABAL) bench \
--enable-tests \
--enable-benchmarks \
all
.PHONY: repl
repl:
$(CABAL) repl \
--repl-option='-fobject-code' \
--repl-option='-O0' \
graphql-parser
.PHONY: ghcid
ghcid:
ghcid --command "\
$(CABAL) repl \
--repl-option='-fobject-code' \
--repl-option='-O0' \
graphql-parser \
"
.PHONY: ghcid-test
ghcid-test:
ghcid \
--command "\
$(CABAL) repl \
--repl-option '-fobject-code' \
--repl-option '-O0' \
graphql-parser-test \
" \
--test ":main"
.PHONY: ghcid-bench
ghcid-bench:
ghcid \
--command "\
$(CABAL) repl \
--repl-option '-fobject-code' \
--repl-option '-O0' \
graphql-parser-bench \
"

11
server/lib/graphql-parser-hs/README.md Normal file
View File

@ -0,0 +1,11 @@
# graphql-parser
[![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)
## Style
This repository follows the graphql-engine
[style guide](https://github.com/hasura/graphql-engine/blob/master/server/STYLE.md).
Use `make format` to run the formatter.

84
server/lib/graphql-parser-hs/bench/Benchmark.hs Normal file
View File

@ -0,0 +1,84 @@
module Main
( main,
)
where
-------------------------------------------------------------------------------
import Data.Bifunctor (second)
import Data.ByteString.Builder qualified as BS
import Data.Function ((&))
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import Data.Text.Lazy.Builder qualified as LTB
import Data.Traversable (for)
import Language.GraphQL.Draft.Generator (genExecutableDocument, genText, generate)
import Language.GraphQL.Draft.Parser (parseExecutableDoc)
import Language.GraphQL.Draft.Printer (executableDocument, renderExecutableDoc)
import Language.GraphQL.Draft.Syntax (ExecutableDocument, Name, mkName)
import Prettyprinter qualified as PP
import Prettyprinter.Render.Text qualified as PP
import Test.Tasty.Bench (bench, bgroup, defaultMain, nf, whnf)
import Text.Builder qualified as STB -- Strict Text Builder
import Prelude
-------------------------------------------------------------------------------
genDocs :: Int -> IO [(Int, ExecutableDocument Name)]
genDocs num =
for [1 .. num] $ \n -> (n,) <$> generate genExecutableDocument
genTexts :: Int -> IO [(Int, [Text])]
genTexts num =
for [1 .. num] $ \n -> do
texts <- for [1 .. 500 :: Int] \_ -> generate genText
pure (n, texts)
main :: IO ()
main = do
docs <- genDocs 10
texts <- genTexts 10
let grp1 = mkPPGrp docs
grp2 = mkBBGrp docs
grp3 = mkTBGrp docs
grp4 = mkTLBGrp docs
renderedDocs = map (second renderExecutableDoc) docs
grp5 = mkPGrp renderedDocs
grp6 = mkNGrp texts
defaultMain [grp1, grp2, grp3, grp4, grp5, grp6]
where
mkNGrp texts =
bgroup "checking name validity" $
texts & map \(n, t) ->
bench (show n) $ nf (length . mapMaybe mkName) t
mkPGrp qs =
bgroup "parsing executableDocument" $
qs & map \(n, q) ->
bench (show n) $ whnf parseExecutableDoc q
mkPPGrp gqs =
bgroup "rendering executableDocument (prettyprinter)" $
gqs & map \(n, gq) ->
bench (show n) $ nf (renderPP . executableDocument) gq
mkBBGrp gqs =
bgroup "rendering executableDocument (bytestring builder)" $
gqs & map \(n, gq) ->
bench (show n) $ nf (renderBB . executableDocument) gq
mkTBGrp gqs =
bgroup "rendering executableDocument (text builder)" $
gqs & map \(n, gq) ->
bench (show n) $ nf (renderTB . executableDocument) gq
mkTLBGrp gqs =
bgroup "rendering executableDocument (lazy text builder)" $
gqs & map \(n, gq) ->
bench (show n) $ nf (renderTLB . executableDocument) gq
renderPP :: PP.Doc Text -> Text
renderPP = PP.renderStrict . PP.layoutPretty PP.defaultLayoutOptions
renderBB = BS.toLazyByteString
renderTB = STB.run
renderTLB = LTB.toLazyText

14
server/lib/graphql-parser-hs/cabal.project Normal file
View File

@ -0,0 +1,14 @@
packages: ./
package *
optimization: 2
ghc-options: -fwrite-ide-info
haddock-html: true
haddock-hoogle: true
haddock-hyperlink-source: true
haddock-quickjump: true
package graphql-parser
ghc-options: -j

1
server/lib/graphql-parser-hs/ci/8.10.7/ci.project Symbolic link
View File

@ -0,0 +1 @@
../../cabal.project

141
server/lib/graphql-parser-hs/ci/8.10.7/ci.project.freeze Normal file
View File

@ -0,0 +1,141 @@
active-repositories: hackage.haskell.org:merge
constraints: any.OneTuple ==0.3.1,
any.PyF ==0.10.2.0,
PyF -python_test,
any.QuickCheck ==2.14.2,
QuickCheck -old-random +templatehaskell,
any.StateVar ==1.2.2,
any.aeson ==2.0.3.0,
aeson -cffi +ordered-keymap,
any.ansi-terminal ==0.11.3,
ansi-terminal -example,
any.ansi-wl-pprint ==0.6.9,
ansi-wl-pprint -example,
any.array ==0.5.4.0,
any.assoc ==1.0.2,
any.async ==2.2.4,
async -bench,
any.attoparsec ==0.14.4,
attoparsec -developer,
any.barbies ==2.0.3.1,
any.base ==4.14.3.0,
any.base-compat ==0.12.1,
any.base-compat-batteries ==0.12.1,
any.base-orphans ==0.8.6,
any.bifunctors ==5.5.11,
bifunctors +semigroups +tagged,
any.binary ==0.8.8.0,
any.bytestring ==0.10.12.0,
any.clock ==0.8.3,
clock -llvm,
any.colour ==2.3.6,
any.comonad ==5.0.8,
comonad +containers +distributive +indexed-traversable,
any.concurrent-output ==1.10.15,
any.constraints ==0.13.3,
any.containers ==0.6.5.1,
any.contravariant ==1.5.5,
contravariant +semigroups +statevar +tagged,
any.data-fix ==0.3.2,
any.deepseq ==1.4.4.0,
any.deferred-folds ==0.9.18.1,
any.directory ==1.3.6.0,
any.distributive ==0.6.2.1,
distributive +semigroups +tagged,
any.dlist ==1.0,
dlist -werror,
any.erf ==2.0.0.0,
any.exceptions ==0.10.4,
any.filepath ==1.4.2.1,
any.foldl ==1.4.12,
any.ghc ==8.10.7,
any.ghc-boot ==8.10.7,
any.ghc-boot-th ==8.10.7,
any.ghc-heap ==8.10.7,
any.ghc-prim ==0.6.1,
any.ghci ==8.10.7,
any.happy ==1.20.0,
any.hashable ==1.4.0.2,
hashable +containers +integer-gmp -random-initial-seed,
any.haskell-lexer ==1.1,
any.hedgehog ==1.1.1,
any.hpc ==0.6.1.0,
any.hsc2hs ==0.68.8,
hsc2hs -in-ghc-tree,
any.indexed-traversable ==0.1.2,
any.indexed-traversable-instances ==0.1.1,
any.integer-gmp ==1.0.3.0,
any.integer-logarithms ==1.0.3.1,
integer-logarithms -check-bounds +integer-gmp,
any.lifted-async ==0.10.2.2,
any.lifted-base ==0.2.3.12,
any.mmorph ==1.2.0,
any.monad-control ==1.0.3.1,
any.mtl ==2.2.2,
any.optparse-applicative ==0.17.0.0,
optparse-applicative +process,
any.parsec ==3.1.14.0,
any.pretty ==1.1.3.6,
any.pretty-show ==1.10,
any.prettyprinter ==1.7.1,
prettyprinter -buildreadme +text,
any.primitive ==0.7.3.0,
any.process ==1.6.13.2,
any.profunctors ==5.6.2,
any.random ==1.2.1,
any.resourcet ==1.2.4.3,
any.rts ==1.0.1,
any.scientific ==0.3.7.0,
scientific -bytestring-builder -integer-simple,
any.semialign ==1.2.0.1,
semialign +semigroupoids,
any.semigroupoids ==5.3.7,
semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers,
any.split ==0.2.3.4,
any.splitmix ==0.1.0.4,
splitmix -optimised-mixer,
any.stm ==2.5.0.1,
any.strict ==0.4.0.1,
strict +assoc,
any.tagged ==0.8.6.1,
tagged +deepseq +transformers,
any.tasty ==1.4.2.1,
tasty +clock +unix,
any.tasty-bench ==0.3.1,
tasty-bench -debug +tasty,
any.template-haskell ==2.16.0.0,
any.terminal-size ==0.3.3,
any.terminfo ==0.4.1.4,
any.text ==1.2.4.1,
any.text-builder ==0.6.7,
any.text-builder-dev ==0.3.1,
any.text-short ==0.1.5,
text-short -asserts,
any.th-abstraction ==0.4.3.0,
any.th-compat ==0.1.3,
any.th-lift ==0.8.2,
any.th-lift-instances ==0.1.19,
any.these ==1.1.1.1,
these +assoc,
any.time ==1.9.3,
any.time-compat ==1.9.6.1,
time-compat -old-locale,
any.transformers ==0.5.6.2,
any.transformers-base ==0.4.6,
transformers-base +orphaninstances,
any.transformers-compat ==0.7.1,
transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
any.type-equality ==1,
any.unbounded-delays ==0.1.1.1,
any.unix ==2.7.2.2,
any.unliftio-core ==0.2.0.1,
any.unordered-containers ==0.2.19.1,
unordered-containers -debug,
any.uuid-types ==1.0.5,
any.vector ==0.12.3.1,
vector +boundschecks -internalchecks -unsafechecks -wall,
any.wcwidth ==0.0.2,
wcwidth -cli +split-base,
any.witherable ==0.4.2,
any.wl-pprint-annotated ==0.1.0.1
index-state: hackage.haskell.org 2022-05-02T18:30:49Z

4
server/lib/graphql-parser-hs/ci/8.10.7/ci.project.local Normal file
View File

@ -0,0 +1,4 @@
with-compiler: ghc-8.10.7
package graphql-parser
ghc-options: -Werror

1
server/lib/graphql-parser-hs/ci/8.10.7/weeder.project Symbolic link
View File

@ -0,0 +1 @@
../../cabal.project

142
server/lib/graphql-parser-hs/ci/8.10.7/weeder.project.freeze Normal file
View File

@ -0,0 +1,142 @@
active-repositories: hackage.haskell.org:merge
constraints: any.OneTuple ==0.3.1,
any.PyF ==0.10.2.0,
PyF -python_test,
any.QuickCheck ==2.14.2,
QuickCheck -old-random +templatehaskell,
any.StateVar ==1.2.2,
any.aeson ==2.0.3.0,
aeson -cffi +ordered-keymap,
any.ansi-terminal ==0.11.3,
ansi-terminal -example,
any.ansi-wl-pprint ==0.6.9,
ansi-wl-pprint -example,
any.array ==0.5.4.0,
any.assoc ==1.0.2,
any.async ==2.2.4,
async -bench,
any.attoparsec ==0.14.4,
attoparsec -developer,
any.barbies ==2.0.3.1,
any.base ==4.14.3.0,
any.base-compat ==0.12.1,
any.base-compat-batteries ==0.12.1,
any.base-orphans ==0.8.6,
any.bifunctors ==5.5.11,
bifunctors +semigroups +tagged,
any.binary ==0.8.8.0,
any.bytestring ==0.10.12.0,
any.clock ==0.8.3,
clock -llvm,
any.colour ==2.3.6,
any.comonad ==5.0.8,
comonad +containers +distributive +indexed-traversable,
any.concurrent-output ==1.10.15,
any.constraints ==0.13.3,
any.containers ==0.6.5.1,
any.contravariant ==1.5.5,
contravariant +semigroups +statevar +tagged,
any.data-fix ==0.3.2,
any.deepseq ==1.4.4.0,
any.deferred-folds ==0.9.18.1,
any.directory ==1.3.6.0,
any.distributive ==0.6.2.1,
distributive +semigroups +tagged,
any.dlist ==1.0,
dlist -werror,
any.erf ==2.0.0.0,
any.exceptions ==0.10.4,
any.filepath ==1.4.2.1,
any.foldl ==1.4.12,
any.ghc ==8.10.7,
any.ghc-boot ==8.10.7,
any.ghc-boot-th ==8.10.7,
any.ghc-heap ==8.10.7,
any.ghc-prim ==0.6.1,
any.ghci ==8.10.7,
any.happy ==1.20.0,
any.hashable ==1.4.0.2,
hashable +containers +integer-gmp -random-initial-seed,
any.haskell-lexer ==1.1,
any.hedgehog ==1.1.1,
any.hpc ==0.6.1.0,
any.hsc2hs ==0.68.8,
hsc2hs -in-ghc-tree,
any.indexed-traversable ==0.1.2,
any.indexed-traversable-instances ==0.1.1,
any.integer-gmp ==1.0.3.0,
any.integer-logarithms ==1.0.3.1,
integer-logarithms -check-bounds +integer-gmp,
any.lifted-async ==0.10.2.2,
any.lifted-base ==0.2.3.12,
any.mmorph ==1.2.0,
any.monad-control ==1.0.3.1,
any.mtl ==2.2.2,
any.optparse-applicative ==0.17.0.0,
optparse-applicative +process,
any.parsec ==3.1.14.0,
any.pretty ==1.1.3.6,
any.pretty-show ==1.10,
any.prettyprinter ==1.7.1,
prettyprinter -buildreadme +text,
any.primitive ==0.7.3.0,
any.process ==1.6.13.2,
any.profunctors ==5.6.2,
any.random ==1.2.1,
any.resourcet ==1.2.4.3,
any.rts ==1.0.1,
any.scientific ==0.3.7.0,
scientific -bytestring-builder -integer-simple,
any.semialign ==1.2.0.1,
semialign +semigroupoids,
any.semigroupoids ==5.3.7,
semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers,
any.split ==0.2.3.4,
any.splitmix ==0.1.0.4,
splitmix -optimised-mixer,
any.stm ==2.5.0.1,
any.strict ==0.4.0.1,
strict +assoc,
any.tagged ==0.8.6.1,
tagged +deepseq +transformers,
any.tasty ==1.4.2.1,
tasty +clock +unix,
any.tasty-bench ==0.3.1,
tasty-bench -debug +tasty,
any.template-haskell ==2.16.0.0,
any.terminal-size ==0.3.3,
any.terminfo ==0.4.1.4,
any.text ==1.2.4.1,
any.text-builder ==0.6.7,
any.text-builder-dev ==0.3.1,
any.text-short ==0.1.5,
text-short -asserts,
any.th-abstraction ==0.4.3.0,
any.th-compat ==0.1.3,
any.th-lift ==0.8.2,
any.th-lift-instances ==0.1.19,
any.these ==1.1.1.1,
these +assoc,
any.time ==1.9.3,
any.time-compat ==1.9.6.1,
time-compat -old-locale,
any.transformers ==0.5.6.2,
any.transformers-base ==0.4.6,
transformers-base +orphaninstances,
any.transformers-compat ==0.7.1,
transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
any.type-equality ==1,
any.unbounded-delays ==0.1.1.1,
any.unix ==2.7.2.2,
any.unliftio-core ==0.2.0.1,
any.unordered-containers ==0.2.19.1,
unordered-containers -debug,
any.uuid-types ==1.0.5,
any.vector ==0.12.3.1,
vector +boundschecks -internalchecks -unsafechecks -wall,
any.wcwidth ==0.0.2,
wcwidth -cli +split-base,
any.weeder ==2.2.0,
any.witherable ==0.4.2,
any.wl-pprint-annotated ==0.1.0.1
index-state: hackage.haskell.org 2022-05-02T18:30:49Z

7
server/lib/graphql-parser-hs/ci/8.10.7/weeder.project.local Normal file
View File

@ -0,0 +1,7 @@
with-compiler: ghc-8.10.7
allow-newer:
weeder:optparse-applicative
package *
optimization: 0

1
server/lib/graphql-parser-hs/ci/9.0.2/ci.project Symbolic link
View File

@ -0,0 +1 @@
../../cabal.project

141
server/lib/graphql-parser-hs/ci/9.0.2/ci.project.freeze Normal file
View File

@ -0,0 +1,141 @@
active-repositories: hackage.haskell.org:merge
constraints: any.OneTuple ==0.3.1,
any.PyF ==0.10.2.0,
PyF -python_test,
any.QuickCheck ==2.14.2,
QuickCheck -old-random +templatehaskell,
any.StateVar ==1.2.2,
any.aeson ==2.0.3.0,
aeson -cffi +ordered-keymap,
any.ansi-terminal ==0.11.3,
ansi-terminal -example,
any.ansi-wl-pprint ==0.6.9,
ansi-wl-pprint -example,
any.array ==0.5.4.0,
any.assoc ==1.0.2,
any.async ==2.2.4,
async -bench,
any.attoparsec ==0.14.4,
attoparsec -developer,
any.barbies ==2.0.3.1,
any.base ==4.15.1.0,
any.base-compat ==0.12.1,
any.base-compat-batteries ==0.12.1,
any.base-orphans ==0.8.6,
any.bifunctors ==5.5.11,
bifunctors +semigroups +tagged,
any.binary ==0.8.8.0,
any.bytestring ==0.10.12.1,
any.clock ==0.8.3,
clock -llvm,
any.colour ==2.3.6,
any.comonad ==5.0.8,
comonad +containers +distributive +indexed-traversable,
any.concurrent-output ==1.10.15,
any.constraints ==0.13.3,
any.containers ==0.6.4.1,
any.contravariant ==1.5.5,
contravariant +semigroups +statevar +tagged,
any.data-fix ==0.3.2,
any.deepseq ==1.4.5.0,
any.deferred-folds ==0.9.18.1,
any.directory ==1.3.6.2,
any.distributive ==0.6.2.1,
distributive +semigroups +tagged,
any.dlist ==1.0,
dlist -werror,
any.erf ==2.0.0.0,
any.exceptions ==0.10.4,
any.filepath ==1.4.2.1,
any.foldl ==1.4.12,
any.ghc ==9.0.2,
any.ghc-bignum ==1.1,
any.ghc-boot ==9.0.2,
any.ghc-boot-th ==9.0.2,
any.ghc-heap ==9.0.2,
any.ghc-prim ==0.7.0,
any.ghci ==9.0.2,
any.happy ==1.20.0,
any.hashable ==1.4.0.2,
hashable +containers +integer-gmp -random-initial-seed,
any.haskell-lexer ==1.1,
any.hedgehog ==1.1.1,
any.hpc ==0.6.1.0,
any.hsc2hs ==0.68.8,
hsc2hs -in-ghc-tree,
any.indexed-traversable ==0.1.2,
any.indexed-traversable-instances ==0.1.1,
any.integer-logarithms ==1.0.3.1,
integer-logarithms -check-bounds +integer-gmp,
any.lifted-async ==0.10.2.2,
any.lifted-base ==0.2.3.12,
any.mmorph ==1.2.0,
any.monad-control ==1.0.3.1,
any.mtl ==2.2.2,
any.optparse-applicative ==0.17.0.0,
optparse-applicative +process,
any.parsec ==3.1.14.0,
any.pretty ==1.1.3.6,
any.pretty-show ==1.10,
any.prettyprinter ==1.7.1,
prettyprinter -buildreadme +text,
any.primitive ==0.7.3.0,
any.process ==1.6.13.2,
any.profunctors ==5.6.2,
any.random ==1.2.1,
any.resourcet ==1.2.4.3,
any.rts ==1.0.2,
any.scientific ==0.3.7.0,
scientific -bytestring-builder -integer-simple,
any.semialign ==1.2.0.1,
semialign +semigroupoids,
any.semigroupoids ==5.3.7,
semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers,
any.split ==0.2.3.4,
any.splitmix ==0.1.0.4,
splitmix -optimised-mixer,
any.stm ==2.5.0.0,
any.strict ==0.4.0.1,
strict +assoc,
any.tagged ==0.8.6.1,
tagged +deepseq +transformers,
any.tasty ==1.4.2.1,
tasty +clock +unix,
any.tasty-bench ==0.3.1,
tasty-bench -debug +tasty,
any.template-haskell ==2.17.0.0,
any.terminal-size ==0.3.3,
any.terminfo ==0.4.1.5,
any.text ==1.2.5.0,
any.text-builder ==0.6.7,
any.text-builder-dev ==0.3.1,
any.text-short ==0.1.5,
text-short -asserts,
any.th-abstraction ==0.4.3.0,
any.th-compat ==0.1.3,
any.th-lift ==0.8.2,
any.th-lift-instances ==0.1.19,
any.these ==1.1.1.1,
these +assoc,
any.time ==1.9.3,
any.time-compat ==1.9.6.1,
time-compat -old-locale,
any.transformers ==0.5.6.2,
any.transformers-base ==0.4.6,
transformers-base +orphaninstances,
any.transformers-compat ==0.7.1,
transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
any.type-equality ==1,
any.unbounded-delays ==0.1.1.1,
any.unix ==2.7.2.2,
any.unliftio-core ==0.2.0.1,
any.unordered-containers ==0.2.19.1,
unordered-containers -debug,
any.uuid-types ==1.0.5,
any.vector ==0.12.3.1,
vector +boundschecks -internalchecks -unsafechecks -wall,
any.wcwidth ==0.0.2,
wcwidth -cli +split-base,
any.witherable ==0.4.2,
any.wl-pprint-annotated ==0.1.0.1
index-state: hackage.haskell.org 2022-05-02T18:30:49Z

4
server/lib/graphql-parser-hs/ci/9.0.2/ci.project.local Normal file
View File

@ -0,0 +1,4 @@
with-compiler: ghc-9.0.2
package graphql-parser
ghc-options: -Werror

1
server/lib/graphql-parser-hs/ci/9.2.2/ci.project Symbolic link
View File

@ -0,0 +1 @@
../../cabal.project

141
server/lib/graphql-parser-hs/ci/9.2.2/ci.project.freeze Normal file
View File

@ -0,0 +1,141 @@
active-repositories: hackage.haskell.org:merge
constraints: any.OneTuple ==0.3.1,
any.PyF ==0.10.2.0,
PyF -python_test,
any.QuickCheck ==2.14.2,
QuickCheck -old-random +templatehaskell,
any.StateVar ==1.2.2,
any.aeson ==2.0.3.0,
aeson -cffi +ordered-keymap,
any.ansi-terminal ==0.11.3,
ansi-terminal -example,
any.ansi-wl-pprint ==0.6.9,
ansi-wl-pprint -example,
any.array ==0.5.4.0,
any.assoc ==1.0.2,
any.async ==2.2.4,
async -bench,
any.attoparsec ==0.14.4,
attoparsec -developer,
any.barbies ==2.0.3.1,
any.base ==4.16.1.0,
any.base-compat ==0.12.1,
any.base-compat-batteries ==0.12.1,
any.base-orphans ==0.8.6,
any.bifunctors ==5.5.11,
bifunctors +semigroups +tagged,
any.binary ==0.8.9.0,
any.bytestring ==0.11.3.0,
any.clock ==0.8.3,
clock -llvm,
any.colour ==2.3.6,
any.comonad ==5.0.8,
comonad +containers +distributive +indexed-traversable,
any.concurrent-output ==1.10.15,
any.constraints ==0.13.3,
any.containers ==0.6.5.1,
any.contravariant ==1.5.5,
contravariant +semigroups +statevar +tagged,
any.data-fix ==0.3.2,
any.deepseq ==1.4.6.1,
any.deferred-folds ==0.9.18.1,
any.directory ==1.3.6.2,
any.distributive ==0.6.2.1,
distributive +semigroups +tagged,
any.dlist ==1.0,
dlist -werror,
any.erf ==2.0.0.0,
any.exceptions ==0.10.4,
any.filepath ==1.4.2.2,
any.foldl ==1.4.12,
any.ghc ==9.2.2,
any.ghc-bignum ==1.2,
any.ghc-boot ==9.2.2,
any.ghc-boot-th ==9.2.2,
any.ghc-heap ==9.2.2,
any.ghc-prim ==0.8.0,
any.ghci ==9.2.2,
any.happy ==1.20.0,
any.hashable ==1.4.0.2,
hashable +containers +integer-gmp -random-initial-seed,
any.haskell-lexer ==1.1,
any.hedgehog ==1.1.1,
any.hpc ==0.6.1.0,
any.hsc2hs ==0.68.8,
hsc2hs -in-ghc-tree,
any.indexed-traversable ==0.1.2,
any.indexed-traversable-instances ==0.1.1,
any.integer-logarithms ==1.0.3.1,
integer-logarithms -check-bounds +integer-gmp,
any.lifted-async ==0.10.2.2,
any.lifted-base ==0.2.3.12,
any.mmorph ==1.2.0,
any.monad-control ==1.0.3.1,
any.mtl ==2.2.2,
any.optparse-applicative ==0.17.0.0,
optparse-applicative +process,
any.parsec ==3.1.15.0,
any.pretty ==1.1.3.6,
any.pretty-show ==1.10,
any.prettyprinter ==1.7.1,
prettyprinter -buildreadme +text,
any.primitive ==0.7.3.0,
any.process ==1.6.13.2,
any.profunctors ==5.6.2,
any.random ==1.2.1,
any.resourcet ==1.2.4.3,
any.rts ==1.0.2,
any.scientific ==0.3.7.0,
scientific -bytestring-builder -integer-simple,
any.semialign ==1.2.0.1,
semialign +semigroupoids,
any.semigroupoids ==5.3.7,
semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers,
any.split ==0.2.3.4,
any.splitmix ==0.1.0.4,
splitmix -optimised-mixer,
any.stm ==2.5.0.2,
any.strict ==0.4.0.1,
strict +assoc,
any.tagged ==0.8.6.1,
tagged +deepseq +transformers,
any.tasty ==1.4.2.1,
tasty +clock +unix,
any.tasty-bench ==0.3.1,
tasty-bench -debug +tasty,
any.template-haskell ==2.18.0.0,
any.terminal-size ==0.3.3,
any.terminfo ==0.4.1.5,
any.text ==1.2.5.0,
any.text-builder ==0.6.7,
any.text-builder-dev ==0.3.1,
any.text-short ==0.1.5,
text-short -asserts,
any.th-abstraction ==0.4.3.0,
any.th-compat ==0.1.3,
any.th-lift ==0.8.2,
any.th-lift-instances ==0.1.19,
any.these ==1.1.1.1,
these +assoc,
any.time ==1.11.1.1,
any.time-compat ==1.9.6.1,
time-compat -old-locale,
any.transformers ==0.5.6.2,
any.transformers-base ==0.4.6,
transformers-base +orphaninstances,
any.transformers-compat ==0.7.1,
transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
any.type-equality ==1,
any.unbounded-delays ==0.1.1.1,
any.unix ==2.7.2.2,
any.unliftio-core ==0.2.0.1,
any.unordered-containers ==0.2.19.1,
unordered-containers -debug,
any.uuid-types ==1.0.5,
any.vector ==0.12.3.1,
vector +boundschecks -internalchecks -unsafechecks -wall,
any.wcwidth ==0.0.2,
wcwidth -cli +split-base,
any.witherable ==0.4.2,
any.wl-pprint-annotated ==0.1.0.1
index-state: hackage.haskell.org 2022-05-06T13:54:12Z

4
server/lib/graphql-parser-hs/ci/9.2.2/ci.project.local Normal file
View File

@ -0,0 +1,4 @@
with-compiler: ghc-9.2.2
package graphql-parser
ghc-options: -Werror

126
server/lib/graphql-parser-hs/graphql-parser.cabal Normal file
View File

@ -0,0 +1,126 @@
cabal-version: 3.0
name: graphql-parser
version: 0.2.0.0
synopsis: A native Haskell GraphQL parser.
homepage: https://github.com/hasura/graphql-parser-hs
bug-reports: https://github.com/hasura/graphql-parser-hs/issues
author: Vamshi Surabhi
maintainer: vamshi@hasura.io
copyright: 2018–2022 Hasura Inc., 2015 J. Daniel Navarro
license: BSD-3-Clause
license-file: LICENSE
build-type: Simple
tested-with: GHC ==8.10.7 || ==9.0.2 || ==9.2.2
source-repository head
type: git
location: https://github.com/hasura/graphql-parser-hs
common common-all
-- This warning strategy was inspired by Max Tagher's 'Enable All the
-- Warnings' blog post.
--
-- NOTE: '-Wno-prepositive-qualified-module' is currently a workaround for
-- https://github.com/haskell/cabal/pull/7352
ghc-options:
-Weverything -Wno-missing-exported-signatures
-Wno-missing-import-lists -Wno-missing-export-lists
-Wno-missed-specialisations -Wno-all-missed-specializations
-Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode
-Wno-missing-local-signatures -Wno-monomorphism-restriction
-Wno-prepositive-qualified-module -Wno-unrecognised-pragmas
if impl(ghc >=9.2)
ghc-options: -Wno-implicit-lift
default-language: Haskell2010
default-extensions:
NoImplicitPrelude
BlockArguments
ConstraintKinds
DeriveAnyClass
DeriveFunctor
DeriveGeneric
DeriveLift
DeriveTraversable
DerivingStrategies
EmptyCase
EmptyDataDeriving
FlexibleContexts
FlexibleInstances
FunctionalDependencies
GeneralizedNewtypeDeriving
ImportQualifiedPost
LambdaCase
NamedFieldPuns
OverloadedStrings
RankNTypes
RecordWildCards
RoleAnnotations
StandaloneKindSignatures
StrictData
TupleSections
library
import: common-all
hs-source-dirs: src
build-depends:
, aeson >=1.5
, attoparsec >=0.14
, base >=4.7
, bytestring >=0.10
, deepseq >=1.4
, hashable >=1.3
, hedgehog >=1.1
, prettyprinter >=1.7
, scientific >=0.3
, template-haskell >=2.16
, text >=1.2
, text-builder >=0.6
, th-compat >=0.1
, th-lift-instances >=0.1
, unordered-containers >=0.2
exposed-modules:
Language.GraphQL.Draft.Generator
Language.GraphQL.Draft.Parser
Language.GraphQL.Draft.Printer
Language.GraphQL.Draft.Syntax
Language.GraphQL.Draft.Syntax.Internal
Language.GraphQL.Draft.Syntax.QQ
other-modules:
Language.GraphQL.Draft.Syntax.Name
test-suite graphql-parser-test
import: common-all
ghc-options: -threaded -rtsopts -with-rtsopts=-N
type: exitcode-stdio-1.0
hs-source-dirs: test
main-is: Spec.hs
other-modules:
BlockStrings
Keywords
build-depends:
, base
, bytestring
, graphql-parser
, hedgehog
, prettyprinter
, text
, text-builder
benchmark graphql-parser-bench
import: common-all
type: exitcode-stdio-1.0
hs-source-dirs: bench
main-is: Benchmark.hs
build-depends:
, base
, bytestring
, graphql-parser
, prettyprinter
, tasty-bench
, text
, text-builder

480
server/lib/graphql-parser-hs/src/Language/GraphQL/Draft/Generator.hs Normal file
View File

@ -0,0 +1,480 @@
module Language.GraphQL.Draft.Generator
( -- * Generator
Generator (..),
generate,
-- * Document
genDocument,
genExecutableDocument,
-- * Identifiers
genText,
alpha_,
alphaNum_,
genGraphqlName,
genName,
genNullability,
genType,
genDescription,
genValueWith,
genEnumValue,
genListValue,
genObjectValue,
genBlockText,
genMinIndentedText,
genIndentation,
-- * Definitions
genDefinition,
genExecutableDefinition,
genOperationDefinition,
genTypedOperationDefinition,
genVariableDefinition,
genFragmentDefinition,
genTypeSystemDefinition,
genSchemaDefinition,
genRootOperationTypeDefinition,
genOperationType,
genTypeDefinition,
genScalarTypeDefinition,
genObjectTypeDefinition,
genInterfaceTypeDefinition,
genUnionTypeDefinition,
genEnumTypeDefinition,
genInputObjectTypeDefinition,
genInputValueDefinition,
genEnumValueDefinition,
genFieldDefinition,
genFieldDefinitions,
genDirectiveDefinition,
genArgumentsDefinition,
genDirectiveLocation,
genExecutableDirectiveLocation,
genTypeSystemDirectiveLocation,
-- * Structure
genSelectionSet,
genSelection,
genFragmentSpread,
genInlineFragment,
genField,
genDirective,
genDirectives,
genArgument,
-- * Helpers
mkList,
mkListNonEmpty,
)
where
-------------------------------------------------------------------------------
import Control.Monad.IO.Class (MonadIO)
import Data.HashMap.Strict as M
import Data.Kind (Constraint, Type)
import Data.Scientific (fromFloatDigits)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Void (Void)
import Hedgehog (Gen)
import Hedgehog.Gen qualified as Gen
import Hedgehog.Range qualified as Range
import Language.GraphQL.Draft.Syntax
import Prelude
-------------------------------------------------------------------------------
-- | *Generator*
type Generator :: Type -> Constraint
class Generator a where
genValue :: Gen (Value a)
instance Generator Void where
genValue = genValueWith []
instance Generator Name where
genValue = genValueWith [genName]
generate :: MonadIO m => Gen a -> m a
generate = Gen.sample
-------------------------------------------------------------------------------
-- Document
genDocument :: Gen Document
genDocument =
Document <$> Gen.list (Range.linear 0 3) genDefinition
genExecutableDocument :: Generator a => Gen (ExecutableDocument a)
genExecutableDocument =
ExecutableDocument <$> Gen.list (Range.linear 1 3) genExecutableDefinition
-------------------------------------------------------------------------------
-- Identifiers
genText :: Gen Text
genText = Gen.text (Range.linear 0 11) Gen.unicode
alpha_ :: Gen Char
alpha_ = Gen.choice [Gen.alpha, pure '_']
alphaNum_ :: Gen Char
alphaNum_ = Gen.choice [Gen.alphaNum, pure '_']
genGraphqlName :: Gen Text
genGraphqlName =
Gen.text (Range.singleton 1) alpha_
<> Gen.text (Range.linear 0 11) alphaNum_
{-# HLINT ignore "Use mkName" #-}
genName :: Gen Name
genName = unsafeMkName <$> genGraphqlName
genNullability :: Gen Nullability
genNullability = Nullability <$> Gen.bool
genType :: Gen GType
genType =
Gen.recursive
Gen.choice
[TypeNamed <$> genNullability <*> genName]
[TypeList <$> genNullability <*> genType]
genDescription :: Gen Description
genDescription = Description <$> Gen.choice [genText, genBlockText]
-------------------------------------------------------------------------------
-- Values
genValueWith :: [Gen a] -> Gen (Value a)
genValueWith varGens = Gen.recursive Gen.choice nonRecursive recursive
where
recursive =
[ VList <$> genListValue (genValueWith varGens),
VObject <$> genObjectValue (genValueWith varGens)
]
-- TODO: use maxbound of int32/double or something?
nonRecursive =
[ pure VNull,
VInt . fromIntegral <$> Gen.int32 (Range.linear 1 99999),
VEnum <$> genEnumValue,
VFloat . fromFloatDigits <$> Gen.double (Range.linearFrac 1.1 999999.99999),
VString <$> Gen.choice [genText, genBlockText],
VBoolean <$> Gen.bool
]
<> [VVariable <$> var | var <- varGens]
genEnumValue :: Gen EnumValue
genEnumValue = EnumValue <$> genName
genListValue :: Gen (Value a) -> Gen [Value a]
genListValue = mkList
genObjectValue :: Gen (Value a) -> Gen (M.HashMap Name (Value a))
genObjectValue genVal = M.fromList <$> mkList genObjectField
where
genObjectField = (,) <$> genName <*> genVal
genBlockText :: Gen Text
genBlockText = T.unlines <$> Gen.list (Range.linear 0 20) line
where
line = do
Gen.frequency
[ (10, Gen.text (Range.linear 1 10) Gen.unicode),
(10, return "\n"),
(6, genIndentation),
(5, genMinIndentedText 10),
(4, return ""),
(3, return " "),
(6, return "\t"),
(3, return "\""), -- "
(3, return "\\") -- \
]
-- | Like `genText` but with random indentation in the start of the string according
-- to a minimum value.
genMinIndentedText :: Int -> Gen Text
genMinIndentedText min_ = do
let minIndent = T.replicate min_ " "
i <- genIndentation
t <- genText
return (minIndent <> i <> t)
genIndentation :: Gen Text
genIndentation = do
Gen.text (Range.linear 0 100) (return ' ')
-------------------------------------------------------------------------------
-- Definitions
genDefinition :: Gen Definition
genDefinition =
Gen.choice
[ DefinitionExecutable <$> genExecutableDefinition,
DefinitionTypeSystem <$> genTypeSystemDefinition
]
genExecutableDefinition :: Generator a => Gen (ExecutableDefinition a)
genExecutableDefinition =
Gen.choice
[ ExecutableDefinitionOperation <$> genOperationDefinition,
ExecutableDefinitionFragment <$> genFragmentDefinition
]
genOperationDefinition :: Generator a => Gen (OperationDefinition FragmentSpread a)
genOperationDefinition =
Gen.choice
[ OperationDefinitionTyped <$> genTypedOperationDefinition,
OperationDefinitionUnTyped <$> genSelectionSet
]
genTypedOperationDefinition :: Generator a => Gen (TypedOperationDefinition FragmentSpread a)
genTypedOperationDefinition =
TypedOperationDefinition
<$> genOperationType
<*> Gen.maybe genName
<*> mkList genVariableDefinition
<*> genDirectives
<*> genSelectionSet
genVariableDefinition :: Gen VariableDefinition
genVariableDefinition =
VariableDefinition
<$> genName
<*> genType
<*> Gen.maybe genValue
genFragmentDefinition :: Gen FragmentDefinition
genFragmentDefinition =
FragmentDefinition
<$> genName
<*> genName
<*> genDirectives
<*> genSelectionSet
genTypeSystemDefinition :: Gen TypeSystemDefinition
genTypeSystemDefinition =
Gen.choice
[ TypeSystemDefinitionSchema <$> genSchemaDefinition,
TypeSystemDefinitionType <$> genTypeDefinition
]
genSchemaDefinition :: Gen SchemaDefinition
genSchemaDefinition =
SchemaDefinition
<$> Gen.maybe genDirectives
<*> mkList genRootOperationTypeDefinition
genRootOperationTypeDefinition :: Gen RootOperationTypeDefinition
genRootOperationTypeDefinition =
RootOperationTypeDefinition
<$> genOperationType
<*> genName
genOperationType :: Gen OperationType
genOperationType =
Gen.element
[ OperationTypeQuery,
OperationTypeMutation,
OperationTypeSubscription
]
genTypeDefinition :: Gen (TypeDefinition () InputValueDefinition)
genTypeDefinition =
Gen.choice
[ TypeDefinitionScalar <$> genScalarTypeDefinition,
TypeDefinitionObject <$> genObjectTypeDefinition,
TypeDefinitionInterface <$> genInterfaceTypeDefinition,
TypeDefinitionUnion <$> genUnionTypeDefinition,
TypeDefinitionEnum <$> genEnumTypeDefinition,
TypeDefinitionInputObject <$> genInputObjectTypeDefinition
]
genScalarTypeDefinition :: Gen ScalarTypeDefinition
genScalarTypeDefinition =
ScalarTypeDefinition
<$> Gen.maybe genDescription
<*> genName
<*> genDirectives
genObjectTypeDefinition :: Gen (ObjectTypeDefinition InputValueDefinition)
genObjectTypeDefinition =
ObjectTypeDefinition
<$> Gen.maybe genDescription
<*> genName
<*> mkList genName
<*> genDirectives
<*> genFieldDefinitions
genInterfaceTypeDefinition :: Gen (InterfaceTypeDefinition () InputValueDefinition)
genInterfaceTypeDefinition =
InterfaceTypeDefinition
<$> Gen.maybe genDescription
<*> genName
<*> genDirectives
<*> genFieldDefinitions
<*> pure ()
genUnionTypeDefinition :: Gen UnionTypeDefinition
genUnionTypeDefinition =
UnionTypeDefinition
<$> Gen.maybe genDescription
<*> genName
<*> genDirectives
<*> mkList genName
genEnumTypeDefinition :: Gen EnumTypeDefinition
genEnumTypeDefinition =
EnumTypeDefinition
<$> Gen.maybe genDescription
<*> genName
<*> genDirectives
<*> mkList genEnumValueDefinition
genInputObjectTypeDefinition :: Gen (InputObjectTypeDefinition InputValueDefinition)
genInputObjectTypeDefinition =
InputObjectTypeDefinition
<$> Gen.maybe genDescription
<*> genName
<*> genDirectives
<*> mkList genInputValueDefinition
genInputValueDefinition :: Gen InputValueDefinition
genInputValueDefinition =
InputValueDefinition
<$> Gen.maybe genDescription
<*> genName
<*> genType
<*> Gen.maybe genValue
<*> genDirectives
genEnumValueDefinition :: Gen EnumValueDefinition
genEnumValueDefinition =
EnumValueDefinition
<$> Gen.maybe genDescription
<*> genEnumValue
<*> genDirectives
genFieldDefinition :: Gen (FieldDefinition InputValueDefinition)
genFieldDefinition =
FieldDefinition
<$> Gen.maybe genDescription
<*> genName
<*> mkList genInputValueDefinition
<*> genType
<*> genDirectives
genFieldDefinitions :: Gen [FieldDefinition InputValueDefinition]
genFieldDefinitions = mkList genFieldDefinition
genDirectiveDefinition :: Gen (DirectiveDefinition InputValueDefinition)
genDirectiveDefinition =
DirectiveDefinition
<$> Gen.maybe genDescription
<*> genName
<*> genArgumentsDefinition
<*> Gen.list (Range.linear 1 10) genDirectiveLocation
genArgumentsDefinition :: Gen (ArgumentsDefinition InputValueDefinition)
genArgumentsDefinition = Gen.list (Range.linear 1 10) genInputValueDefinition
genDirectiveLocation :: Gen DirectiveLocation
genDirectiveLocation =
Gen.choice
[ DLExecutable <$> genExecutableDirectiveLocation,
DLTypeSystem <$> genTypeSystemDirectiveLocation
]
genExecutableDirectiveLocation :: Gen ExecutableDirectiveLocation
genExecutableDirectiveLocation =
Gen.element
[ EDLQUERY,
EDLMUTATION,
EDLSUBSCRIPTION,
EDLFIELD,
EDLFRAGMENT_DEFINITION,
EDLFRAGMENT_SPREAD,
EDLINLINE_FRAGMENT
]
genTypeSystemDirectiveLocation :: Gen TypeSystemDirectiveLocation
genTypeSystemDirectiveLocation =
Gen.element
[ TSDLSCHEMA,
TSDLSCALAR,
TSDLOBJECT,
TSDLFIELD_DEFINITION,
TSDLARGUMENT_DEFINITION,
TSDLINTERFACE,
TSDLUNION,
TSDLENUM,
TSDLENUM_VALUE,
TSDLINPUT_OBJECT,
TSDLINPUT_FIELD_DEFINITION
]
-------------------------------------------------------------------------------
-- Structure
genSelectionSet :: Generator a => Gen (SelectionSet FragmentSpread a)
genSelectionSet = mkListNonEmpty genSelection
genSelection :: Generator a => Gen (Selection FragmentSpread a)
genSelection =
Gen.recursive
Gen.choice
[ SelectionFragmentSpread <$> genFragmentSpread
]
[ SelectionField <$> genField,
SelectionInlineFragment <$> genInlineFragment
]
genFragmentSpread :: Generator a => Gen (FragmentSpread a)
genFragmentSpread =
FragmentSpread
<$> genName
<*> genDirectives
genInlineFragment :: Generator a => Gen (InlineFragment FragmentSpread a)
genInlineFragment =
InlineFragment
<$> Gen.maybe genName
<*> genDirectives
<*> genSelectionSet
genField :: Generator a => Gen (Field FragmentSpread a)
genField =
Field
<$> Gen.maybe genName
<*> genName
<*> (M.fromList <$> mkList genArgument)
<*> genDirectives
<*> genSelectionSet
genDirective :: Generator a => Gen (Directive a)
genDirective =
Directive
<$> genName
<*> (M.fromList <$> mkList genArgument)
genDirectives :: Generator a => Gen [Directive a]
genDirectives = mkList genDirective
genArgument :: Generator a => Gen (Name, Value a)
genArgument = (,) <$> genName <*> genValue
-------------------------------------------------------------------------------
-- Helpers
mkList :: Gen a -> Gen [a]
mkList = Gen.list $ Range.linear 0 11
mkListNonEmpty :: Gen a -> Gen [a]
mkListNonEmpty = Gen.list $ Range.linear 1 11

613
server/lib/graphql-parser-hs/src/Language/GraphQL/Draft/Parser.hs Normal file
View File

@ -0,0 +1,613 @@
{-# HLINT ignore "Use onLeft" #-}
{-# HLINT ignore "Use mkName" #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Description: Parse text into GraphQL ASTs
module Language.GraphQL.Draft.Parser
( executableDocument,
parseExecutableDoc,
schemaDocument,
parseTypeSystemDefinitions,
parseSchemaDocument,
Variable (..),
value,
PossibleTypes (..),
nameParser,
graphQLType,
parseGraphQLType,
Parser,
runParser,
blockString,
field,
)
where
-------------------------------------------------------------------------------
import Control.Applicative (empty, many, optional, (<|>))
import Control.Monad (foldM, guard)
import Data.Aeson.Parser (jstring)
import Data.Attoparsec.ByteString qualified as A
import Data.Attoparsec.Text
( Parser,
anyChar,
char,
many1,
match,
option,
scan,
scientific,
sepBy1,
(<?>),
)
import Data.Attoparsec.Text qualified as AT
import Data.Char
( isAsciiLower,
isAsciiUpper,
isDigit,
)
import Data.Functor (($>))
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as M
import Data.Kind (Constraint, Type)
import Data.Maybe (fromMaybe)
import Data.Scientific (Scientific)
import Data.Text (Text, find)
import Data.Text qualified as T
import Data.Text.Encoding (encodeUtf8)
import Data.Void (Void)
import Language.GraphQL.Draft.Syntax qualified as AST
import Language.GraphQL.Draft.Syntax.Name qualified as Name
import Prelude
-------------------------------------------------------------------------------
-- * Document
executableDocument :: Parser (AST.ExecutableDocument AST.Name)
executableDocument = whiteSpace *> (AST.ExecutableDocument <$> many1 definitionExecutable)
runParser :: AT.Parser a -> Text -> Either Text a
runParser parser t =
either (Left . T.pack) return $ AT.parseOnly (parser <* AT.endOfInput) t
parseExecutableDoc :: Text -> Either Text (AST.ExecutableDocument AST.Name)
parseExecutableDoc = runParser executableDocument
-- | Parser for a schema document.
schemaDocument :: Parser AST.SchemaDocument
schemaDocument = whiteSpace *> (AST.SchemaDocument <$> many1 typeSystemDefinition)
parseSchemaDocument :: Text -> Either Text AST.SchemaDocument
parseSchemaDocument = runParser schemaDocument
definitionExecutable :: Parser (AST.ExecutableDefinition AST.Name)
definitionExecutable =
AST.ExecutableDefinitionOperation <$> operationDefinition
<|> AST.ExecutableDefinitionFragment <$> fragmentDefinition
operationDefinition :: Parser (AST.OperationDefinition AST.FragmentSpread AST.Name)
operationDefinition =
AST.OperationDefinitionTyped <$> typedOperationDef
<|> (AST.OperationDefinitionUnTyped <$> selectionSet)
operationTypeParser :: Parser AST.OperationType
operationTypeParser =
AST.OperationTypeQuery <$ tok "query"
<|> AST.OperationTypeMutation <$ tok "mutation"
<|> AST.OperationTypeSubscription <$ tok "subscription"
typedOperationDef :: Parser (AST.TypedOperationDefinition AST.FragmentSpread AST.Name)
typedOperationDef =
AST.TypedOperationDefinition
<$> operationTypeParser
<*> optional nameParser
<*> optempty variableDefinitions
<*> optempty directives
<*> selectionSet
variableDefinitions :: Parser [AST.VariableDefinition]
variableDefinitions = parens (many1 variableDefinition)
variableDefinition :: Parser AST.VariableDefinition
variableDefinition =
AST.VariableDefinition <$> variable
<* tok ":"
<*> graphQLType
<*> optional defaultValue
defaultValue :: Parser (AST.Value Void)
defaultValue = tok "=" *> value
type Variable :: Type -> Constraint
class Variable var where
variable :: Parser var
instance Variable Void where
variable = empty
instance Variable AST.Name where
variable = tok "$" *> nameParser <?> "variable"
type PossibleTypes :: Type -> Constraint
class PossibleTypes pos where
possibleTypes :: Parser pos
instance PossibleTypes () where
possibleTypes = pure ()
selectionSet :: Variable var => Parser (AST.SelectionSet AST.FragmentSpread var)
selectionSet = braces $ many1 selection
selection :: Variable var => Parser (AST.Selection AST.FragmentSpread var)
selection =
AST.SelectionField <$> field
-- Inline first to catch `on` case
<|> AST.SelectionInlineFragment <$> inlineFragment
<|> AST.SelectionFragmentSpread <$> fragmentSpread
aliasAndFld :: Parser (Maybe AST.Name, AST.Name)
aliasAndFld = do
n <- nameParser
colonM <- optional (tok ":")
case colonM of
Just _ -> (Just n,) <$> nameParser
Nothing -> return (Nothing, n)
{-# INLINE aliasAndFld #-}
field :: Variable var => Parser (AST.Field AST.FragmentSpread var)
field = do
(alM, n) <- aliasAndFld
AST.Field alM n
<$> optempty arguments
<*> optempty directives
<*> optempty selectionSet
-- * Fragments
fragmentSpread :: Variable var => Parser (AST.FragmentSpread var)
-- TODO: Make sure it fails when `... on`.
-- See https://facebook.github.io/graphql/#FragmentSpread
fragmentSpread =
AST.FragmentSpread
<$ tok "..."
<*> nameParser
<*> optempty directives
-- InlineFragment tried first in order to guard against 'on' keyword
inlineFragment :: Variable var => Parser (AST.InlineFragment AST.FragmentSpread var)
inlineFragment =
AST.InlineFragment
<$ tok "..."
<*> optional (tok "on" *> nameParser)
<*> optempty directives
<*> selectionSet
fragmentDefinition :: Parser AST.FragmentDefinition
fragmentDefinition =
AST.FragmentDefinition
<$ tok "fragment"
<*> nameParser
<* tok "on"
<*> nameParser
<*> optempty directives
<*> selectionSet
-- * Values
number :: Parser (Either Scientific Integer)
number = do
(numText, num) <- match (tok scientific)
pure $ case Data.Text.find (\c -> c == '.' || c == 'e' || c == 'E') numText of
-- Number specified with decimals and/or scientific notation, so
-- store as a 'Scientific'.
Just _ -> Left num
-- No '.' and not in scientific notation, so safe to convert to integer.
Nothing -> Right (floor num)
-- This will try to pick the first type it can runParser. If you are working with
-- explicit types use the `typedValue` parser.
value :: Variable var => Parser (AST.Value var)
value =
tok
( AST.VVariable <$> variable
<|> (fmap (either AST.VFloat AST.VInt) number <?> "number")
<|> AST.VNull <$ literal "null"
<|> AST.VBoolean <$> booleanLiteral
<|> AST.VString <$> blockString
<|> AST.VString <$> stringLiteral
-- `true` and `false` have been tried before, so we can safely proceed with the enum parser
<|> AST.VEnum <$> (fmap AST.EnumValue nameParser <?> "name")
<|> AST.VList <$> listLiteral
<|> AST.VObject <$> objectLiteral
<?> "value"
)
booleanLiteral :: Parser Bool
booleanLiteral =
True <$ literal "true"
<|> False <$ literal "false"
<?> "boolean"
stringLiteral :: Parser Text
stringLiteral = unescapeText =<< (char '"' *> jstring_ <?> "string")
where
-- Parse a string without a leading quote, ignoring any escaped characters.
jstring_ :: Parser Text
jstring_ = scan False go <* anyChar
go :: Bool -> Char -> Maybe Bool
go previousWasEscapingCharacter current
-- if the previous character was an escaping character, we skip this one
| previousWasEscapingCharacter = Just False
-- otherwise, if we find an unescaped quote, we've reached the end
| current == '"' = Nothing
-- otherwise, we continue, and track whether the current character is an escaping backslash
| otherwise = Just $ current == backslash
where
backslash = '\\'
-- Unescape a string.
--
-- Turns out this is really tricky, so we're going to cheat by
-- reconstructing a literal string (by putting quotes around it) and
-- delegating all the hard work to Aeson.
unescapeText :: Text -> Parser Text
unescapeText str = either fail pure $ A.parseOnly jstring ("\"" <> encodeUtf8 str <> "\"")
listLiteral :: Variable var => Parser [AST.Value var]
listLiteral = brackets (many value) <?> "list"
objectLiteral :: Variable var => Parser (HashMap AST.Name (AST.Value var))
objectLiteral = braces (objectFields many) <?> "object"
arguments :: Variable var => Parser (HashMap AST.Name (AST.Value var))
arguments = parens (objectFields many1) <?> "arguments"
objectFields ::
Variable var =>
(forall b. Parser b -> Parser [b]) ->
Parser (HashMap AST.Name (AST.Value var))
objectFields several = foldM insertField M.empty =<< several objectField
where
objectField = (,) <$> nameParser <* tok ":" <*> value
insertField obj (k, v)
| k `M.member` obj = fail $ "multiple “" <> T.unpack (Name.unName k) <> "” fields"
| otherwise = pure (M.insert k v obj)
-- * Directives
directives :: Variable var => Parser [AST.Directive var]
directives = many1 directive
directive :: Variable var => Parser (AST.Directive var)
directive =
AST.Directive
<$ tok "@"
<*> nameParser
<*> optempty arguments
-- * Type Reference
graphQLType :: Parser AST.GType
graphQLType =
(flip AST.TypeList <$> brackets graphQLType <*> nullability)
<|> (flip AST.TypeNamed <$> nameParser <*> nullability)
<?> "type"
parseGraphQLType :: Text -> Either Text AST.GType
parseGraphQLType = runParser graphQLType
nullability :: Parser AST.Nullability
nullability =
(tok "!" $> AST.Nullability False)
<|> pure (AST.Nullability True)
-- * Type Definition
rootOperationTypeDefinition :: Parser AST.RootOperationTypeDefinition
rootOperationTypeDefinition =
AST.RootOperationTypeDefinition <$> operationTypeParser <* tok ":" <*> nameParser
schemaDefinition :: Parser AST.SchemaDefinition
schemaDefinition =
AST.SchemaDefinition
<$ tok "schema"
<*> optional directives
<*> rootOperationTypeDefinitions
rootOperationTypeDefinitions :: Parser [AST.RootOperationTypeDefinition]
rootOperationTypeDefinitions = braces $ many1 rootOperationTypeDefinition
typeSystemDefinition :: Parser AST.TypeSystemDefinition
typeSystemDefinition =
AST.TypeSystemDefinitionSchema <$> schemaDefinition
<|> AST.TypeSystemDefinitionType <$> typeDefinition
parseTypeSystemDefinitions :: Text -> Either Text [AST.TypeSystemDefinition]
parseTypeSystemDefinitions = runParser $ many1 typeSystemDefinition
typeDefinition :: Parser (AST.TypeDefinition () AST.InputValueDefinition)
typeDefinition =
AST.TypeDefinitionObject <$> objectTypeDefinition
<|> AST.TypeDefinitionInterface <$> interfaceTypeDefinition
<|> AST.TypeDefinitionUnion <$> unionTypeDefinition
<|> AST.TypeDefinitionScalar <$> scalarTypeDefinition
<|> AST.TypeDefinitionEnum <$> enumTypeDefinition
<|> AST.TypeDefinitionInputObject <$> inputObjectTypeDefinition
<?> "type definition"
optDesc :: Parser (Maybe AST.Description)
optDesc = optional (AST.Description <$> (blockString <|> stringLiteral))
objectTypeDefinition :: Parser (AST.ObjectTypeDefinition AST.InputValueDefinition)
objectTypeDefinition =
AST.ObjectTypeDefinition
<$> optDesc
<* whiteSpace
<* tok "type"
<*> nameParser
<*> optempty interfaces
<*> optempty directives
<*> fieldDefinitions
interfaces :: Parser [AST.Name]
interfaces = tok "implements" *> nameParser `sepBy1` tok "&"
fieldDefinitions :: Parser [AST.FieldDefinition AST.InputValueDefinition]
fieldDefinitions = braces $ many1 fieldDefinition
fieldDefinition :: Parser (AST.FieldDefinition AST.InputValueDefinition)
fieldDefinition =
AST.FieldDefinition
<$> optDesc
<* whiteSpace
<*> nameParser
<*> optempty argumentsDefinition
<* tok ":"
<*> graphQLType
<*> optempty directives
argumentsDefinition :: Parser (AST.ArgumentsDefinition AST.InputValueDefinition)
argumentsDefinition = parens $ many1 inputValueDefinition
interfaceTypeDefinition :: PossibleTypes pos => Parser (AST.InterfaceTypeDefinition pos AST.InputValueDefinition)
interfaceTypeDefinition =
AST.InterfaceTypeDefinition
<$> optDesc
<* whiteSpace
<* tok "interface"
<*> nameParser
<*> optempty directives
<*> fieldDefinitions
<*> possibleTypes
unionTypeDefinition :: Parser AST.UnionTypeDefinition
unionTypeDefinition =
AST.UnionTypeDefinition
<$> optDesc
<* whiteSpace
<* tok "union"
<*> nameParser
<*> optempty directives
<* tok "="
<*> unionMembers
unionMembers :: Parser [AST.Name]
unionMembers = nameParser `sepBy1` tok "|"
scalarTypeDefinition :: Parser AST.ScalarTypeDefinition
scalarTypeDefinition =
AST.ScalarTypeDefinition
<$> optDesc
<* whiteSpace
<* tok "scalar"
<*> nameParser
<*> optempty directives
enumTypeDefinition :: Parser AST.EnumTypeDefinition
enumTypeDefinition =
AST.EnumTypeDefinition
<$> optDesc
<* whiteSpace
<* tok "enum"
<*> nameParser
<*> optempty directives
<*> enumValueDefinitions
enumValueDefinitions :: Parser [AST.EnumValueDefinition]
enumValueDefinitions = braces $ many1 enumValueDefinition
enumValueDefinition :: Parser AST.EnumValueDefinition
enumValueDefinition =
AST.EnumValueDefinition
<$> optDesc
<* whiteSpace
<*> enumValue
<*> optempty directives
-- TODO: should not be one of true/false/null
enumValue :: Parser AST.EnumValue
enumValue = AST.EnumValue <$> nameParser
inputObjectTypeDefinition :: Parser (AST.InputObjectTypeDefinition AST.InputValueDefinition)
inputObjectTypeDefinition =
AST.InputObjectTypeDefinition
<$> optDesc
<* whiteSpace
<* tok "input"
<*> nameParser
<*> optempty directives
<*> inputValueDefinitions
inputValueDefinitions :: Parser [AST.InputValueDefinition]
inputValueDefinitions = braces $ many1 inputValueDefinition
inputValueDefinition :: Parser AST.InputValueDefinition
inputValueDefinition =
AST.InputValueDefinition
<$> optDesc
<* whiteSpace
<*> nameParser
<* tok ":"
<*> graphQLType
<*> optional defaultValue
<*> optempty directives
-- * Internal
tok :: AT.Parser a -> AT.Parser a
tok p = p <* whiteSpace
{-# INLINE tok #-}
-- |
-- Literal functions in the same fashion as `tok`,
-- however there are issues using `tok` when the token may be followed by additional /a-z0-9/i characters.
-- This manifests in bugs such as #20 where columns in on_conflict clauses prefixed with keywords
-- e.g. "nullColumn" actually end up parsing as "[null, Column]".
--
-- Adding in a seperate lexing pass would probably be the right way to resolve this behaviour.
-- This is a simple initial fix to address the bug with more involved changes being able to be
-- considered seperately.
literal :: AT.Parser a -> AT.Parser a
literal p = p <* ends <* whiteSpace
{-# INLINE literal #-}
ends :: AT.Parser ()
ends = do
mc <- AT.peekChar
case mc of
Nothing -> pure ()
Just c -> guard (not (isNonFirstChar c))
comment :: Parser ()
comment =
AT.char '#'
*> AT.skipWhile (\c -> c /= '\n' && c /= '\r')
{-# INLINE comment #-}
isSpaceLike :: Char -> Bool
isSpaceLike c =
c == '\t' || c == ' ' || c == '\n' || c == '\r' || c == ','
{-# INLINE isSpaceLike #-}
whiteSpace :: AT.Parser ()
whiteSpace = do
AT.skipWhile isSpaceLike
(comment *> whiteSpace) <|> pure ()
nameParser :: AT.Parser AST.Name
nameParser =
AST.unsafeMkName
<$> tok
( (<>) <$> AT.takeWhile1 isFirstChar
<*> AT.takeWhile isNonFirstChar
)
{-# INLINE nameParser #-}
isFirstChar :: Char -> Bool
isFirstChar x = isAsciiLower x || isAsciiUpper x || x == '_'
{-# INLINE isFirstChar #-}
isNonFirstChar :: Char -> Bool
isNonFirstChar x = isFirstChar x || isDigit x
{-# INLINE isNonFirstChar #-}
parens :: Parser a -> Parser a
parens = between "(" ")"
braces :: Parser a -> Parser a
braces = between "{" "}"
brackets :: Parser a -> Parser a
brackets = between "[" "]"
between :: Parser Text -> Parser Text -> Parser a -> Parser a
between open close p = tok open *> p <* tok close
-- `empty` /= `pure mempty` for `Parser`.
optempty :: Monoid a => Parser a -> Parser a
optempty = option mempty
type Expecting :: Type
data Expecting
= Anything
| Open
| Closed
type BlockState :: Type
data BlockState
= Escaped Expecting
| Quoting Expecting
| Continue
| Done
-- | Parses strings delimited by triple quotes.
-- http://spec.graphql.org/June2018/#sec-String-Value
blockString :: Parser Text
blockString = extractText <$> ("\"\"\"" *> blockContents)
where
blockContents =
AT.runScanner Continue scanner >>= \case
-- this drop the parsed closing quotes (since we are using a different parser)
(textBlock, Done) -> return $ T.lines (T.dropEnd 3 textBlock)
-- there is only one way to get to a Done, so we need this here because runScanner never fails
_ -> fail "couldn't parse block string"
extractText =
-- The reason we have this replace here is to convert
-- an escaped triple-quotes to the way it should be
-- represented in the parsed strings. The printer will
-- deal with it normally.
T.replace "\\\"\"\"" "\"\"\"" . \case
[] -> ""
-- we keep the first line apart as, per the specification, it should not count for
-- the calculation of the common minimum indentation:
-- see item 3.a in http://spec.graphql.org/June2018/#BlockStringValue()
headline : indentedRemainder ->
let commonIndentation = minimum $ (maxBound :) $ countIndentation <$> indentedRemainder
rlines = T.drop commonIndentation <$> indentedRemainder
in rebuild (sanitize $ headline : rlines)
-- Take characters from the block string until the first
-- non-escaped triple quotes.
scanner :: BlockState -> Char -> Maybe BlockState
scanner s ch =
case s of
Done -> Nothing
Continue ->
case ch of
'\\' -> Just (Escaped Anything)
'"' -> Just (Quoting Open)
_ -> Just Continue
-- we are counting " for a possible closing delimiter
Quoting Open -> if ch == '"' then Just (Quoting Closed) else Just Continue
Quoting Closed -> if ch == '"' then Just Done else Just Continue
Quoting _ -> Just Continue
-- we are counting escaped characters when "
Escaped Anything -> if ch == '"' then Just (Escaped Open) else Just Continue
Escaped Open -> if ch == '"' then Just (Escaped Closed) else Just Continue
Escaped Closed -> Just Continue
-- Joins all the lines into a single block of text
-- we drop the last new line character that is added
-- automatically by T.unlines
rebuild :: [Text] -> Text
rebuild = maybe "" fst . T.unsnoc . T.unlines
sanitize :: [Text] -> [Text]
sanitize = dropWhileEnd' onlyWhiteSpace . dropWhile onlyWhiteSpace
onlyWhiteSpace :: Text -> Bool
onlyWhiteSpace = T.all isWhitespace
countIndentation :: Text -> Int
countIndentation = fromMaybe maxBound . T.findIndex (not . isWhitespace)
-- whitespace
isWhitespace :: Char -> Bool
isWhitespace c = c == ' ' || c == '\t'
-- copied from https://hackage.haskell.org/package/extra-1.7.9/docs/src/Data.List.Extra.html
dropWhileEnd' :: (a -> Bool) -> [a] -> [a]
dropWhileEnd' p = foldr (\x xs -> if null xs && p x then [] else x : xs) []

17
server/lib/graphql-parser-hs/src/Language/GraphQL/Draft/Parser.hs-boot Normal file
View File

@ -0,0 +1,17 @@
module Language.GraphQL.Draft.Parser
( parseExecutableDoc,
parseSchemaDocument,
)
where
-------------------------------------------------------------------------------
import Data.Text (Text)
import {-# SOURCE #-} Language.GraphQL.Draft.Syntax qualified as AST
import Language.GraphQL.Draft.Syntax.Name (Name)
import Prelude (Either)
-------------------------------------------------------------------------------
parseExecutableDoc :: Text -> Either Text (AST.ExecutableDocument Name)
parseSchemaDocument :: Text -> Either Text AST.SchemaDocument

476
server/lib/graphql-parser-hs/src/Language/GraphQL/Draft/Printer.hs Normal file
View File

@ -0,0 +1,476 @@
module Language.GraphQL.Draft.Printer where
-------------------------------------------------------------------------------
import Data.Aeson qualified as J
import Data.Bool (bool)
import Data.ByteString.Builder qualified as BS
import Data.ByteString.Builder.Scientific qualified as BSBS
import Data.Char (isControl)
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as M
import Data.Kind (Constraint, Type)
import Data.List (intersperse, sort)
import Data.Scientific (Scientific)
import Data.String (IsString)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Lazy qualified as LT hiding (singleton)
import Data.Text.Lazy.Builder qualified as LT (Builder)
import Data.Text.Lazy.Builder qualified as LTB
import Data.Text.Lazy.Builder.Int qualified as LTBI
import Data.Text.Lazy.Builder.Scientific qualified as LTBS
import Data.Text.Lazy.Encoding qualified as LTE
import Data.Void (Void, absurd)
import Language.GraphQL.Draft.Syntax
import Language.GraphQL.Draft.Syntax.Name qualified as Name
import Prettyprinter qualified as PP
import Text.Builder qualified as Text
import Prelude
-------------------------------------------------------------------------------
type Printer :: Type -> Constraint
class (Monoid a, IsString a) => Printer a where
textP :: Text -> a
charP :: Char -> a
intP :: Integer -> a
doubleP :: Scientific -> a
{-# MINIMAL textP, charP, intP, doubleP #-}
nameP :: Name -> a
nameP = textP . Name.unName
nodeP :: (Print (frag var), Print var) => TypedOperationDefinition frag var -> a
nodeP = node
selectionSetP :: (Print (frag var), Print var) => SelectionSet frag var -> a
selectionSetP = selectionSet
instance Printer BS.Builder where
textP = LTE.encodeUtf8Builder . LT.fromStrict
{-# INLINE textP #-}
charP = BS.charUtf8
{-# INLINE charP #-}
intP = BS.integerDec
{-# INLINE intP #-}
doubleP = BSBS.scientificBuilder
{-# INLINE doubleP #-}
instance Printer LT.Builder where
textP = LTB.fromText
{-# INLINE textP #-}
charP = LTB.singleton
{-# INLINE charP #-}
intP = LTBI.decimal
{-# INLINE intP #-}
doubleP = LTBS.scientificBuilder
{-# INLINE doubleP #-}
instance Printer (PP.Doc Text) where
textP = PP.pretty
{-# INLINE textP #-}
charP = PP.pretty
{-# INLINE charP #-}
intP = PP.pretty
{-# INLINE intP #-}
-- NOTE: @prettyprinter@ constructs its 'Int', 'Float', etc. instances with
-- 'unsafeViaShow', so it fine for us to use it here since 'Scientific'
-- satisfies the requirement that the 'Show' instance must not have newlines.
doubleP = PP.unsafeViaShow
{-# INLINE doubleP #-}
nameP = PP.pretty
{-# INLINE nameP #-}
instance Printer Text.Builder where
textP = Text.text
{-# INLINE textP #-}
charP = Text.char
{-# INLINE charP #-}
intP = Text.decimal
{-# INLINE intP #-}
doubleP = Text.string . show
{-# INLINE doubleP #-}
type Print :: Type -> Constraint
class Print a where
printP :: Printer b => a -> b
instance Print Void where
printP = absurd
instance Print Name where
printP = nameP
renderExecutableDoc :: ExecutableDocument Name -> Text
renderExecutableDoc = Text.run . executableDocument
-- | the pretty printer implementation
executableDocument :: (Print var, Printer a) => ExecutableDocument var -> a
executableDocument ed =
mconcat $
intersperse (charP '\n') $
map executableDefinition $
getExecutableDefinitions ed
executableDefinition :: (Print var, Printer a) => ExecutableDefinition var -> a
executableDefinition = \case
ExecutableDefinitionOperation d -> operationDefinition d
ExecutableDefinitionFragment d -> fragmentDefinition d
operationDefinition :: (Print (frag var), Print var, Printer a) => OperationDefinition frag var -> a
operationDefinition = \case
OperationDefinitionUnTyped selSet -> selectionSetP selSet
OperationDefinitionTyped op -> typedOperationDefinition op
typedOperationDefinition :: (Print (frag var), Print var, Printer a) => TypedOperationDefinition frag var -> a
typedOperationDefinition op =
operationType (_todType op) <> charP ' ' <> nodeP op
operationType :: Printer a => OperationType -> a
operationType = \case
OperationTypeQuery -> "query"
OperationTypeMutation -> "mutation"
OperationTypeSubscription -> "subscription"
-- TODO: add horizontal nesting
node :: (Print (frag var), Print var, Printer a) => TypedOperationDefinition frag var -> a
node (TypedOperationDefinition _ name vars dirs sels) =
maybe mempty nameP name
<> optempty variableDefinitions vars
<> optempty directives dirs
<> charP ' '
<> selectionSetP sels
-- TODO: add horizontal nesting
selectionSet :: (Print (frag var), Print var, Printer a) => SelectionSet frag var -> a
selectionSet [] = mempty
selectionSet xs =
"{ " <> mconcat (intersperse (charP ' ') (map selection xs)) <> " }"
selection :: (Print (frag var), Print var, Printer a) => Selection frag var -> a
selection = \case
SelectionField fld -> field fld
SelectionFragmentSpread fs -> printP fs
SelectionInlineFragment ilf -> inlineFragment ilf
field :: (Print (frag var), Print var, Printer a) => Field frag var -> a
field (Field alias name args dirs selSets) =
optAlias alias
<> nameP name
<> optempty arguments args
<> optempty directives dirs
<> charP ' '
<> selectionSetP selSets
optAlias :: Printer a => Maybe Name -> a
optAlias = maybe mempty (\a -> nameP a <> textP ": ")
inlineFragment :: (Print (frag var), Print var, Printer a) => InlineFragment frag var -> a
inlineFragment (InlineFragment tc ds sels) =
"... "
<> maybe mempty ((textP "on " <>) . nameP) tc
<> optempty directives ds
<> selectionSetP sels
instance Print var => Print (FragmentSpread var) where
printP (FragmentSpread name ds) =
"..." <> nameP name <> optempty directives ds
instance Print (NoFragments var) where
printP = \case {}
fragmentDefinition :: Printer a => FragmentDefinition -> a
fragmentDefinition (FragmentDefinition name tc dirs sels) =
"fragment "
<> nameP name
<> " on "
<> nameP tc
<> optempty directives dirs
<> selectionSetP sels
directives :: (Print var, Printer a) => [Directive var] -> a
directives = mconcat . intersperse (charP ' ') . map directive
directive :: (Print var, Printer a) => Directive var -> a
directive (Directive name args) =
charP '@' <> nameP name <> optempty arguments args
arguments :: (Print var, Printer a) => HashMap Name (Value var) -> a
arguments xs = charP '(' <> objectFields xs <> charP ')'
variableDefinitions :: Printer a => [VariableDefinition] -> a
variableDefinitions vars =
mconcat
[ charP '(',
mconcat vars',
charP ')'
]
where
vars' = intersperse (charP ',') $ map variableDefinition vars
variableDefinition :: Printer a => VariableDefinition -> a
variableDefinition (VariableDefinition var ty defVal) =
variableP var <> ": " <> graphQLType ty <> maybe mempty defaultValue defVal
defaultValue :: Printer a => Value Void -> a
defaultValue v = " = " <> value v
description :: Printer a => Maybe Description -> a
description Nothing = mempty
description (Just desc) = dispatchStringPrinter (unDescription desc) <> " \n"
-- | Type Reference
graphQLType :: Printer a => GType -> a
graphQLType (TypeNamed n x) = nameP x <> nonNull n
graphQLType (TypeList n x) = listType x <> nonNull n
listType :: Printer a => GType -> a
listType ty = charP '[' <> graphQLType ty <> charP ']'
nonNull :: Printer a => Nullability -> a
nonNull n = bool (charP '!') mempty $ unNullability n
-- | Primitives
variableP :: (Print a, Printer b) => a -> b
variableP v = charP '$' <> printP v
value :: (Print var, Printer a) => Value var -> a
value = \case
VVariable v -> variableP v
VInt i -> intP i
VFloat d -> doubleP d
VString s -> dispatchStringPrinter s
VBoolean b -> fromBool b
VNull -> "null"
VList xs -> listValue xs
VObject o -> objectValue o
VEnum ev -> nameP $ unEnumValue ev
-- | Print a given text as a normal string or as a block string, depending on
-- its content.
dispatchStringPrinter :: Printer a => Text -> a
dispatchStringPrinter t =
if printAsBlockString then blockStringValue t else stringValue t
where
printAsBlockString =
hasNewlines && onlySourceCharacter && not (hasWhitespaceEnd || hasZeroIndentation || hasTripleQuotes)
-- Condition 1: if there are no newlines, there's no point to print a text
-- as a block string
hasNewlines = "\n" `T.isInfixOf` t
-- Condition 2: block strings only support GraphQL's SourceCharacters
-- http://spec.graphql.org/June2018/#SourceCharacter
onlySourceCharacter = T.all isSourceCharacter t
-- Condition 3: if the text ends in a line containing only whitespace, we
-- can't print it as a block string
hasWhitespaceEnd = T.all isWhitespace $ T.takeWhileEnd (/= '\n') t
-- Condition 4: if none of the remaining lines (i.e. not the first line)
-- contains nonzero indentation, we can't print it as a block string
hasZeroIndentation = any lineZeroIndentation $ tail $ T.lines t
where
lineZeroIndentation line = case T.uncons line of
Nothing -> False -- empty lines don't count
Just (firstChar, _) -> not (isWhitespace firstChar)
-- Condition 5: although """ is printable in block strings as \""", this
-- isn't currently implemented
hasTripleQuotes = "\"\"\"" `T.isInfixOf` t
isWhitespace :: Char -> Bool
isWhitespace c = c == ' ' || c == '\t'
isSourceCharacter :: Char -> Bool
isSourceCharacter = not . isControl
-- | We use Aeson to decode string values, and therefore use Aeson to encode them back.
stringValue :: Printer a => Text -> a
stringValue s = textP $ LT.toStrict $ LTE.decodeUtf8 $ J.encode s
blockStringValue :: Printer a => Text -> a
blockStringValue t = textP "\"\"\"\n" <> textP t <> textP "\n\"\"\""
listValue :: (Print var, Printer a) => [Value var] -> a
listValue xs = mconcat [charP '[', li, charP ']']
where
li = mconcat $ intersperse (charP ',') $ map value xs
objectValue :: (Print var, Printer a) => HashMap Name (Value var) -> a
objectValue o = charP '{' <> objectFields o <> charP '}'
objectFields :: (Print var, Printer a) => HashMap Name (Value var) -> a
objectFields o = mconcat $ intersperse (charP ',') $ map objectField $ M.toList o
where
objectField (name, val) = nameP name <> ": " <> value val
fromBool :: Printer a => Bool -> a
fromBool True = "true"
fromBool False = "false"
optempty :: (Foldable f, Monoid b) => (f a -> b) -> f a -> b
optempty f xs
| null xs = mempty
| otherwise = f xs
schemaDefinition ::
forall a.
Printer a =>
SchemaDefinition ->
a
schemaDefinition (SchemaDefinition dirs rootOpDefs) =
"schema "
<> maybe mempty (optempty directives) dirs
<> " { "
<> mconcat (intersperse (charP ' ') (map rootOperationTypeDefinition rootOpDefs))
<> " }"
rootOperationTypeDefinition :: Printer a => RootOperationTypeDefinition -> a
rootOperationTypeDefinition (RootOperationTypeDefinition opType rootName) =
operationType opType <> ": " <> nameP rootName
typeSystemDefinition :: Printer a => TypeSystemDefinition -> a
typeSystemDefinition (TypeSystemDefinitionSchema schemaDefn) = schemaDefinition schemaDefn
typeSystemDefinition (TypeSystemDefinitionType typeDefn) = typeDefinitionP typeDefn
schemaDocument :: Printer a => SchemaDocument -> a
schemaDocument (SchemaDocument typeDefns) =
mconcat $ intersperse (textP "\n\n") $ map typeSystemDefinition $ sort typeDefns
typeDefinitionP :: Printer a => TypeDefinition () InputValueDefinition -> a
typeDefinitionP (TypeDefinitionScalar scalarDefn) = scalarTypeDefinition scalarDefn
typeDefinitionP (TypeDefinitionObject objDefn) = objectTypeDefinition objDefn
typeDefinitionP (TypeDefinitionInterface interfaceDefn) = interfaceTypeDefinition interfaceDefn
typeDefinitionP (TypeDefinitionUnion unionDefn) = unionTypeDefinition unionDefn
typeDefinitionP (TypeDefinitionEnum enumDefn) = enumTypeDefinition enumDefn
typeDefinitionP (TypeDefinitionInputObject inpObjDefn) = inputObjectTypeDefinition inpObjDefn
scalarTypeDefinition :: Printer a => ScalarTypeDefinition -> a
scalarTypeDefinition (ScalarTypeDefinition desc name dirs) =
description desc
<> "scalar "
<> nameP name
<> if null dirs
then mempty
else charP ' ' <> optempty directives dirs
inputValueDefinition :: Printer a => InputValueDefinition -> a
inputValueDefinition (InputValueDefinition desc name gType defVal dirs) =
description desc
<> nameP name
<> textP ": "
<> graphQLType gType
<> maybe mempty defaultValue defVal
<> if null dirs
then mempty
else charP ' ' <> optempty directives dirs
fieldDefinition :: Printer a => FieldDefinition InputValueDefinition -> a
fieldDefinition (FieldDefinition desc name args gType dirs) =
description desc
<> nameP name
<> case args of
[] -> mempty
_ ->
charP '('
<> mconcat (intersperse (textP ", ") $ map inputValueDefinition args)
<> charP ')'
<> textP ": "
<> graphQLType gType
<> optempty directives dirs
objectTypeDefinition :: Printer a => ObjectTypeDefinition InputValueDefinition -> a
objectTypeDefinition (ObjectTypeDefinition desc name ifaces dirs fieldDefinitions) =
description desc
<> "type "
<> nameP name
<> optempty directives dirs
<> case ifaces of
[] -> mempty
_ -> " implements " <> mconcat (intersperse (textP " & ") $ map nameP ifaces)
<> " { "
<> ( mconcat
. intersperse (textP "\n ")
. map fieldDefinition
. sort
$ fieldDefinitions
)
<> "\n"
<> "}"
interfaceTypeDefinition :: Printer a => InterfaceTypeDefinition () InputValueDefinition -> a
interfaceTypeDefinition (InterfaceTypeDefinition desc name dirs fieldDefinitions _possibleTypes) =
-- `possibleTypes` are not included with an interface definition in a GraphQL IDL
description desc
<> "interface "
<> nameP name
<> charP ' '
<> optempty directives dirs
<> " { "
<> mconcat
( intersperse (textP "\n ")
. map fieldDefinition
. sort
$ fieldDefinitions
)
<> "\n"
<> "}"
unionTypeDefinition :: Printer a => UnionTypeDefinition -> a
unionTypeDefinition (UnionTypeDefinition desc name dirs members) =
description desc
<> "union "
<> nameP name
<> charP ' '
<> optempty directives dirs
<> textP " = "
<> mconcat (intersperse (textP " | ") $ map nameP $ sort members)
enumValueDefinition :: Printer a => EnumValueDefinition -> a
enumValueDefinition (EnumValueDefinition desc name dirs) =
description desc
<> nameP (unEnumValue name)
<> charP ' '
<> optempty directives dirs
enumTypeDefinition :: Printer a => EnumTypeDefinition -> a
enumTypeDefinition (EnumTypeDefinition desc name dirs enumValDefns) =
description desc
<> "enum "
<> nameP name
<> optempty directives dirs
<> " {"
<> mconcat
( intersperse (textP "\n ")
. map enumValueDefinition
. sort
$ enumValDefns
)
<> "\n"
<> "}"
inputObjectTypeDefinition :: Printer a => InputObjectTypeDefinition InputValueDefinition -> a
inputObjectTypeDefinition (InputObjectTypeDefinition desc name dirs valDefns) =
description desc
<> "input "
<> nameP name
<> optempty directives dirs
<> " {"
<> mconcat
( intersperse (textP "\n ")
. map inputValueDefinition
. sort
$ valDefns
)
<> "\n"
<> "}"

14
server/lib/graphql-parser-hs/src/Language/GraphQL/Draft/Printer.hs-boot Normal file
View File

@ -0,0 +1,14 @@
module Language.GraphQL.Draft.Printer
( renderExecutableDoc,
)
where
-------------------------------------------------------------------------------
import Data.Text (Text)
import {-# SOURCE #-} Language.GraphQL.Draft.Syntax (ExecutableDocument)
import Language.GraphQL.Draft.Syntax.Name (Name)
-------------------------------------------------------------------------------
renderExecutableDoc :: ExecutableDocument Name -> Text

621
server/lib/graphql-parser-hs/src/Language/GraphQL/Draft/Syntax.hs Normal file
View File

@ -0,0 +1,621 @@
{-# HLINT ignore "Use onLeft" #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TemplateHaskell #-}
-- | Description: The GraphQL AST
module Language.GraphQL.Draft.Syntax
( -- * Basics
Name,
unName,
mkName,
unsafeMkName,
parseName,
litName,
isValidName,
NameSuffix,
unNameSuffix,
mkNameSuffix,
addSuffixes,
convertNameToSuffix,
parseSuffix,
litSuffix,
litGQLIdentifier,
Description (..),
Value (..),
literal,
EnumValue (..),
Directive (..),
-- * Types
GType (..),
getBaseType,
Nullability (..),
showGT,
showLT,
isNullable,
isNotNull,
isListType,
-- * Documents
Document (..),
ExecutableDocument (..),
SchemaDocument (..),
SchemaIntrospection (..),
-- * Definitions
Definition (..),
DirectiveDefinition (..),
DirectiveLocation (..),
-- ** Type system definitions
TypeSystemDefinition (..),
SchemaDefinition (..),
RootOperationTypeDefinition (..),
TypeDefinition (..),
ObjectTypeDefinition (..),
FieldDefinition (..),
ArgumentsDefinition,
InputValueDefinition (..),
InterfaceTypeDefinition (..),
UnionTypeDefinition (..),
ScalarTypeDefinition (..),
EnumTypeDefinition (..),
EnumValueDefinition (..),
InputObjectTypeDefinition (..),
TypeSystemDirectiveLocation (..),
-- ** Executable definitions
ExecutableDefinition (..),
partitionExDefs,
OperationDefinition (..),
OperationType (..),
TypedOperationDefinition (..),
VariableDefinition (..),
ExecutableDirectiveLocation (..),
FragmentDefinition (..),
-- * Queries
SelectionSet,
Selection (..),
Field (..),
FragmentSpread (..),
NoFragments,
InlineFragment (..),
-- ** Fragment conversion functions
inline,
fmapFieldFragment,
fmapSelectionSetFragment,
fmapSelectionFragment,
fmapInlineFragment,
)
where
-------------------------------------------------------------------------------
import Control.DeepSeq (NFData)
import Data.Aeson qualified as J
import Data.Bifunctor (Bifunctor (bimap))
import Data.Bool (bool)
import Data.HashMap.Strict (HashMap)
import Data.Hashable (Hashable)
import Data.Kind (Type)
import Data.Scientific (Scientific)
import Data.String (IsString (..))
import Data.Text (Text)
import Data.Void (Void, absurd)
import GHC.Generics (Generic)
import Instances.TH.Lift ()
import {-# SOURCE #-} Language.GraphQL.Draft.Parser
( parseExecutableDoc,
parseSchemaDocument,
)
import {-# SOURCE #-} Language.GraphQL.Draft.Printer (renderExecutableDoc)
import Language.GraphQL.Draft.Syntax.Internal (liftTypedHashMap)
import Language.GraphQL.Draft.Syntax.Name
import Language.Haskell.TH.Syntax (Lift)
import Language.Haskell.TH.Syntax qualified as TH
import Prelude
-------------------------------------------------------------------------------
-- * Documents
type Document :: Type
newtype Document = Document {getDefinitions :: [Definition]}
deriving stock (Eq, Lift, Ord, Show)
type Definition :: Type
data Definition
= DefinitionExecutable (ExecutableDefinition Name)
| DefinitionTypeSystem TypeSystemDefinition
deriving stock (Eq, Generic, Lift, Ord, Show)
instance Hashable Definition
type ExecutableDocument :: Type -> Type
newtype ExecutableDocument var = ExecutableDocument {getExecutableDefinitions :: [ExecutableDefinition var]}
deriving stock (Eq, Lift, Ord, Show, Functor, Foldable, Traversable)
deriving newtype (Hashable, NFData)
instance J.FromJSON (ExecutableDocument Name) where
parseJSON = J.withText "ExecutableDocument" $ \t ->
case parseExecutableDoc t of
Right a -> return a
Left _ -> fail "parsing the graphql query failed"
instance J.ToJSON (ExecutableDocument Name) where
toJSON = J.String . renderExecutableDoc
type ExecutableDefinition :: Type -> Type
data ExecutableDefinition var
= ExecutableDefinitionOperation (OperationDefinition FragmentSpread var)
| ExecutableDefinitionFragment FragmentDefinition
deriving stock (Eq, Generic, Lift, Ord, Show, Functor, Foldable, Traversable)
instance Hashable var => Hashable (ExecutableDefinition var)
instance NFData var => NFData (ExecutableDefinition var)
partitionExDefs ::
[ExecutableDefinition var] ->
( [SelectionSet FragmentSpread var],
[TypedOperationDefinition FragmentSpread var],
[FragmentDefinition]
)
partitionExDefs = foldr f ([], [], [])
where
f d (selSets, ops, frags) = case d of
ExecutableDefinitionOperation (OperationDefinitionUnTyped t) ->
(t : selSets, ops, frags)
ExecutableDefinitionOperation (OperationDefinitionTyped t) ->
(selSets, t : ops, frags)
ExecutableDefinitionFragment frag ->
(selSets, ops, frag : frags)
type TypeSystemDefinition :: Type
data TypeSystemDefinition
= TypeSystemDefinitionSchema SchemaDefinition
| TypeSystemDefinitionType (TypeDefinition () InputValueDefinition) -- No 'possibleTypes' specified for interfaces
deriving stock (Eq, Generic, Lift, Ord, Show)
deriving anyclass (Hashable, NFData)
type SchemaDefinition :: Type
data SchemaDefinition = SchemaDefinition
{ _sdDirectives :: Maybe [Directive Void],
_sdRootOperationTypeDefinitions :: [RootOperationTypeDefinition]
}
deriving stock (Eq, Generic, Lift, Ord, Show)
deriving anyclass (Hashable, NFData)
type RootOperationTypeDefinition :: Type
data RootOperationTypeDefinition = RootOperationTypeDefinition
{ _rotdOperationType :: OperationType,
_rotdOperationTypeType :: Name
}
deriving stock (Eq, Generic, Lift, Ord, Show)
deriving anyclass (Hashable, NFData)
type OperationType :: Type
data OperationType
= OperationTypeQuery
| OperationTypeMutation
| OperationTypeSubscription
deriving stock (Eq, Generic, Lift, Ord, Show)
deriving anyclass (Hashable, NFData)
type SchemaDocument :: Type
newtype SchemaDocument
= SchemaDocument [TypeSystemDefinition]
deriving stock (Eq, Generic, Lift, Ord, Show)
deriving newtype (Hashable, NFData)
instance J.FromJSON SchemaDocument where
parseJSON = J.withText "SchemaDocument" $ \t ->
case parseSchemaDocument t of
Right schemaDoc -> return schemaDoc
Left err -> fail $ "parsing the schema document: " <> show err
-- | A variant of 'SchemaDocument' that additionally stores, for each interface,
-- the list of object types that implement that interface. Types are indexed by
-- their name for fast lookups.
type SchemaIntrospection :: Type
newtype SchemaIntrospection
= SchemaIntrospection (HashMap Name (TypeDefinition [Name] InputValueDefinition))
deriving stock (Eq, Generic, Ord, Show)
deriving newtype (Hashable)
type OperationDefinition :: (Type -> Type) -> Type -> Type
data OperationDefinition frag var
= OperationDefinitionTyped (TypedOperationDefinition frag var)
| OperationDefinitionUnTyped (SelectionSet frag var)
deriving stock (Eq, Generic, Lift, Ord, Show, Functor, Foldable, Traversable)
deriving anyclass (Hashable, NFData)
type TypedOperationDefinition :: (Type -> Type) -> Type -> Type
data TypedOperationDefinition frag var = TypedOperationDefinition
{ _todType :: OperationType,
_todName :: Maybe Name,
_todVariableDefinitions :: [VariableDefinition],
_todDirectives :: [Directive var],
_todSelectionSet :: SelectionSet frag var
}
deriving stock (Eq, Generic, Lift, Ord, Show, Functor, Foldable, Traversable)
deriving anyclass (Hashable, NFData)
type VariableDefinition :: Type
data VariableDefinition = VariableDefinition
{ _vdName :: Name,
_vdType :: GType,
_vdDefaultValue :: Maybe (Value Void)
}
deriving stock (Eq, Generic, Lift, Ord, Show)
deriving anyclass (Hashable, NFData)
type SelectionSet :: (Type -> Type) -> Type -> Type
type SelectionSet frag var = [Selection frag var]
type Selection :: (Type -> Type) -> Type -> Type
data Selection frag var
= SelectionField (Field frag var)
| SelectionFragmentSpread (frag var)
| SelectionInlineFragment (InlineFragment frag var)
deriving stock (Eq, Generic, Lift, Ord, Show, Functor, Foldable, Traversable)
deriving anyclass (Hashable, NFData)
type Field :: (Type -> Type) -> Type -> Type
data Field frag var = Field
{ _fAlias :: Maybe Name,
_fName :: Name,
_fArguments :: HashMap Name (Value var),
_fDirectives :: [Directive var],
_fSelectionSet :: SelectionSet frag var
}
deriving stock (Eq, Generic, Ord, Show, Functor, Foldable, Traversable)
deriving anyclass (Hashable, NFData)
instance (Lift (frag var), Lift var) => Lift (Field frag var) where
liftTyped Field {..} =
[||
Field
{ _fAlias,
_fName,
_fDirectives,
_fSelectionSet,
_fArguments = $$(liftTypedHashMap _fArguments)
}
||]
-- * Fragments
type FragmentSpread :: Type -> Type
data FragmentSpread var = FragmentSpread
{ _fsName :: Name,
_fsDirectives :: [Directive var]
}
deriving stock (Eq, Generic, Lift, Ord, Show, Functor, Foldable, Traversable)
deriving anyclass (Hashable, NFData)
-- | Can be used in place of the @frag@ parameter to various AST types to
-- guarante that the AST does not include any fragment spreads.
--
-- Note: This is equivalent to @'Const' 'Void'@, but annoyingly, 'Const' does
-- not provide a 'Lift' instance as of GHC 8.6.
type NoFragments :: Type -> Type
data NoFragments var
deriving stock (Eq, Generic, Lift, Ord, Show, Functor, Foldable, Traversable)
deriving anyclass (Hashable, NFData)
type InlineFragment :: (Type -> Type) -> Type -> Type
data InlineFragment frag var = InlineFragment
{ _ifTypeCondition :: Maybe Name,
_ifDirectives :: [Directive var],
_ifSelectionSet :: SelectionSet frag var
}
deriving stock (Eq, Generic, Lift, Ord, Show, Functor, Foldable, Traversable)
deriving anyclass (Hashable, NFData)
type FragmentDefinition :: Type
data FragmentDefinition = FragmentDefinition
{ _fdName :: Name,
_fdTypeCondition :: Name,
_fdDirectives :: [Directive Name],
_fdSelectionSet :: SelectionSet FragmentSpread Name
}
deriving stock (Eq, Generic, Lift, Ord, Show)
deriving anyclass (Hashable, NFData)
-- * Values
type Value :: Type -> Type
data Value var
= VVariable var
| VNull
| VInt Integer
| VFloat Scientific
| VString Text
| VBoolean Bool
| VEnum EnumValue
| VList [Value var]
| VObject (HashMap Name (Value var))
deriving stock (Eq, Generic, Ord, Show, Functor, Foldable, Traversable)
deriving anyclass (Hashable, NFData)
instance Lift var => Lift (Value var) where
liftTyped (VVariable a) = [||VVariable a||]
liftTyped VNull = [||VNull||]
liftTyped (VInt a) = [||VInt a||]
liftTyped (VFloat a) = [||VFloat $ fromRational $$(TH.liftTyped $ toRational a)||]
liftTyped (VString a) = [||VString a||]
liftTyped (VBoolean a) = [||VBoolean a||]
liftTyped (VEnum a) = [||VEnum a||]
liftTyped (VList a) = [||VList a||]
liftTyped (VObject a) = [||VObject $$(liftTypedHashMap a)||]
literal :: Value Void -> Value var
literal = fmap absurd
-- * Directives
type Directive :: Type -> Type
data Directive var = Directive
{ _dName :: Name,
_dArguments :: HashMap Name (Value var)
}
deriving stock (Eq, Generic, Ord, Show, Functor, Foldable, Traversable)
deriving anyclass (Hashable, NFData)
instance Lift var => Lift (Directive var) where
liftTyped Directive {..} =
[||
Directive
{ _dName,
_dArguments = $$(liftTypedHashMap _dArguments)
}
||]
-- * Type Reference
type Nullability :: Type
newtype Nullability = Nullability {unNullability :: Bool}
deriving stock (Eq, Generic, Lift, Ord, Show)
deriving newtype (Hashable, NFData)
type GType :: Type
data GType
= TypeNamed Nullability Name
| TypeList Nullability GType
deriving stock (Eq, Generic, Lift, Ord, Show)
deriving anyclass (Hashable, NFData)
getBaseType :: GType -> Name
getBaseType = \case
TypeNamed _ namedType -> namedType
TypeList _ listType -> getBaseType listType
instance J.ToJSON GType where
toJSON = J.toJSON . showGT
showGT :: GType -> Text
showGT = \case
TypeNamed nullability nt -> unName nt <> showNullable nullability
TypeList nullability lt -> showLT lt <> showNullable nullability
showNullable :: Nullability -> Text
showNullable = bool "!" "" . unNullability
showLT :: GType -> Text
showLT lt = "[" <> showGT lt <> "]"
isNullable :: GType -> Bool
isNullable = \case
TypeNamed nullability _ -> unNullability nullability
TypeList nullability _ -> unNullability nullability
isListType :: GType -> Bool
isListType = \case
TypeList _ _ -> True
TypeNamed _ _ -> False
isNotNull :: GType -> Bool
isNotNull = not . isNullable
-- * Type definition
type TypeDefinition :: Type -> Type -> Type
data TypeDefinition possibleTypes inputType
= TypeDefinitionScalar ScalarTypeDefinition
| TypeDefinitionObject (ObjectTypeDefinition inputType)
| TypeDefinitionInterface (InterfaceTypeDefinition possibleTypes inputType)
| TypeDefinitionUnion UnionTypeDefinition
| TypeDefinitionEnum EnumTypeDefinition
| TypeDefinitionInputObject (InputObjectTypeDefinition inputType)
deriving stock (Eq, Generic, Lift, Ord, Show, Functor)
deriving anyclass (Hashable, NFData)
instance Bifunctor TypeDefinition where
bimap f g definition = case definition of
TypeDefinitionScalar d -> TypeDefinitionScalar d
TypeDefinitionObject d -> TypeDefinitionObject $ fmap g d
TypeDefinitionInterface d -> TypeDefinitionInterface $ bimap f g d
TypeDefinitionUnion d -> TypeDefinitionUnion d
TypeDefinitionEnum d -> TypeDefinitionEnum d
TypeDefinitionInputObject d -> TypeDefinitionInputObject $ fmap g d
type Description :: Type
newtype Description = Description {unDescription :: Text}
deriving stock (Eq, Lift, Ord, Show)
deriving newtype (Hashable, IsString, Monoid, NFData, Semigroup, J.FromJSON, J.ToJSON)
type ObjectTypeDefinition :: Type -> Type
data ObjectTypeDefinition inputType = ObjectTypeDefinition
{ _otdDescription :: Maybe Description,
_otdName :: Name,
_otdImplementsInterfaces :: [Name],
_otdDirectives :: [Directive Void],
_otdFieldsDefinition :: [FieldDefinition inputType]
}
deriving stock (Eq, Generic, Lift, Ord, Show, Functor)
deriving anyclass (Hashable, NFData)
type FieldDefinition :: Type -> Type
data FieldDefinition inputType = FieldDefinition
{ _fldDescription :: Maybe Description,
_fldName :: Name,
_fldArgumentsDefinition :: ArgumentsDefinition inputType,
_fldType :: GType,
_fldDirectives :: [Directive Void]
}
deriving stock (Eq, Generic, Lift, Ord, Show, Functor)
deriving anyclass (Hashable, NFData)
type ArgumentsDefinition :: Type -> Type
type ArgumentsDefinition inputType = [inputType]
type InputValueDefinition :: Type
data InputValueDefinition = InputValueDefinition
{ _ivdDescription :: Maybe Description,
_ivdName :: Name,
_ivdType :: GType,
_ivdDefaultValue :: Maybe (Value Void),
_ivdDirectives :: [Directive Void]
}
deriving stock (Eq, Generic, Lift, Ord, Show)
deriving anyclass (Hashable, NFData)
type InterfaceTypeDefinition :: Type -> Type -> Type
data InterfaceTypeDefinition possibleTypes inputType = InterfaceTypeDefinition
{ _itdDescription :: Maybe Description,
_itdName :: Name,
_itdDirectives :: [Directive Void],
_itdFieldsDefinition :: [FieldDefinition inputType],
_itdPossibleTypes :: possibleTypes
}
deriving stock (Eq, Generic, Lift, Ord, Show, Functor)
deriving anyclass (Hashable, NFData)
instance Bifunctor InterfaceTypeDefinition where
bimap f g InterfaceTypeDefinition {..} =
InterfaceTypeDefinition
{ _itdFieldsDefinition = map (fmap g) _itdFieldsDefinition,
_itdPossibleTypes = f _itdPossibleTypes,
..
}
type UnionTypeDefinition :: Type
data UnionTypeDefinition = UnionTypeDefinition
{ _utdDescription :: Maybe Description,
_utdName :: Name,
_utdDirectives :: [Directive Void],
_utdMemberTypes :: [Name]
}
deriving stock (Eq, Generic, Lift, Ord, Show)
deriving anyclass (Hashable, NFData)
type ScalarTypeDefinition :: Type
data ScalarTypeDefinition = ScalarTypeDefinition
{ _stdDescription :: Maybe Description,
_stdName :: Name,
_stdDirectives :: [Directive Void]
}
deriving stock (Eq, Generic, Lift, Ord, Show)
deriving anyclass (Hashable, NFData)
type EnumTypeDefinition :: Type
data EnumTypeDefinition = EnumTypeDefinition
{ _etdDescription :: Maybe Description,
_etdName :: Name,
_etdDirectives :: [Directive Void],
_etdValueDefinitions :: [EnumValueDefinition]
}
deriving stock (Eq, Generic, Lift, Ord, Show)
deriving anyclass (Hashable, NFData)
type EnumValueDefinition :: Type
data EnumValueDefinition = EnumValueDefinition
{ _evdDescription :: Maybe Description,
_evdName :: EnumValue,
_evdDirectives :: [Directive Void]
}
deriving stock (Eq, Generic, Lift, Ord, Show)
deriving anyclass (Hashable, NFData)
type EnumValue :: Type
newtype EnumValue = EnumValue {unEnumValue :: Name}
deriving stock (Eq, Lift, Ord, Show)
deriving newtype (Hashable, NFData, J.ToJSON, J.FromJSON)
type InputObjectTypeDefinition :: Type -> Type
data InputObjectTypeDefinition inputType = InputObjectTypeDefinition
{ _iotdDescription :: Maybe Description,
_iotdName :: Name,
_iotdDirectives :: [Directive Void],
_iotdValueDefinitions :: [inputType]
}
deriving stock (Eq, Generic, Lift, Ord, Show, Functor)
deriving anyclass (Hashable, NFData)
type DirectiveDefinition :: Type -> Type
data DirectiveDefinition inputType = DirectiveDefinition
{ _ddDescription :: Maybe Description,
_ddName :: Name,
_ddArguments :: ArgumentsDefinition inputType,
_ddLocations :: [DirectiveLocation]
}
deriving stock (Eq, Generic, Lift, Ord, Show, Functor)
deriving anyclass (Hashable, NFData)
type DirectiveLocation :: Type
data DirectiveLocation
= DLExecutable ExecutableDirectiveLocation
| DLTypeSystem TypeSystemDirectiveLocation
deriving stock (Eq, Generic, Lift, Ord, Show)
deriving anyclass (Hashable, NFData)
type ExecutableDirectiveLocation :: Type
data ExecutableDirectiveLocation
= EDLQUERY
| EDLMUTATION
| EDLSUBSCRIPTION
| EDLFIELD
| EDLFRAGMENT_DEFINITION
| EDLFRAGMENT_SPREAD
| EDLINLINE_FRAGMENT
deriving stock (Eq, Generic, Lift, Ord, Show)
deriving anyclass (Hashable, NFData)
type TypeSystemDirectiveLocation :: Type
data TypeSystemDirectiveLocation
= TSDLSCHEMA
| TSDLSCALAR
| TSDLOBJECT
| TSDLFIELD_DEFINITION
| TSDLARGUMENT_DEFINITION
| TSDLINTERFACE
| TSDLUNION
| TSDLENUM
| TSDLENUM_VALUE
| TSDLINPUT_OBJECT
| TSDLINPUT_FIELD_DEFINITION
deriving stock (Eq, Generic, Lift, Ord, Show)
deriving anyclass (Hashable, NFData)
inline :: NoFragments var -> FragmentSpread var
inline x = case x of {}
fmapFieldFragment :: (frag var -> frag' var) -> Field frag var -> Field frag' var
fmapFieldFragment f field =
field {_fSelectionSet = fmapSelectionSetFragment f (_fSelectionSet field)}
fmapSelectionSetFragment :: (frag var -> frag' var) -> SelectionSet frag var -> SelectionSet frag' var
fmapSelectionSetFragment f = fmap (fmapSelectionFragment f)
fmapSelectionFragment :: (frag var -> frag' var) -> Selection frag var -> Selection frag' var
fmapSelectionFragment f (SelectionField field) = SelectionField $ fmapFieldFragment f field
fmapSelectionFragment f (SelectionFragmentSpread frag) = SelectionFragmentSpread $ f frag
fmapSelectionFragment f (SelectionInlineFragment inlineFrag) =
SelectionInlineFragment $ fmapInlineFragment f inlineFrag
fmapInlineFragment :: (frag var -> frag' var) -> InlineFragment frag var -> InlineFragment frag' var
fmapInlineFragment f inlineFragment =
inlineFragment {_ifSelectionSet = fmapSelectionSetFragment f (_ifSelectionSet inlineFragment)}

17
server/lib/graphql-parser-hs/src/Language/GraphQL/Draft/Syntax.hs-boot Normal file
View File

@ -0,0 +1,17 @@
module Language.GraphQL.Draft.Syntax
( ExecutableDocument,
SchemaDocument,
)
where
import Data.Kind (Type)
-------------------------------------------------------------------------------
type role ExecutableDocument nominal
type ExecutableDocument :: Type -> Type
data ExecutableDocument var
type SchemaDocument :: Type
data SchemaDocument

48
server/lib/graphql-parser-hs/src/Language/GraphQL/Draft/Syntax/Internal.hs Normal file
View File

@ -0,0 +1,48 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
-- | Internal GraphQL AST functionality.
--
-- This module is primarily necessary due to an incorrect
-- @-Wredundant-constraints@ warning emitted by GHC when compiling
-- 'liftTypedHashMap'.
module Language.GraphQL.Draft.Syntax.Internal
( liftTypedHashMap,
)
where
-------------------------------------------------------------------------------
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.Hashable (Hashable)
import Language.Haskell.TH.Syntax (Lift, liftTyped)
import Language.Haskell.TH.Syntax qualified as TH
import Prelude
-------------------------------------------------------------------------------
-- | Lift a 'HashMap' into a Template Haskell splice via list conversion.
#if MIN_VERSION_template_haskell(2,17,0)
liftTypedHashMap ::
( Eq k,
Hashable k,
Lift k,
Lift v,
TH.Quote m
) =>
HashMap k v ->
TH.Code m (HashMap k v)
#else
liftTypedHashMap ::
( Eq k,
Hashable k,
Lift k,
Lift v
) =>
HashMap k v ->
TH.Q (TH.TExp (HashMap k v))
#endif
liftTypedHashMap hm =
[||HashMap.fromList $$(liftTyped $ HashMap.toList hm)||]

134
server/lib/graphql-parser-hs/src/Language/GraphQL/Draft/Syntax/Name.hs Normal file
View File

@ -0,0 +1,134 @@
{-# HLINT ignore "Use onNothing" #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
-- | Internal functionality for Name values.
--
-- This module is necessary to avoid exposing `unName` and friends to the outside world.
module Language.GraphQL.Draft.Syntax.Name
( Name (..),
NameSuffix (..),
mkName,
unsafeMkName,
parseName,
mkNameSuffix,
parseSuffix,
isValidName,
addSuffixes,
convertNameToSuffix,
litName,
litSuffix,
litGQLIdentifier,
)
where
-------------------------------------------------------------------------------
import Control.DeepSeq (NFData)
import Data.Aeson qualified as J
import Data.Char qualified as C
import Data.Coerce (coerce)
import Data.Hashable (Hashable)
import Data.Kind (Type)
import Data.Text (Text)
import Data.Text qualified as T
import Instances.TH.Lift ()
import Language.Haskell.TH.Syntax (Lift)
import Language.Haskell.TH.Syntax.Compat (SpliceQ, examineSplice, liftSplice)
import Prettyprinter (Pretty (..))
import Prelude
-------------------------------------------------------------------------------
-- Defined here and re-exported in the public module to avoid exporting `unName`.`
type Name :: Type
newtype Name = Name {unName :: Text}
deriving stock (Eq, Lift, Ord, Show)
deriving newtype (Semigroup, Hashable, NFData, Pretty, J.ToJSONKey, J.ToJSON)
-- | @NameSuffix@ is essentially a GQL identifier that can be used as Suffix
-- It is slightely different from @Name@ as it relaxes the criteria that a
-- @Name@ cannot start with a digit.
type NameSuffix :: Type
newtype NameSuffix = Suffix {unNameSuffix :: Text}
deriving stock (Eq, Lift, Ord, Show)
deriving newtype (Semigroup, Hashable, NFData, Pretty, J.ToJSONKey, J.ToJSON)
parseName :: MonadFail m => Text -> m Name
parseName text = maybe (fail errorMessage) pure $ mkName text
where
errorMessage = T.unpack text <> " is not valid GraphQL name"
-- | @matchFirst@ verifies if the starting character is according to the
-- graphql spec (refer https://spec.graphql.org/October2021/#NameStart).
matchFirst :: Char -> Bool
matchFirst c = c == '_' || C.isAsciiUpper c || C.isAsciiLower c
-- | @matchBody@ verifies if the continuing character is according to the
-- graphql spec (refer https://spec.graphql.org/October2021/#NameContinue).
matchBody :: Char -> Bool
matchBody c = c == '_' || C.isAsciiUpper c || C.isAsciiLower c || C.isDigit c
-- | @isValidName@ verifies if a text is a valid @Name@ as per the graphql
-- spec (refer https://spec.graphql.org/October2021/#Name)
isValidName :: Text -> Bool
isValidName text =
case T.uncons text of
Nothing -> False
Just (first, body) ->
matchFirst first && T.all matchBody body
mkName :: Text -> Maybe Name
mkName text =
if isValidName text
then Just (Name text)
else Nothing
mkNameSuffix :: Text -> Maybe NameSuffix
mkNameSuffix text =
if T.all matchBody text
then Just (Suffix text)
else Nothing
addSuffixes :: Name -> [NameSuffix] -> Name
addSuffixes prefix [] = prefix
addSuffixes (Name prefix) suffs = Name $ T.concat (prefix : suffsT)
where
suffsT = map unNameSuffix suffs
-- | All @Name@s are @Suffix@, so this function won't fail
convertNameToSuffix :: Name -> NameSuffix
convertNameToSuffix = coerce
unsafeMkName :: Text -> Name
unsafeMkName = Name
parseSuffix :: MonadFail m => Text -> m NameSuffix
parseSuffix text = maybe (fail errorMessage) pure $ mkNameSuffix text
where
errorMessage = T.unpack text <> " is not valid GraphQL suffix"
-- | Construct a 'Name' value at compile-time.
litName :: Text -> SpliceQ Name
litName txt = liftSplice do
name <- parseName txt
examineSplice [||name||]
-- | Construct a 'NameSuffix' value at compile-time.
litSuffix :: Text -> SpliceQ NameSuffix
litSuffix txt = liftSplice do
name <- parseSuffix txt
examineSplice [||name||]
-- | Construct prefix-suffix tuple at compile-time from a list.
litGQLIdentifier :: [Text] -> SpliceQ (Name, [NameSuffix])
litGQLIdentifier [] = liftSplice $ fail "GQL identifier cannot be empty"
litGQLIdentifier (x : xs) = liftSplice do
pref <- parseName x
suffs <- traverse parseSuffix xs
examineSplice [||(pref, suffs)||]
instance J.FromJSON Name where
parseJSON = J.withText "Name" parseName
instance J.FromJSONKey Name where
fromJSONKey = J.FromJSONKeyTextParser parseName

8
server/lib/graphql-parser-hs/src/Language/GraphQL/Draft/Syntax/Name.hs-boot Normal file
View File

@ -0,0 +1,8 @@
module Language.GraphQL.Draft.Syntax.Name (Name) where
import Data.Kind (Type)
-------------------------------------------------------------------------------
type Name :: Type
data Name

70
server/lib/graphql-parser-hs/src/Language/GraphQL/Draft/Syntax/QQ.hs Normal file
View File

@ -0,0 +1,70 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TypeApplications #-}
-- | Quasiquotation for 'Language.GraphQL.Draft.Syntax' types.
--
-- These quasiquoters can be used to construct GraphQL literal values at
-- compile-time.
module Language.GraphQL.Draft.Syntax.QQ
( name,
executableDoc,
)
where
-------------------------------------------------------------------------------
import Data.Text qualified as Text
import Language.GraphQL.Draft.Parser (parseExecutableDoc)
import Language.GraphQL.Draft.Syntax qualified as Syntax
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Prelude
-------------------------------------------------------------------------------
-- | Construct 'Syntax.Name' literals at compile-time via quasiquotation.
--
-- For example:
--
-- @
-- [name|foo_bar|]
-- @
--
-- ... would produce a 'Syntax.Name' value with the value @foo_bar@.
name :: QuasiQuoter
name =
QuasiQuoter {quoteExp, quotePat, quoteType, quoteDec}
where
quotePat _ = error "'name' does not support quoting patterns"
quoteType _ = error "'name' does not support quoting types"
quoteDec _ = error "'name' does not support quoting declarations"
quoteExp str = case Syntax.mkName (Text.pack str) of
Nothing -> error $ str <> " is not a valid GraphQL Name"
Just result -> [|result|]
-- | Construct @'Syntax.ExecutableDocument' 'Syntax.Name'@ literals at compile
-- time via quasiquotation.
--
-- For example:
--
-- @
-- [executableDoc|
-- {
-- hero {
-- name
-- age
-- }
-- }
-- |]
-- @
executableDoc :: QuasiQuoter
executableDoc =
QuasiQuoter {quoteExp, quotePat, quoteType, quoteDec}
where
quotePat _ = error "'executableDoc' does not support quoting patterns"
quoteType _ = error "'executableDoc' does not support quoting types"
quoteDec _ = error "'executableDoc' does not support quoting declarations"
quoteExp str = case parseExecutableDoc (Text.pack str) of
Left err -> fail . show $ err
Right doc -> [|doc|]

78
server/lib/graphql-parser-hs/test/BlockStrings.hs Normal file
View File

@ -0,0 +1,78 @@
-- | Regression tests for issue #20 https://github.com/hasura/graphql-parser-hs/issues/20
module BlockStrings
( blockTest,
)
where
-------------------------------------------------------------------------------
import Data.Text (Text)
import Data.Text qualified as T
import Hedgehog
( Group (..),
Property,
checkParallel,
failure,
footnote,
property,
success,
withTests,
(===),
)
import Language.GraphQL.Draft.Parser (blockString, runParser)
import Prelude
-------------------------------------------------------------------------------
blockTest :: IO Bool
blockTest = do
checkParallel $
Group
"Test.parser.block-string.unit"
[ ("parses the specExample", "\n Hello,\n World!\n\n Yours,\n GraphQL.\n " `shouldParseTo` "Hello,\n World!\n\nYours,\n GraphQL."),
("do not remove WS from the end of lines", "\nFoo \nbar " `shouldParseTo` "Foo \nbar "),
("tabs are WS as well", "\n\t\tFoo\n\t\tbar\n\t\t\tqux" `shouldParseTo` "Foo\nbar\n\tqux"),
("tabs work with spaces", "\n\t Foo\n \tbar\n\t\t qux" `shouldParseTo` "Foo\nbar\n qux"),
("parses newline", "\n" `shouldParseTo` ""),
("parses very simples not-empty block", "x" `shouldParseTo` "x"),
("common indentation is removed", "\n a \n b \n c " `shouldParseTo` "a \n b \nc "),
("zero common indentation is possible", "\na \n b \nc " `shouldParseTo` "a \n b \nc "),
("no whitespace is removed from the first line", " abc " `shouldParseTo` " abc "),
("ignores escaping", " \\ " `shouldParseTo` " \\ "), -- this is a single \
("\n in first characters is parsed", "\n hey " `shouldParseTo` "hey "),
("simple case", "\nx\n" `shouldParseTo` "x"),
("empty single line", "" `shouldParseTo` ""),
("empty two lines", "\n" `shouldParseTo` ""),
("empty three lines", "\n\n" `shouldParseTo` ""),
("empty X lines", "\n\n\n\n\n\n" `shouldParseTo` ""),
("preserves escaped newlines", "\nhello\\nworld\n" `shouldParseTo` "hello\\nworld"),
("double-quotes are parsed normally", "\n\"\n" `shouldParseTo` "\""),
("escaped triple-quotes are ignored as block terminator", "\n \\\"\"\"hey\n friends\n" `shouldParseTo` "\"\"\"hey\nfriends"),
("fails for normal string", blockParseFail "\"hey\""),
("fails for block string that is not closed", blockParseFail "\"\"\" hey"),
("fails for block string that is not closed when there are escaped triple-quotes", blockParseFail "\"\"\" hey\\\"\"\"hey"),
("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
]
-- | We use this function to tests cases that we know should
-- fail, when we pass a function to construct wrapped the
-- body in a delimiter, where we will probably be testing
-- for errors using it.
blockParseFail :: Text -> Property
blockParseFail unparsed = withTests 1 $
property $ do
case runParser blockString ("\"\"\"" <> unparsed <> "\"\"\"") of
Left _ -> success
Right _ -> do
footnote ("Should have failed for: " <> T.unpack ("\"\"\"" <> unparsed <> "\"\"\""))
failure
-- | Test whether certain block string content parses to the expected value.
shouldParseTo :: Text -> Text -> Property
shouldParseTo unparsed expected = withTests 1 $
property $ do
case runParser blockString ("\"\"\"" <> unparsed <> "\"\"\"") of
Right r -> expected === r
Left l -> do
footnote $ T.unpack $ "Block parser failed: " <> l
failure

111
server/lib/graphql-parser-hs/test/Keywords.hs Normal file
View File

@ -0,0 +1,111 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
-------------------------------------------------------------------------------
-- | Regression tests for issue #20 https://github.com/hasura/graphql-parser-hs/issues/20
module Keywords
( primitiveTests,
)
where
-------------------------------------------------------------------------------
import Data.Foldable (for_)
import Data.Text (Text, singleton)
import Data.Void (Void)
import Hedgehog
( MonadTest,
Property,
PropertyName,
liftTest,
property,
tripping,
withTests,
)
import Language.GraphQL.Draft.Parser (Parser, nameParser, runParser, value)
import Language.GraphQL.Draft.Printer qualified as Printer
import Language.GraphQL.Draft.Syntax (EnumValue (..), Value (..), addSuffixes, litName, litSuffix)
import Text.Builder (Builder, run)
import Prelude
-------------------------------------------------------------------------------
primitiveTests :: [(PropertyName, Property)]
primitiveTests =
[ ("a \"null\" prefix doesn't prevent parsing a name", withTests 1 propNullNameName),
("a \"null\" prefix doesn't prevent parsing an enum name", withTests 1 propNullNameValue),
("a \"true\" prefix doesn't prevent parsing an enum name", withTests 1 propBoolNameValue),
("a string containing \\NUL is handled correctly", withTests 1 propHandleNulString),
("a string containing \\n is handled correctly", withTests 1 propHandleNewlineString),
("a string containing \\x0011 is handled correctly", withTests 1 propHandleControlString),
("all unicode characters are supported", withTests 1 propHandleUnicodeCharacters),
("triple quotes is a valid string", withTests 1 propHandleTripleQuote),
("name with a suffix should be a valid name", withTests 1 propNameWithSuffix)
]
propNullNameValue :: Property
propNullNameValue =
property . roundtripValue $
VList [VEnum $ EnumValue $$(litName "nullColumn")]
propBoolNameValue :: Property
propBoolNameValue =
property . roundtripValue $
VList [VEnum $ EnumValue $$(litName "trueColumn")]
propNullNameName :: Property
propNullNameName =
property $
roundtripParser nameParser Printer.nameP $$(litName "nullColumntwo")
propHandleNulString :: Property
propHandleNulString = property . roundtripValue $ VString "\NUL"
propHandleNewlineString :: Property
propHandleNewlineString = property . roundtripValue $ VString "\n"
propHandleControlString :: Property
propHandleControlString = property . roundtripValue $ VString "\x0011"
-- NB: 'liftTest' is explicitly used to restrict the 'for_' block to operate in
-- the 'Test' type (i.e. 'type Test = TestT Identity'), as opposed to 'PropertyT
-- IO'. The 'Test' monad is a thinner monad stack & therefore doesn't suffer
-- from memory leakage caused by, among others, Hedgehog's 'TreeT', which is
-- used for automatic shrinking (which we don't need in this test).
propHandleUnicodeCharacters :: Property
propHandleUnicodeCharacters = property . liftTest $
for_ [minBound .. maxBound] $ \char ->
roundtripValue . VString $ singleton char
propHandleTripleQuote :: Property
propHandleTripleQuote = property . roundtripValue $ VString "\"\"\""
propNameWithSuffix :: Property
propNameWithSuffix =
property . roundtripValue $
VList [VEnum $ EnumValue (addSuffixes $$(litName "prefix") [$$(litSuffix "1suffix"), $$(litSuffix "2suffix")])]
-- | Test that a given 'Value'@ @'Void' passes round-trip tests as expected.
roundtripValue :: (MonadTest m) => Value Void -> m ()
roundtripValue = roundtripParser value Printer.value
-- | Test that a pair of parsing/printing functions are compatible with one
-- another.
--
-- That is: given a 'Parser'@ a@ and some @a -> @'Builder', ensure that any
-- valid @a@ round-trips through the printer and parser to yield the same @a@.
roundtripParser ::
forall a m.
(MonadTest m, Eq a, Show a) =>
Parser a ->
(a -> Builder) ->
a ->
m ()
roundtripParser parser printer ast = tripping ast printAST parseAST
where
parseAST :: Text -> Either Text a
parseAST = runParser parser
printAST :: a -> Text
printAST = run . printer

118
server/lib/graphql-parser-hs/test/Spec.hs Normal file
View File

@ -0,0 +1,118 @@
{-# LANGUAGE ViewPatterns #-}
module Main
( main,
)
where
-------------------------------------------------------------------------------
import BlockStrings (blockTest)
import Control.Monad (unless)
import Data.ByteString.Builder qualified as BSB
import Data.ByteString.Lazy qualified as LBS
import Data.Kind (Type)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding.Error qualified as TEE
import Data.Text.Lazy qualified as LT
import Data.Text.Lazy.Builder qualified as LTB
import Data.Text.Lazy.Encoding qualified as LTE
import Hedgehog
( Group (..),
Property,
TestLimit,
checkParallel,
failure,
footnote,
forAll,
property,
withTests,
(===),
)
import Keywords qualified
import Language.GraphQL.Draft.Generator
import Language.GraphQL.Draft.Parser qualified as Input
import Language.GraphQL.Draft.Printer qualified as Output
import Language.GraphQL.Draft.Syntax
import Prettyprinter qualified as PP
import Prettyprinter.Render.Text qualified as PP
import System.Environment (getArgs)
import System.Exit (exitFailure)
import Text.Builder qualified as TB
import Prelude
-------------------------------------------------------------------------------
type TestMode :: Type
data TestMode = TMDev | TMQuick | TMRelease
deriving stock (Show)
main :: IO ()
main = do
args <- getArgs
case parseArgs args of
TMQuick -> runTest 100
TMDev -> runTest 500
TMRelease -> runTest 1000
where
parseArgs = foldr parseArg TMDev
parseArg str _ = case str of
"quick" -> TMQuick
"release" -> TMRelease
_ -> TMDev
runTest :: TestLimit -> IO ()
runTest limit = do
allGood1 <- tests limit
allGood2 <- blockTest
unless (allGood1 && allGood2) exitFailure
tests :: TestLimit -> IO Bool
tests nTests =
checkParallel $
Group "Test.printer.parser" $
[ ("property [ parse (prettyPrint ast) == ast ]", propParserPrettyPrinter nTests),
("property [ parse (textBuilderPrint ast) == ast ]", propParserTextPrinter nTests),
("property [ parse (lazyTextBuilderPrint ast) == ast ]", propParserLazyTextPrinter nTests),
("property [ parse (bytestringBuilderPrint ast) == ast ]", propParserBSPrinter nTests)
]
++ Keywords.primitiveTests
propParserPrettyPrinter :: TestLimit -> Property
propParserPrettyPrinter = mkPropParserPrinter $ prettyPrinter . Output.executableDocument
where
prettyPrinter :: PP.Doc Text -> Text
prettyPrinter = PP.renderStrict . PP.layoutPretty PP.defaultLayoutOptions
propParserTextPrinter :: TestLimit -> Property
propParserTextPrinter = mkPropParserPrinter $ TB.run . Output.executableDocument
propParserLazyTextPrinter :: TestLimit -> Property
propParserLazyTextPrinter =
mkPropParserPrinter $
LT.toStrict
. LTB.toLazyText
. Output.executableDocument
propParserBSPrinter :: TestLimit -> Property
propParserBSPrinter =
mkPropParserPrinter $
bsToTxt
. BSB.toLazyByteString
. Output.executableDocument
mkPropParserPrinter :: (ExecutableDocument Name -> Text) -> (TestLimit -> Property)
mkPropParserPrinter printer = \space ->
withTests space $
property $ do
xs <- forAll genExecutableDocument
let rendered = printer xs
either onError (xs ===) $ Input.parseExecutableDoc rendered
where
onError (T.unpack -> errorMsg) = do
footnote errorMsg
failure
bsToTxt :: LBS.ByteString -> Text
bsToTxt = LT.toStrict . LTE.decodeUtf8With TEE.lenientDecode

8
server/lib/graphql-parser-hs/weeder.dhall Normal file
View File

@ -0,0 +1,8 @@
{ roots =
[ "Language.GraphQL.Draft.Generator"
, "Language.GraphQL.Draft.Parser"
, "Language.GraphQL.Draft.Printer"
, "Language.GraphQL.Draft.Syntax"
]
, type-class-roots = False
}