diff options
| -rw-r--r-- | tests/Language/GraphQL/AST/Arbitrary.hs | 60 | ||||
| -rw-r--r-- | tests/Language/GraphQL/AST/EncoderSpec.hs | 10 | ||||
| -rw-r--r-- | tests/Language/GraphQL/AST/ParserSpec.hs | 255 |
3 files changed, 158 insertions, 167 deletions
diff --git a/tests/Language/GraphQL/AST/Arbitrary.hs b/tests/Language/GraphQL/AST/Arbitrary.hs index 4f74bf3..69247b1 100644 --- a/tests/Language/GraphQL/AST/Arbitrary.hs +++ b/tests/Language/GraphQL/AST/Arbitrary.hs @@ -1,15 +1,26 @@ {-# LANGUAGE OverloadedStrings #-} -module Language.GraphQL.AST.Arbitrary where +module Language.GraphQL.AST.Arbitrary + ( AnyArgument(..) + , AnyLocation(..) + , AnyName(..) + , AnyNode(..) + , AnyObjectField(..) + , AnyValue(..) + , printArgument + ) where import qualified Language.GraphQL.AST.Document as Doc import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary)) import Test.QuickCheck (oneof, elements, listOf, resize, NonEmptyList (..)) import Test.QuickCheck.Gen (Gen (..)) -import Data.Text (Text, pack) +import Data.Text (Text) +import qualified Data.Text as Text import Data.Functor ((<&>)) -newtype AnyPrintableChar = AnyPrintableChar { getAnyPrintableChar :: Char } deriving (Eq, Show) +newtype AnyPrintableChar = AnyPrintableChar + { getAnyPrintableChar :: Char + } deriving (Eq, Show) alpha :: String alpha = ['a'..'z'] <> ['A'..'Z'] @@ -20,30 +31,42 @@ num = ['0'..'9'] instance Arbitrary AnyPrintableChar where arbitrary = AnyPrintableChar <$> elements chars where - chars = alpha <> num <> ['_'] + chars = alpha <> num <> ['_'] -newtype AnyPrintableText = AnyPrintableText { getAnyPrintableText :: Text } deriving (Eq, Show) +newtype AnyPrintableText = AnyPrintableText + { getAnyPrintableText :: Text + } deriving (Eq, Show) instance Arbitrary AnyPrintableText where arbitrary = do nonEmptyStr <- getNonEmpty <$> (arbitrary :: Gen (NonEmptyList AnyPrintableChar)) - pure $ AnyPrintableText (pack $ map getAnyPrintableChar nonEmptyStr) + pure $ AnyPrintableText + $ Text.pack + $ map getAnyPrintableChar nonEmptyStr -- https://spec.graphql.org/June2018/#Name -newtype AnyName = AnyName { getAnyName :: Text } deriving (Eq, Show) +newtype AnyName = AnyName + { getAnyName :: Text + } deriving (Eq, Show) instance Arbitrary AnyName where arbitrary = do firstChar <- elements $ alpha <> ['_'] rest <- (arbitrary :: Gen [AnyPrintableChar]) - pure $ AnyName (pack $ firstChar : map getAnyPrintableChar rest) + pure $ AnyName + $ Text.pack + $ firstChar : map getAnyPrintableChar rest -newtype AnyLocation = AnyLocation { getAnyLocation :: Doc.Location } deriving (Eq, Show) +newtype AnyLocation = AnyLocation + { getAnyLocation :: Doc.Location + } deriving (Eq, Show) instance Arbitrary AnyLocation where arbitrary = AnyLocation <$> (Doc.Location <$> arbitrary <*> arbitrary) -newtype AnyNode a = AnyNode { getAnyNode :: Doc.Node a } deriving (Eq, Show) +newtype AnyNode a = AnyNode + { getAnyNode :: Doc.Node a + } deriving (Eq, Show) instance Arbitrary a => Arbitrary (AnyNode a) where arbitrary = do @@ -51,7 +74,9 @@ instance Arbitrary a => Arbitrary (AnyNode a) where node' <- flip Doc.Node location' <$> arbitrary pure $ AnyNode node' -newtype AnyObjectField a = AnyObjectField { getAnyObjectField :: Doc.ObjectField a } deriving (Eq, Show) +newtype AnyObjectField a = AnyObjectField + { getAnyObjectField :: Doc.ObjectField a + } deriving (Eq, Show) instance Arbitrary a => Arbitrary (AnyObjectField a) where arbitrary = do @@ -60,8 +85,9 @@ instance Arbitrary a => Arbitrary (AnyObjectField a) where location' <- getAnyLocation <$> arbitrary pure $ AnyObjectField $ Doc.ObjectField name' value' location' -newtype AnyValue = AnyValue { getAnyValue :: Doc.Value } - deriving (Eq, Show) +newtype AnyValue = AnyValue + { getAnyValue :: Doc.Value + } deriving (Eq, Show) instance Arbitrary AnyValue where @@ -88,8 +114,9 @@ instance Arbitrary AnyValue , Doc.Object <$> objectGen ] -newtype AnyArgument a = AnyArgument { getAnyArgument :: Doc.Argument } - deriving (Eq, Show) +newtype AnyArgument a = AnyArgument + { getAnyArgument :: Doc.Argument + } deriving (Eq, Show) instance Arbitrary a => Arbitrary (AnyArgument a) where arbitrary = do @@ -99,4 +126,5 @@ instance Arbitrary a => Arbitrary (AnyArgument a) where pure $ AnyArgument $ Doc.Argument name' (Doc.Node value' location') location' printArgument :: AnyArgument AnyValue -> Text -printArgument (AnyArgument (Doc.Argument name' (Doc.Node value' _) _)) = name' <> ": " <> (pack . show) value' +printArgument (AnyArgument (Doc.Argument name' (Doc.Node value' _) _)) = + name' <> ": " <> (Text.pack . show) value' diff --git a/tests/Language/GraphQL/AST/EncoderSpec.hs b/tests/Language/GraphQL/AST/EncoderSpec.hs index b916658..e98d5ef 100644 --- a/tests/Language/GraphQL/AST/EncoderSpec.hs +++ b/tests/Language/GraphQL/AST/EncoderSpec.hs @@ -14,12 +14,9 @@ import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation spec :: Spec spec = do describe "value" $ do - context "null value" $ do - let testNull formatter = value formatter Full.Null `shouldBe` "null" - it "minified" $ testNull minified - it "pretty" $ testNull pretty - context "minified" $ do + it "encodes null" $ + value minified Full.Null `shouldBe` "null" it "escapes \\" $ value minified (Full.String "\\") `shouldBe` "\"\\\\\"" it "escapes double quotes" $ @@ -45,6 +42,9 @@ spec = do it "~" $ value minified (Full.String "\x007E") `shouldBe` "\"~\"" context "pretty" $ do + it "encodes null" $ + value pretty Full.Null `shouldBe` "null" + it "uses strings for short string values" $ value pretty (Full.String "Short text") `shouldBe` "\"Short text\"" it "uses block strings for text with new lines, with newline symbol" $ diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs index 455c99a..3bd2576 100644 --- a/tests/Language/GraphQL/AST/ParserSpec.hs +++ b/tests/Language/GraphQL/AST/ParserSpec.hs @@ -1,16 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} module Language.GraphQL.AST.ParserSpec ( spec ) where import Data.List.NonEmpty (NonEmpty(..)) -import Data.Text (Text) import qualified Data.Text as Text import Language.GraphQL.AST.Document import qualified Language.GraphQL.AST.DirectiveLocation as DirLoc import Language.GraphQL.AST.Parser -import Language.GraphQL.TH import Test.Hspec (Spec, describe, it, context) import Test.Hspec.Megaparsec ( shouldParse @@ -28,127 +25,105 @@ spec = describe "Parser" $ do parse document "" `shouldSucceedOn` "\xfeff{foo}" context "Arguments" $ do - it "accepts block strings as argument" $ - parse document "" `shouldSucceedOn` [gql|{ - hello(text: """Argument""") - }|] - - it "accepts strings as argument" $ - parse document "" `shouldSucceedOn` [gql|{ - hello(text: "Argument") - }|] - - it "accepts int as argument1" $ - parse document "" `shouldSucceedOn` [gql|{ - user(id: 4) - }|] - - it "accepts boolean as argument" $ - parse document "" `shouldSucceedOn` [gql|{ - hello(flag: true) { field1 } - }|] - - it "accepts float as argument" $ - parse document "" `shouldSucceedOn` [gql|{ - body(height: 172.5) { height } - }|] - - it "accepts empty list as argument" $ - parse document "" `shouldSucceedOn` [gql|{ - query(list: []) { field1 } - }|] - - it "accepts two required arguments" $ - parse document "" `shouldSucceedOn` [gql| - mutation auth($username: String!, $password: String!){ - test - }|] - - it "accepts two string arguments" $ - parse document "" `shouldSucceedOn` [gql| - mutation auth{ - test(username: "username", password: "password") - }|] - - it "accepts two block string arguments" $ - parse document "" `shouldSucceedOn` [gql| - mutation auth{ - test(username: """username""", password: """password""") - }|] - - it "fails to parse an empty argument list in parens" $ - parse document "" `shouldFailOn` "{ test() }" - - it "accepts any arguments" $ mapSize (const 10) $ property $ \xs -> - let - query' :: Text - arguments' = map printArgument $ getNonEmpty (xs :: NonEmptyList (AnyArgument AnyValue)) - query' = "query(" <> Text.intercalate ", " arguments' <> ")" in - parse document "" `shouldSucceedOn` ("{ " <> query' <> " }") + it "accepts block strings as argument" $ + parse document "" `shouldSucceedOn` + "{ hello(text: \"\"\"Argument\"\"\") }" + + it "accepts strings as argument" $ + parse document "" `shouldSucceedOn` "{ hello(text: \"Argument\") }" + + it "accepts int as argument" $ + parse document "" `shouldSucceedOn` "{ user(id: 4) }" + + it "accepts boolean as argument" $ + parse document "" `shouldSucceedOn` + "{ hello(flag: true) { field1 } }" + + it "accepts float as argument" $ + parse document "" `shouldSucceedOn` + "{ body(height: 172.5) { height } }" + + it "accepts empty list as argument" $ + parse document "" `shouldSucceedOn` "{ query(list: []) { field1 } }" + + it "accepts two required arguments" $ + parse document "" `shouldSucceedOn` + "mutation auth($username: String!, $password: String!) { test }" + + it "accepts two string arguments" $ + parse document "" `shouldSucceedOn` + "mutation auth { test(username: \"username\", password: \"password\") }" + + it "accepts two block string arguments" $ + let given = "mutation auth {\n\ + \ test(username: \"\"\"username\"\"\", password: \"\"\"password\"\"\")\n\ + \}" + in parse document "" `shouldSucceedOn` given + + it "fails to parse an empty argument list in parens" $ + parse document "" `shouldFailOn` "{ test() }" + + it "accepts any arguments" $ mapSize (const 10) $ property $ \xs -> + let arguments' = map printArgument + $ getNonEmpty (xs :: NonEmptyList (AnyArgument AnyValue)) + query' = "query(" <> Text.intercalate ", " arguments' <> ")" + in parse document "" `shouldSucceedOn` ("{ " <> query' <> " }") it "parses minimal schema definition" $ - parse document "" `shouldSucceedOn` [gql|schema { query: Query }|] + parse document "" `shouldSucceedOn` "schema { query: Query }" it "parses minimal scalar definition" $ - parse document "" `shouldSucceedOn` [gql|scalar Time|] + parse document "" `shouldSucceedOn` "scalar Time" it "parses ImplementsInterfaces" $ - parse document "" `shouldSucceedOn` [gql| - type Person implements NamedEntity & ValuedEntity { - name: String - } - |] + parse document "" `shouldSucceedOn` + "type Person implements NamedEntity & ValuedEntity {\n\ + \ name: String\n\ + \}" it "parses a type without ImplementsInterfaces" $ - parse document "" `shouldSucceedOn` [gql| - type Person { - name: String - } - |] + parse document "" `shouldSucceedOn` + "type Person {\n\ + \ name: String\n\ + \}" it "parses ArgumentsDefinition in an ObjectDefinition" $ - parse document "" `shouldSucceedOn` [gql| - type Person { - name(first: String, last: String): String - } - |] + parse document "" `shouldSucceedOn` + "type Person {\n\ + \ name(first: String, last: String): String\n\ + \}" it "parses minimal union type definition" $ - parse document "" `shouldSucceedOn` [gql| - union SearchResult = Photo | Person - |] + parse document "" `shouldSucceedOn` + "union SearchResult = Photo | Person" it "parses minimal interface type definition" $ - parse document "" `shouldSucceedOn` [gql| - interface NamedEntity { - name: String - } - |] + parse document "" `shouldSucceedOn` + "interface NamedEntity {\n\ + \ name: String\n\ + \}" it "parses minimal enum type definition" $ - parse document "" `shouldSucceedOn` [gql| - enum Direction { - NORTH - EAST - SOUTH - WEST - } - |] + parse document "" `shouldSucceedOn` + "enum Direction {\n\ + \ NORTH\n\ + \ EAST\n\ + \ SOUTH\n\ + \ WEST\n\ + \}" it "parses minimal input object type definition" $ - parse document "" `shouldSucceedOn` [gql| - input Point2D { - x: Float - y: Float - } - |] + parse document "" `shouldSucceedOn` + "input Point2D {\n\ + \ x: Float\n\ + \ y: Float\n\ + \}" it "parses minimal input enum definition with an optional pipe" $ - parse document "" `shouldSucceedOn` [gql| - directive @example on - | FIELD - | FRAGMENT_SPREAD - |] + parse document "" `shouldSucceedOn` + "directive @example on\n\ + \ | FIELD\n\ + \ | FRAGMENT_SPREAD" it "parses two minimal directive definitions" $ let directive name' loc = TypeSystemDefinition @@ -165,10 +140,10 @@ spec = describe "Parser" $ do (DirLoc.ExecutableDirectiveLocation DirLoc.Field) (Location {line = 2, column = 1}) testSchemaExtension = example1 :| [example2] - query = [gql| - directive @example1 on FIELD_DEFINITION - directive @example2 on FIELD - |] + query = Text.unlines + [ "directive @example1 on FIELD_DEFINITION" + , "directive @example2 on FIELD" + ] in parse document "" query `shouldParse` testSchemaExtension it "parses a directive definition with a default empty list argument" $ @@ -185,21 +160,19 @@ spec = describe "Parser" $ do definition = DirectiveDefinition (Description Nothing) "test" - (ArgumentsDefinition [argumentValueDefinition] ) + (ArgumentsDefinition [argumentValueDefinition]) False (loc :| []) directive = TypeSystemDefinition definition $ Location{ line = 1, column = 1 } - query = [gql|directive @test(foo: [String] = []) on FIELD_DEFINITION|] + query = "directive @test(foo: [String] = []) on FIELD_DEFINITION" in parse document "" query `shouldParse` (directive :| []) it "parses schema extension with a new directive" $ - parse document "" `shouldSucceedOn`[gql| - extend schema @newDirective - |] + parse document "" `shouldSucceedOn` "extend schema @newDirective" it "parses schema extension with an operation type definition" $ - parse document "" `shouldSucceedOn` [gql|extend schema { query: Query }|] + parse document "" `shouldSucceedOn` "extend schema { query: Query }" it "parses schema extension with an operation type and directive" $ let newDirective = Directive "newDirective" [] $ Location 1 15 @@ -208,52 +181,42 @@ spec = describe "Parser" $ do $ OperationTypeDefinition Query "Query" :| [] testSchemaExtension = TypeSystemExtension schemaExtension $ Location 1 1 - query = [gql|extend schema @newDirective { query: Query }|] + query = "extend schema @newDirective { query: Query }" in parse document "" query `shouldParse` (testSchemaExtension :| []) it "parses a repeatable directive definition" $ - let given = [gql|directive @test repeatable on FIELD_DEFINITION|] + let given = "directive @test repeatable on FIELD_DEFINITION" isRepeatable (TypeSystemDefinition definition' _ :| []) | DirectiveDefinition _ _ _ repeatable _ <- definition' = repeatable isRepeatable _ = False in parse document "" given `parseSatisfies` isRepeatable it "parses an object extension" $ - parse document "" `shouldSucceedOn` [gql| - extend type Story { - isHiddenLocally: Boolean - } - |] + parse document "" `shouldSucceedOn` + "extend type Story { isHiddenLocally: Boolean }" it "rejects variables in DefaultValue" $ - parse document "" `shouldFailOn` [gql| - query ($book: String = "Zarathustra", $author: String = $book) { - title - } - |] + parse document "" `shouldFailOn` + "query ($book: String = \"Zarathustra\", $author: String = $book) {\n\ + \ title\n\ + \}" it "rejects empty selection set" $ - parse document "" `shouldFailOn` [gql| - query { - innerField {} - } - |] + parse document "" `shouldFailOn` "query { innerField {} }" it "parses documents beginning with a comment" $ - parse document "" `shouldSucceedOn` [gql| - """ - Query - """ - type Query { - queryField: String - } - |] + parse document "" `shouldSucceedOn` + "\"\"\"\n\ + \Query\n\ + \\"\"\"\n\ + \type Query {\n\ + \ queryField: String\n\ + \}" it "parses subscriptions" $ - parse document "" `shouldSucceedOn` [gql| - subscription NewMessages { - newMessage(roomId: 123) { - sender - } - } - |] + parse document "" `shouldSucceedOn` + "subscription NewMessages {\n\ + \ newMessage(roomId: 123) {\n\ + \ sender\n\ + \ }\n\ + \}" |