add Arbitrary instances for AST.Document, add random arguments Parser test

This commit is contained in:
Dmitrii Skurikhin 2022-02-02 20:52:46 +03:00 committed by Eugen Wissner
parent 647547206f
commit 05e6aa4c95
4 changed files with 115 additions and 13 deletions

View File

@ -12,6 +12,9 @@ and this project adheres to
swapped).
- Parsing empty list as an argument.
### Added
- quickCheck Parser test for arguments. Arbitrary instances for Language.GraphQL.AST.Document.
## [1.0.2.0] - 2021-12-26
### Added
- `Serialize` instance for `Type.Definition.Value`.

View File

@ -93,6 +93,7 @@ test-suite graphql-test
Language.GraphQL.AST.EncoderSpec
Language.GraphQL.AST.LexerSpec
Language.GraphQL.AST.ParserSpec
Language.GraphQL.AST.Arbitrary
Language.GraphQL.ErrorSpec
Language.GraphQL.Execute.CoerceSpec
Language.GraphQL.Execute.OrderedMapSpec

View File

@ -0,0 +1,99 @@
{-# LANGUAGE OverloadedStrings #-}
module Language.GraphQL.AST.Arbitrary 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)
newtype AnyPrintableChar = AnyPrintableChar { getAnyPrintableChar :: Char } deriving (Eq, Show)
alpha :: String
alpha = ['a'..'z'] <> ['A'..'Z']
num :: String
num = ['0'..'9']
instance Arbitrary AnyPrintableChar where
arbitrary = AnyPrintableChar <$> elements chars
where
chars = alpha <> num <> ['_']
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)
-- https://spec.graphql.org/June2018/#Name
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)
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)
instance Arbitrary a => Arbitrary (AnyNode a) where
arbitrary = do
(AnyLocation location') <- arbitrary
node' <- flip Doc.Node location' <$> arbitrary
pure $ AnyNode node'
newtype AnyObjectField a = AnyObjectField { getAnyObjectField :: Doc.ObjectField a } deriving (Eq, Show)
instance Arbitrary a => Arbitrary (AnyObjectField a) where
arbitrary = do
name' <- getAnyName <$> arbitrary
value' <- getAnyNode <$> arbitrary
location' <- getAnyLocation <$> arbitrary
pure $ AnyObjectField $ Doc.ObjectField name' value' location'
newtype AnyValue = AnyValue { getAnyValue :: Doc.Value } deriving (Eq, Show)
instance Arbitrary AnyValue where
arbitrary = AnyValue <$> oneof
[ variableGen
, Doc.Int <$> arbitrary
, Doc.Float <$> arbitrary
, Doc.String <$> (getAnyPrintableText <$> arbitrary)
, Doc.Boolean <$> arbitrary
, MkGen $ \_ _ -> Doc.Null
, Doc.Enum <$> (getAnyName <$> arbitrary)
, Doc.List <$> listGen
, Doc.Object <$> objectGen
]
where
variableGen :: Gen Doc.Value
variableGen = Doc.Variable <$> (getAnyName <$> arbitrary)
listGen :: Gen [Doc.Node Doc.Value]
listGen = (resize 5 . listOf) nodeGen
nodeGen = do
node' <- getAnyNode <$> (arbitrary :: Gen (AnyNode AnyValue))
pure (getAnyValue <$> node')
objectGen :: Gen [Doc.ObjectField Doc.Value]
objectGen = resize 1 $ do
list <- getNonEmpty <$> (arbitrary :: Gen (NonEmptyList (AnyObjectField AnyValue)))
pure $ map (fmap getAnyValue . getAnyObjectField) list
newtype AnyArgument a = AnyArgument { getAnyArgument :: Doc.Argument } deriving (Eq, Show)
instance Arbitrary a => Arbitrary (AnyArgument a) where
arbitrary = do
name' <- getAnyName <$> arbitrary
(AnyValue value') <- arbitrary
(AnyLocation location') <- arbitrary
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'

View File

@ -5,6 +5,8 @@ module Language.GraphQL.AST.ParserSpec
) 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
@ -12,6 +14,8 @@ import Language.GraphQL.TH
import Test.Hspec (Spec, describe, it, context)
import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn)
import Text.Megaparsec (parse)
import Test.QuickCheck (property, NonEmptyList (..), mapSize)
import Language.GraphQL.AST.Arbitrary
spec :: Spec
spec = describe "Parser" $ do
@ -29,7 +33,7 @@ spec = describe "Parser" $ do
hello(text: "Argument")
}|]
it "accepts int as argument" $
it "accepts int as argument1" $
parse document "" `shouldSucceedOn` [gql|{
user(id: 4)
}|]
@ -67,7 +71,12 @@ spec = describe "Parser" $ do
test(username: """username""", password: """password""")
}|]
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 "parses minimal schema definition" $
parse document "" `shouldSucceedOn` [gql|schema { query: Query }|]
@ -118,16 +127,6 @@ spec = describe "Parser" $ do
}
|]
it "parses minimal enum type definition" $
parse document "" `shouldSucceedOn` [gql|
enum Direction {
NORTH
EAST
SOUTH
WEST
}
|]
it "parses minimal input object type definition" $
parse document "" `shouldSucceedOn` [gql|
input Point2D {