mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-16 09:51:59 +03:00
e953efeb40
PR-URL: https://github.com/hasura/graphql-engine-mono/pull/7758 Co-authored-by: Tom Harding <6302310+i-am-tom@users.noreply.github.com> GitOrigin-RevId: 311f6c4a5c629c18a55d75a5d5a74f826078e86d
112 lines
4.0 KiB
Haskell
112 lines
4.0 KiB
Haskell
{-# 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
|