aboutsummaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/Language/GraphQL/AST/EncoderSpec.hs107
-rw-r--r--tests/Language/GraphQL/AST/LexerSpec.hs11
-rw-r--r--tests/Language/GraphQL/AST/ParserSpec.hs108
-rw-r--r--tests/Test/DirectiveSpec.hs18
-rw-r--r--tests/Test/FragmentSpec.hs16
-rw-r--r--tests/Test/StarWars/Data.hs13
-rw-r--r--tests/Test/StarWars/QuerySpec.hs182
-rw-r--r--tests/Test/StarWars/Schema.hs55
8 files changed, 361 insertions, 149 deletions
diff --git a/tests/Language/GraphQL/AST/EncoderSpec.hs b/tests/Language/GraphQL/AST/EncoderSpec.hs
index 0067c83..71ee948 100644
--- a/tests/Language/GraphQL/AST/EncoderSpec.hs
+++ b/tests/Language/GraphQL/AST/EncoderSpec.hs
@@ -6,37 +6,124 @@ module Language.GraphQL.AST.EncoderSpec
import Language.GraphQL.AST
import Language.GraphQL.AST.Encoder
-import Test.Hspec (Spec, context, describe, it, shouldBe)
+import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain)
+import Test.QuickCheck (choose, oneof, forAll)
import Text.RawString.QQ (r)
+import Data.Text.Lazy (cons, toStrict, unpack)
spec :: Spec
spec = do
describe "value" $ do
+ context "null value" $ do
+ let testNull formatter = value formatter Null `shouldBe` "null"
+ it "minified" $ testNull minified
+ it "pretty" $ testNull pretty
+
context "minified" $ do
it "escapes \\" $
value minified (String "\\") `shouldBe` "\"\\\\\""
- it "escapes quotes" $
+ it "escapes double quotes" $
value minified (String "\"") `shouldBe` "\"\\\"\""
+ it "escapes \\f" $
+ value minified (String "\f") `shouldBe` "\"\\f\""
+ it "escapes \\n" $
+ value minified (String "\n") `shouldBe` "\"\\n\""
+ it "escapes \\r" $
+ value minified (String "\r") `shouldBe` "\"\\r\""
+ it "escapes \\t" $
+ value minified (String "\t") `shouldBe` "\"\\t\""
it "escapes backspace" $
value minified (String "a\bc") `shouldBe` "\"a\\bc\""
- it "escapes Unicode" $
- value minified (String "\0") `shouldBe` "\"\\u0000\""
+ context "escapes Unicode for chars less than 0010" $ do
+ it "Null" $ value minified (String "\x0000") `shouldBe` "\"\\u0000\""
+ it "bell" $ value minified (String "\x0007") `shouldBe` "\"\\u0007\""
+ context "escapes Unicode for char less than 0020" $ do
+ it "DLE" $ value minified (String "\x0010") `shouldBe` "\"\\u0010\""
+ it "EM" $ value minified (String "\x0019") `shouldBe` "\"\\u0019\""
+ context "encodes without escape" $ do
+ it "space" $ value minified (String "\x0020") `shouldBe` "\" \""
+ it "~" $ value minified (String "\x007E") `shouldBe` "\"~\""
context "pretty" $ do
it "uses strings for short string values" $
value pretty (String "Short text") `shouldBe` "\"Short text\""
- it "uses block strings for text with new lines" $
+ it "uses block strings for text with new lines, with newline symbol" $
value pretty (String "Line 1\nLine 2")
- `shouldBe` "\"\"\"\n Line 1\n Line 2\n\"\"\""
- it "escapes \\ in short strings" $
- value pretty (String "\\") `shouldBe` "\"\\\\\""
+ `shouldBe` [r|"""
+ Line 1
+ Line 2
+"""|]
+ it "uses block strings for text with new lines, with CR symbol" $
+ value pretty (String "Line 1\rLine 2")
+ `shouldBe` [r|"""
+ Line 1
+ Line 2
+"""|]
+ it "uses block strings for text with new lines, with CR symbol followed by newline" $
+ value pretty (String "Line 1\r\nLine 2")
+ `shouldBe` [r|"""
+ Line 1
+ Line 2
+"""|]
+ it "encodes as one line string if has escaped symbols" $ do
+ let
+ genNotAllowedSymbol = oneof
+ [ choose ('\x0000', '\x0008')
+ , choose ('\x000B', '\x000C')
+ , choose ('\x000E', '\x001F')
+ , pure '\x007F'
+ ]
+
+ forAll genNotAllowedSymbol $ \x -> do
+ let
+ rawValue = "Short \n" <> cons x "text"
+ encoded = value pretty (String $ toStrict rawValue)
+ shouldStartWith (unpack encoded) "\""
+ shouldEndWith (unpack encoded) "\""
+ shouldNotContain (unpack encoded) "\"\"\""
+
+ it "Hello world" $ value pretty (String "Hello,\n World!\n\nYours,\n GraphQL.")
+ `shouldBe` [r|"""
+ Hello,
+ World!
+
+ Yours,
+ GraphQL.
+"""|]
+
+ it "has only newlines" $ value pretty (String "\n") `shouldBe` [r|"""
+
+
+"""|]
+ it "has newlines and one symbol at the begining" $
+ value pretty (String "a\n\n") `shouldBe` [r|"""
+ a
+
+
+"""|]
+ it "has newlines and one symbol at the end" $
+ value pretty (String "\n\na") `shouldBe` [r|"""
+
+
+ a
+"""|]
+ it "has newlines and one symbol in the middle" $
+ value pretty (String "\na\n") `shouldBe` [r|"""
+
+ a
+
+"""|]
+ it "skip trailing whitespaces" $ value pretty (String " Short\ntext ")
+ `shouldBe` [r|"""
+ Short
+ text
+"""|]
describe "definition" $
it "indents block strings in arguments" $
let arguments = [Argument "message" (String "line1\nline2")]
field = Field Nothing "field" arguments [] []
- set = OperationSelectionSet $ pure $ SelectionField field
- operation = DefinitionOperation set
+ operation = DefinitionOperation $ SelectionSet $ pure field
in definition pretty operation `shouldBe` [r|{
field(message: """
line1
diff --git a/tests/Language/GraphQL/AST/LexerSpec.hs b/tests/Language/GraphQL/AST/LexerSpec.hs
index a0acb9f..0b4cb31 100644
--- a/tests/Language/GraphQL/AST/LexerSpec.hs
+++ b/tests/Language/GraphQL/AST/LexerSpec.hs
@@ -8,7 +8,7 @@ import Data.Text (Text)
import Data.Void (Void)
import Language.GraphQL.AST.Lexer
import Test.Hspec (Spec, context, describe, it)
-import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn)
+import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn)
import Text.Megaparsec (ParseErrorBundle, parse)
import Text.RawString.QQ (r)
@@ -77,7 +77,7 @@ spec = describe "Lexer" $ do
parse spread "" "..." `shouldParse` "..."
parse colon "" ":" `shouldParse` ":"
parse equals "" "=" `shouldParse` "="
- parse at "" "@" `shouldParse` '@'
+ parse at "" "@" `shouldParse` "@"
runBetween brackets `shouldSucceedOn` "[]"
runBetween braces `shouldSucceedOn` "{}"
parse pipe "" "|" `shouldParse` "|"
@@ -87,6 +87,13 @@ spec = describe "Lexer" $ do
parse blockString "" [r|""""""|] `shouldParse` ""
it "lexes ampersand" $
parse amp "" "&" `shouldParse` "&"
+ it "lexes schema extensions" $
+ parseExtend "schema" `shouldSucceedOn` "extend schema"
+ it "fails if the given token doesn't match" $
+ parseExtend "schema" `shouldFailOn` "extend shema"
+
+parseExtend :: Text -> (Text -> Either (ParseErrorBundle Text Void) ())
+parseExtend extension = parse (extend extension "" $ pure $ pure ()) ""
runBetween :: (Parser () -> Parser ()) -> Text -> Either (ParseErrorBundle Text Void) ()
runBetween parser = parse (parser $ pure ()) ""
diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs
index 420d3cf..4fae5b1 100644
--- a/tests/Language/GraphQL/AST/ParserSpec.hs
+++ b/tests/Language/GraphQL/AST/ParserSpec.hs
@@ -4,9 +4,11 @@ module Language.GraphQL.AST.ParserSpec
( spec
) where
+import Data.List.NonEmpty (NonEmpty(..))
+import Language.GraphQL.AST.Document
import Language.GraphQL.AST.Parser
import Test.Hspec (Spec, describe, it)
-import Test.Hspec.Megaparsec (shouldSucceedOn)
+import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn)
import Text.Megaparsec (parse)
import Text.RawString.QQ (r)
@@ -28,17 +30,115 @@ spec = describe "Parser" $ do
it "accepts two required arguments" $
parse document "" `shouldSucceedOn` [r|
mutation auth($username: String!, $password: String!){
- test
+ test
}|]
it "accepts two string arguments" $
parse document "" `shouldSucceedOn` [r|
mutation auth{
- test(username: "username", password: "password")
+ test(username: "username", password: "password")
}|]
it "accepts two block string arguments" $
parse document "" `shouldSucceedOn` [r|
mutation auth{
- test(username: """username""", password: """password""")
+ test(username: """username""", password: """password""")
}|]
+
+ it "parses minimal schema definition" $
+ parse document "" `shouldSucceedOn` [r|schema { query: Query }|]
+
+ it "parses minimal scalar definition" $
+ parse document "" `shouldSucceedOn` [r|scalar Time|]
+
+ it "parses ImplementsInterfaces" $
+ parse document "" `shouldSucceedOn` [r|
+ type Person implements NamedEntity & ValuedEntity {
+ name: String
+ }
+ |]
+
+ it "parses a type without ImplementsInterfaces" $
+ parse document "" `shouldSucceedOn` [r|
+ type Person {
+ name: String
+ }
+ |]
+
+ it "parses ArgumentsDefinition in an ObjectDefinition" $
+ parse document "" `shouldSucceedOn` [r|
+ type Person {
+ name(first: String, last: String): String
+ }
+ |]
+
+ it "parses minimal union type definition" $
+ parse document "" `shouldSucceedOn` [r|
+ union SearchResult = Photo | Person
+ |]
+
+ it "parses minimal interface type definition" $
+ parse document "" `shouldSucceedOn` [r|
+ interface NamedEntity {
+ name: String
+ }
+ |]
+
+ it "parses minimal enum type definition" $
+ parse document "" `shouldSucceedOn` [r|
+ enum Direction {
+ NORTH
+ EAST
+ SOUTH
+ WEST
+ }
+ |]
+
+ it "parses minimal enum type definition" $
+ parse document "" `shouldSucceedOn` [r|
+ enum Direction {
+ NORTH
+ EAST
+ SOUTH
+ WEST
+ }
+ |]
+
+ it "parses minimal input object type definition" $
+ parse document "" `shouldSucceedOn` [r|
+ input Point2D {
+ x: Float
+ y: Float
+ }
+ |]
+
+ it "parses minimal input enum definition with an optional pipe" $
+ parse document "" `shouldSucceedOn` [r|
+ directive @example on
+ | FIELD
+ | FRAGMENT_SPREAD
+ |]
+
+ it "parses schema extension with a new directive" $
+ parse document "" `shouldSucceedOn`[r|
+ extend schema @newDirective
+ |]
+
+ it "parses schema extension with an operation type definition" $
+ parse document "" `shouldSucceedOn` [r|extend schema { query: Query }|]
+
+ it "parses schema extension with an operation type and directive" $
+ let newDirective = Directive "newDirective" []
+ testSchemaExtension = TypeSystemExtension
+ $ SchemaExtension
+ $ SchemaOperationExtension [newDirective]
+ $ OperationTypeDefinition Query "Query" :| []
+ query = [r|extend schema @newDirective { query: Query }|]
+ in parse document "" query `shouldParse` (testSchemaExtension :| [])
+
+ it "parses an object extension" $
+ parse document "" `shouldSucceedOn` [r|
+ extend type Story {
+ isHiddenLocally: Boolean
+ }
+ |] \ No newline at end of file
diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs
index 2224bc5..3b9da19 100644
--- a/tests/Test/DirectiveSpec.hs
+++ b/tests/Test/DirectiveSpec.hs
@@ -5,14 +5,18 @@ module Test.DirectiveSpec
) where
import Data.Aeson (Value, object, (.=))
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
import Data.List.NonEmpty (NonEmpty(..))
+import Data.Text (Text)
import Language.GraphQL
import qualified Language.GraphQL.Schema as Schema
import Test.Hspec (Spec, describe, it, shouldBe)
import Text.RawString.QQ (r)
-experimentalResolver :: Schema.Resolver IO
-experimentalResolver = Schema.scalar "experimentalField" $ pure (5 :: Int)
+experimentalResolver :: HashMap Text (NonEmpty (Schema.Resolver IO))
+experimentalResolver = HashMap.singleton "Query"
+ $ Schema.scalar "experimentalField" (pure (5 :: Int)) :| []
emptyObject :: Value
emptyObject = object
@@ -29,7 +33,7 @@ spec =
}
|]
- actual <- graphql (experimentalResolver :| []) query
+ actual <- graphql experimentalResolver query
actual `shouldBe` emptyObject
it "should not skip fields if @skip is false" $ do
@@ -44,7 +48,7 @@ spec =
]
]
- actual <- graphql (experimentalResolver :| []) query
+ actual <- graphql experimentalResolver query
actual `shouldBe` expected
it "should skip fields if @include is false" $ do
@@ -54,7 +58,7 @@ spec =
}
|]
- actual <- graphql (experimentalResolver :| []) query
+ actual <- graphql experimentalResolver query
actual `shouldBe` emptyObject
it "should be able to @skip a fragment spread" $ do
@@ -68,7 +72,7 @@ spec =
}
|]
- actual <- graphql (experimentalResolver :| []) query
+ actual <- graphql experimentalResolver query
actual `shouldBe` emptyObject
it "should be able to @skip an inline fragment" $ do
@@ -80,5 +84,5 @@ spec =
}
|]
- actual <- graphql (experimentalResolver :| []) query
+ actual <- graphql experimentalResolver query
actual `shouldBe` emptyObject
diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs
index de10d63..74293a9 100644
--- a/tests/Test/FragmentSpec.hs
+++ b/tests/Test/FragmentSpec.hs
@@ -51,7 +51,7 @@ spec :: Spec
spec = do
describe "Inline fragment executor" $ do
it "chooses the first selection if the type matches" $ do
- actual <- graphql (garment "Hat" :| []) inlineQuery
+ actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) inlineQuery
let expected = object
[ "data" .= object
[ "garment" .= object
@@ -62,7 +62,7 @@ spec = do
in actual `shouldBe` expected
it "chooses the last selection if the type matches" $ do
- actual <- graphql (garment "Shirt" :| []) inlineQuery
+ actual <- graphql (HashMap.singleton "Query" $ garment "Shirt" :| []) inlineQuery
let expected = object
[ "data" .= object
[ "garment" .= object
@@ -83,7 +83,7 @@ spec = do
}|]
resolvers = Schema.object "garment" $ return [circumference, size]
- actual <- graphql (resolvers :| []) query
+ actual <- graphql (HashMap.singleton "Query" $ resolvers :| []) query
let expected = object
[ "data" .= object
[ "garment" .= object
@@ -101,7 +101,7 @@ spec = do
}
}|]
- actual <- graphql (size :| []) query
+ actual <- graphql (HashMap.singleton "Query" $ size :| []) query
actual `shouldNotSatisfy` hasErrors
describe "Fragment spread executor" $ do
@@ -116,7 +116,7 @@ spec = do
}
|]
- actual <- graphql (circumference :| []) query
+ actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query
let expected = object
[ "data" .= object
[ "circumference" .= (60 :: Int)
@@ -141,7 +141,7 @@ spec = do
}
|]
- actual <- graphql (garment "Hat" :| []) query
+ actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query
let expected = object
[ "data" .= object
[ "garment" .= object
@@ -162,7 +162,7 @@ spec = do
}
|]
- actual <- graphql (circumference :| []) query
+ actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query
actual `shouldSatisfy` hasErrors
it "considers type condition" $ do
@@ -187,5 +187,5 @@ spec = do
]
]
]
- actual <- graphql (garment "Hat" :| []) query
+ actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query
actual `shouldBe` expected
diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs
index 4854f8f..9466991 100644
--- a/tests/Test/StarWars/Data.hs
+++ b/tests/Test/StarWars/Data.hs
@@ -8,7 +8,6 @@ module Test.StarWars.Data
, getEpisode
, getFriends
, getHero
- , getHeroIO
, getHuman
, id_
, homePlanet
@@ -17,11 +16,8 @@ module Test.StarWars.Data
, typeName
) where
-import Data.Monoid (mempty)
-import Control.Applicative ( Alternative(..)
- , liftA2
- )
-import Control.Monad.IO.Class (MonadIO(..))
+import Data.Functor.Identity (Identity)
+import Control.Applicative (Alternative(..), liftA2)
import Control.Monad.Trans.Except (throwE)
import Data.Maybe (catMaybes)
import Data.Text (Text)
@@ -71,7 +67,7 @@ appearsIn :: Character -> [Int]
appearsIn (Left x) = _appearsIn . _droidChar $ x
appearsIn (Right x) = _appearsIn . _humanChar $ x
-secretBackstory :: MonadIO m => Character -> ActionT m Text
+secretBackstory :: Character -> ActionT Identity Text
secretBackstory = const $ ActionT $ throwE "secretBackstory is secret."
typeName :: Character -> Text
@@ -166,9 +162,6 @@ getHero :: Int -> Character
getHero 5 = luke
getHero _ = artoo
-getHeroIO :: Int -> IO Character
-getHeroIO = pure . getHero
-
getHuman :: Alternative f => ID -> f Character
getHuman = fmap Right . getHuman'
diff --git a/tests/Test/StarWars/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs
index 0f6a2ef..45fcf42 100644
--- a/tests/Test/StarWars/QuerySpec.hs
+++ b/tests/Test/StarWars/QuerySpec.hs
@@ -5,20 +5,15 @@ module Test.StarWars.QuerySpec
) where
import qualified Data.Aeson as Aeson
-import Data.Aeson ( object
- , (.=)
- )
+import Data.Aeson ((.=))
+import Data.Functor.Identity (Identity(..))
+import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import Language.GraphQL
import Language.GraphQL.Schema (Subs)
import Text.RawString.QQ (r)
-import Test.Hspec.Expectations ( Expectation
- , shouldBe
- )
-import Test.Hspec ( Spec
- , describe
- , it
- )
+import Test.Hspec.Expectations (Expectation, shouldBe)
+import Test.Hspec (Spec, describe, it)
import Test.StarWars.Schema
-- * Test
@@ -34,7 +29,11 @@ spec = describe "Star Wars Query Tests" $ do
}
}
|]
- $ object [ "data" .= object ["hero" .= object ["id" .= ("2001" :: Text)]]]
+ $ Aeson.object
+ [ "data" .= Aeson.object
+ [ "hero" .= Aeson.object ["id" .= ("2001" :: Text)]
+ ]
+ ]
it "R2-D2 ID and friends" $ testQuery
[r| query HeroNameAndFriendsQuery {
hero {
@@ -46,14 +45,14 @@ spec = describe "Star Wars Query Tests" $ do
}
}
|]
- $ object [ "data" .= object [
- "hero" .= object
+ $ Aeson.object [ "data" .= Aeson.object [
+ "hero" .= Aeson.object
[ "id" .= ("2001" :: Text)
, r2d2Name
, "friends" .=
- [ object [lukeName]
- , object [hanName]
- , object [leiaName]
+ [ Aeson.object [lukeName]
+ , Aeson.object [hanName]
+ , Aeson.object [leiaName]
]
]
]]
@@ -73,37 +72,37 @@ spec = describe "Star Wars Query Tests" $ do
}
}
|]
- $ object [ "data" .= object [
- "hero" .= object [
+ $ Aeson.object [ "data" .= Aeson.object [
+ "hero" .= Aeson.object [
"name" .= ("R2-D2" :: Text)
, "friends" .= [
- object [
+ Aeson.object [
"name" .= ("Luke Skywalker" :: Text)
, "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text]
, "friends" .= [
- object [hanName]
- , object [leiaName]
- , object [c3poName]
- , object [r2d2Name]
+ Aeson.object [hanName]
+ , Aeson.object [leiaName]
+ , Aeson.object [c3poName]
+ , Aeson.object [r2d2Name]
]
]
- , object [
+ , Aeson.object [
hanName
, "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
- , "friends" .= [
- object [lukeName]
- , object [leiaName]
- , object [r2d2Name]
+ , "friends" .=
+ [ Aeson.object [lukeName]
+ , Aeson.object [leiaName]
+ , Aeson.object [r2d2Name]
]
]
- , object [
+ , Aeson.object [
leiaName
, "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
- , "friends" .= [
- object [lukeName]
- , object [hanName]
- , object [c3poName]
- , object [r2d2Name]
+ , "friends" .=
+ [ Aeson.object [lukeName]
+ , Aeson.object [hanName]
+ , Aeson.object [c3poName]
+ , Aeson.object [r2d2Name]
]
]
]
@@ -116,40 +115,40 @@ spec = describe "Star Wars Query Tests" $ do
}
}
|]
- $ object [ "data" .= object [
- "human" .= object [lukeName]
- ]]
+ $ Aeson.object [ "data" .= Aeson.object
+ [ "human" .= Aeson.object [lukeName]
+ ]]
it "Luke ID with variable" $ testQueryParams
- (\v -> if v == "someId" then Just "1000" else Nothing)
+ (HashMap.singleton "someId" "1000")
[r| query FetchSomeIDQuery($someId: String!) {
human(id: $someId) {
name
}
}
|]
- $ object [ "data" .= object [
- "human" .= object [lukeName]
+ $ Aeson.object [ "data" .= Aeson.object [
+ "human" .= Aeson.object [lukeName]
]]
it "Han ID with variable" $ testQueryParams
- (\v -> if v == "someId" then Just "1002" else Nothing)
+ (HashMap.singleton "someId" "1002")
[r| query FetchSomeIDQuery($someId: String!) {
human(id: $someId) {
name
}
}
|]
- $ object [ "data" .= object [
- "human" .= object [hanName]
+ $ Aeson.object [ "data" .= Aeson.object [
+ "human" .= Aeson.object [hanName]
]]
it "Invalid ID" $ testQueryParams
- (\v -> if v == "id" then Just "Not a valid ID" else Nothing)
+ (HashMap.singleton "id" "Not a valid ID")
[r| query humanQuery($id: String!) {
human(id: $id) {
name
}
}
- |] $ object ["data" .= object ["human" .= Aeson.Null]]
+ |] $ Aeson.object ["data" .= Aeson.object ["human" .= Aeson.Null]]
it "Luke aliased" $ testQuery
[r| query FetchLukeAliased {
luke: human(id: "1000") {
@@ -157,8 +156,8 @@ spec = describe "Star Wars Query Tests" $ do
}
}
|]
- $ object [ "data" .= object [
- "luke" .= object [lukeName]
+ $ Aeson.object [ "data" .= Aeson.object [
+ "luke" .= Aeson.object [lukeName]
]]
it "R2-D2 ID and friends aliased" $ testQuery
[r| query HeroNameAndFriendsQuery {
@@ -171,14 +170,14 @@ spec = describe "Star Wars Query Tests" $ do
}
}
|]
- $ object [ "data" .= object [
- "hero" .= object [
+ $ Aeson.object [ "data" .= Aeson.object [
+ "hero" .= Aeson.object [
"id" .= ("2001" :: Text)
, r2d2Name
- , "friends" .= [
- object ["friendName" .= ("Luke Skywalker" :: Text)]
- , object ["friendName" .= ("Han Solo" :: Text)]
- , object ["friendName" .= ("Leia Organa" :: Text)]
+ , "friends" .=
+ [ Aeson.object ["friendName" .= ("Luke Skywalker" :: Text)]
+ , Aeson.object ["friendName" .= ("Han Solo" :: Text)]
+ , Aeson.object ["friendName" .= ("Leia Organa" :: Text)]
]
]
]]
@@ -192,9 +191,9 @@ spec = describe "Star Wars Query Tests" $ do
}
}
|]
- $ object [ "data" .= object [
- "luke" .= object [lukeName]
- , "leia" .= object [leiaName]
+ $ Aeson.object [ "data" .= Aeson.object
+ [ "luke" .= Aeson.object [lukeName]
+ , "leia" .= Aeson.object [leiaName]
]]
describe "Fragments for complex queries" $ do
@@ -210,9 +209,9 @@ spec = describe "Star Wars Query Tests" $ do
}
}
|]
- $ object [ "data" .= object [
- "luke" .= object [lukeName, tatooine]
- , "leia" .= object [leiaName, alderaan]
+ $ Aeson.object [ "data" .= Aeson.object [
+ "luke" .= Aeson.object [lukeName, tatooine]
+ , "leia" .= Aeson.object [leiaName, alderaan]
]]
it "Fragment for duplicate content" $ testQuery
[r| query UseFragment {
@@ -228,9 +227,9 @@ spec = describe "Star Wars Query Tests" $ do
homePlanet
}
|]
- $ object [ "data" .= object [
- "luke" .= object [lukeName, tatooine]
- , "leia" .= object [leiaName, alderaan]
+ $ Aeson.object [ "data" .= Aeson.object [
+ "luke" .= Aeson.object [lukeName, tatooine]
+ , "leia" .= Aeson.object [leiaName, alderaan]
]]
describe "__typename" $ do
@@ -242,8 +241,11 @@ spec = describe "Star Wars Query Tests" $ do
}
}
|]
- $ object ["data" .= object [
- "hero" .= object ["__typename" .= ("Droid" :: Text), r2d2Name]
+ $ Aeson.object ["data" .= Aeson.object [
+ "hero" .= Aeson.object
+ [ "__typename" .= ("Droid" :: Text)
+ , r2d2Name
+ ]
]]
it "Luke is a human" $ testQuery
[r| query CheckTypeOfLuke {
@@ -253,8 +255,11 @@ spec = describe "Star Wars Query Tests" $ do
}
}
|]
- $ object ["data" .= object [
- "hero" .= object ["__typename" .= ("Human" :: Text), lukeName]
+ $ Aeson.object ["data" .= Aeson.object [
+ "hero" .= Aeson.object
+ [ "__typename" .= ("Human" :: Text)
+ , lukeName
+ ]
]]
describe "Errors in resolvers" $ do
@@ -267,15 +272,15 @@ spec = describe "Star Wars Query Tests" $ do
}
}
|]
- $ object
- [ "data" .= object
- [ "hero" .= object
+ $ Aeson.object
+ [ "data" .= Aeson.object
+ [ "hero" .= Aeson.object
[ "name" .= ("R2-D2" :: Text)
, "secretBackstory" .= Aeson.Null
]
]
, "errors" .=
- [ object
+ [ Aeson.object
["message" .= ("secretBackstory is secret." :: Text)]
]
]
@@ -290,19 +295,19 @@ spec = describe "Star Wars Query Tests" $ do
}
}
|]
- $ object ["data" .= object
- [ "hero" .= object
+ $ Aeson.object ["data" .= Aeson.object
+ [ "hero" .= Aeson.object
[ "name" .= ("R2-D2" :: Text)
, "friends" .=
- [ object
+ [ Aeson.object
[ "name" .= ("Luke Skywalker" :: Text)
, "secretBackstory" .= Aeson.Null
]
- , object
+ , Aeson.object
[ "name" .= ("Han Solo" :: Text)
, "secretBackstory" .= Aeson.Null
]
- , object
+ , Aeson.object
[ "name" .= ("Leia Organa" :: Text)
, "secretBackstory" .= Aeson.Null
]
@@ -310,9 +315,15 @@ spec = describe "Star Wars Query Tests" $ do
]
]
, "errors" .=
- [ object ["message" .= ("secretBackstory is secret." :: Text)]
- , object ["message" .= ("secretBackstory is secret." :: Text)]
- , object ["message" .= ("secretBackstory is secret." :: Text)]
+ [ Aeson.object
+ [ "message" .= ("secretBackstory is secret." :: Text)
+ ]
+ , Aeson.object
+ [ "message" .= ("secretBackstory is secret." :: Text)
+ ]
+ , Aeson.object
+ [ "message" .= ("secretBackstory is secret." :: Text)
+ ]
]
]
it "error on secretBackstory with alias" $ testQuery
@@ -323,15 +334,17 @@ spec = describe "Star Wars Query Tests" $ do
}
}
|]
- $ object
- [ "data" .= object
- [ "mainHero" .= object
+ $ Aeson.object
+ [ "data" .= Aeson.object
+ [ "mainHero" .= Aeson.object
[ "name" .= ("R2-D2" :: Text)
, "story" .= Aeson.Null
]
]
, "errors" .=
- [ object ["message" .= ("secretBackstory is secret." :: Text)]
+ [ Aeson.object
+ [ "message" .= ("secretBackstory is secret." :: Text)
+ ]
]
]
@@ -345,7 +358,8 @@ spec = describe "Star Wars Query Tests" $ do
alderaan = "homePlanet" .= ("Alderaan" :: Text)
testQuery :: Text -> Aeson.Value -> Expectation
-testQuery q expected = graphql schema q >>= flip shouldBe expected
+testQuery q expected = runIdentity (graphql schema q) `shouldBe` expected
testQueryParams :: Subs -> Text -> Aeson.Value -> Expectation
-testQueryParams f q expected = graphqlSubs schema f q >>= flip shouldBe expected
+testQueryParams f q expected =
+ runIdentity (graphqlSubs schema f q) `shouldBe` expected
diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs
index 7b98747..cd25599 100644
--- a/tests/Test/StarWars/Schema.hs
+++ b/tests/Test/StarWars/Schema.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Test.StarWars.Schema
( character
@@ -10,9 +9,12 @@ module Test.StarWars.Schema
import Control.Monad.Trans.Except (throwE)
import Control.Monad.Trans.Class (lift)
-import Control.Monad.IO.Class (MonadIO(..))
+import Data.Functor.Identity (Identity)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (catMaybes)
+import Data.Text (Text)
import qualified Language.GraphQL.Schema as Schema
import Language.GraphQL.Trans
import qualified Language.GraphQL.Type as Type
@@ -20,32 +22,37 @@ import Test.StarWars.Data
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
-schema :: MonadIO m => NonEmpty (Schema.Resolver m)
-schema = hero :| [human, droid]
+schema :: HashMap Text (NonEmpty (Schema.Resolver Identity))
+schema = HashMap.singleton "Query" $ hero :| [human, droid]
-hero :: MonadIO m => Schema.Resolver m
-hero = Schema.objectA "hero" $ \case
- [] -> character artoo
- [Schema.Argument "episode" (Schema.Enum "NEWHOPE")] -> character $ getHero 4
- [Schema.Argument "episode" (Schema.Enum "EMPIRE" )] -> character $ getHero 5
- [Schema.Argument "episode" (Schema.Enum "JEDI" )] -> character $ getHero 6
- _ -> ActionT $ throwE "Invalid arguments."
+hero :: Schema.Resolver Identity
+hero = Schema.object "hero" $ do
+ episode <- argument "episode"
+ character $ case episode of
+ Schema.Enum "NEWHOPE" -> getHero 4
+ Schema.Enum "EMPIRE" -> getHero 5
+ Schema.Enum "JEDI" -> getHero 6
+ _ -> artoo
-human :: MonadIO m => Schema.Resolver m
-human = Schema.wrappedObjectA "human" $ \case
- [Schema.Argument "id" (Schema.String i)] -> do
- humanCharacter <- lift $ return $ getHuman i >>= Just
- case humanCharacter of
- Nothing -> return Type.Null
- Just e -> Type.Named <$> character e
- _ -> ActionT $ throwE "Invalid arguments."
+human :: Schema.Resolver Identity
+human = Schema.wrappedObject "human" $ do
+ id' <- argument "id"
+ case id' of
+ Schema.String i -> do
+ humanCharacter <- lift $ return $ getHuman i >>= Just
+ case humanCharacter of
+ Nothing -> return Type.Null
+ Just e -> Type.Named <$> character e
+ _ -> ActionT $ throwE "Invalid arguments."
-droid :: MonadIO m => Schema.Resolver m
-droid = Schema.objectA "droid" $ \case
- [Schema.Argument "id" (Schema.String i)] -> character =<< liftIO (getDroid i)
- _ -> ActionT $ throwE "Invalid arguments."
+droid :: Schema.Resolver Identity
+droid = Schema.object "droid" $ do
+ id' <- argument "id"
+ case id' of
+ Schema.String i -> character =<< getDroid i
+ _ -> ActionT $ throwE "Invalid arguments."
-character :: MonadIO m => Character -> ActionT m [Schema.Resolver m]
+character :: Character -> ActionT Identity [Schema.Resolver Identity]
character char = return
[ Schema.scalar "id" $ return $ id_ char
, Schema.scalar "name" $ return $ name char
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 08:52:57 +0000