Mis-parsing GraphQL identifiers when it starts with keywords (fix #20)

package.yaml

@@ -78,6 +78,7 @@ benchmarks:
 tests:
   graphql-parser-test:
     main:                Spec.hs
+    other-modules:       PrimitiveColumns
     source-dirs:         test
     ghc-options:
     - -threaded

src/Language/GraphQL/Draft/Parser.hs

@@ -12,6 +12,7 @@ module Language.GraphQL.Draft.Parser
 
   , value
   , parseValueConst
+  , nameParser
 
   , graphQLType
   , parseGraphQLType
@@ -24,6 +25,7 @@ import           Protolude                     hiding (option)
 
 import           Control.Applicative           (many, optional, (<|>))
 import           Control.Monad.Fail            (fail)
+import           Prelude                       hiding (fail)
 import           Data.Aeson.Parser             (jstring)
 import qualified Data.Attoparsec.ByteString    as A
 import           Data.Attoparsec.Text          (Parser, anyChar, char, many1,
@@ -174,7 +176,7 @@ parseValueConst = runParser valueConst
 valueConst :: Parser AST.ValueConst
 valueConst = tok (
   (fmap (either AST.VCFloat AST.VCInt) number <?> "number")
-  <|> AST.VCNull     <$  tok "null"
+  <|> AST.VCNull     <$  literal "null"
   <|> AST.VCBoolean  <$> (booleanValue <?> "booleanValue")
   <|> AST.VCString   <$> (stringValue <?> "stringValue")
   -- `true` and `false` have been tried before
@@ -200,7 +202,7 @@ value :: Parser AST.Value
 value = tok (
   AST.VVariable <$> (variable <?> "variable")
   <|> (fmap (either AST.VFloat AST.VInt) number <?> "number")
-  <|> AST.VNull     <$  tok "null"
+  <|> AST.VNull     <$  literal "null"
   <|> AST.VBoolean  <$> (booleanValue <?> "booleanValue")
   <|> AST.VString   <$> (stringValue <?> "stringValue")
   -- `true` and `false` have been tried before
@@ -211,8 +213,9 @@ value = tok (
   )
 
 booleanValue :: Parser Bool
-booleanValue = True  <$ tok "true"
-   <|> False <$ tok "false"
+booleanValue
+  =   True  <$ literal "true"
+  <|> False <$ literal "false"
 
 stringValue :: Parser AST.StringValue
 stringValue = do
@@ -411,6 +414,20 @@ tok :: AT.Parser a -> AT.Parser a
 tok p = p <* whiteSpace
 {-# INLINE tok #-}
 
+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  ->
+      if isNonFirstChar c
+         then mzero
+         else pure ()
+
 comment :: Parser ()
 comment =
   AT.char '#' *>
@@ -440,16 +457,16 @@ whiteSpace = do
 nameParser :: AT.Parser AST.Name
 nameParser =
   AST.Name <$> tok ((<>) <$> AT.takeWhile1 isFirstChar
-                     <*> AT.takeWhile isNonFirstChar)
-  where
-
-    isFirstChar x = isAsciiLower x || isAsciiUpper x || x == '_'
-    {-# INLINE isFirstChar #-}
+                         <*> AT.takeWhile isNonFirstChar)
+{-# INLINE nameParser #-}
 
-    isNonFirstChar x = isFirstChar x || isDigit x
-    {-# INLINE isNonFirstChar #-}
+isFirstChar :: Char -> Bool
+isFirstChar x = isAsciiLower x || isAsciiUpper x || x == '_'
+{-# INLINE isFirstChar #-}
 
-{-# INLINE nameParser #-}
+isNonFirstChar :: Char -> Bool
+isNonFirstChar x = isFirstChar x || isDigit x
+{-# INLINE isNonFirstChar #-}
 
 parens :: Parser a -> Parser a
 parens = between "(" ")"

test/Spec.hs

@@ -14,11 +14,16 @@ import           Language.GraphQL.Draft.Generator.Document
 import           Language.GraphQL.Draft.Parser             (parseExecutableDoc)
 import           Language.GraphQL.Draft.Syntax
 
+import PrimitiveColumns
+
 import qualified Language.GraphQL.Draft.Printer.ByteString as PP.BB
 import qualified Language.GraphQL.Draft.Printer.LazyText   as PP.TLB
 import qualified Language.GraphQL.Draft.Printer.Pretty     as PP
 import qualified Language.GraphQL.Draft.Printer.Text       as PP.TB
 
+-- import Text.Groom
+
+import Prelude hiding (print)
 
 data TestMode = TMDev | TMQuick | TMRelease
   deriving (Show)
@@ -42,12 +47,13 @@ runTest = void . tests
 
 tests :: TestLimit -> IO Bool
 tests nTests =
-  checkParallel $ Group "Test.printer.parser"
+  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)
     ]
+    ++ PrimitiveColumns.primitiveTests
 
 propParserPrettyPrinter :: TestLimit -> Property
 propParserPrettyPrinter = mkPropParserPrinter PP.renderExecutableDoc

test/primitiveColumns.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Regression tests for issue #20 https://github.com/hasura/graphql-parser-hs/issues/20
+
+module PrimitiveColumns (primitiveTests) where
+
+import Hedgehog
+import Protolude
+import GHC.Base (fail)
+
+import Language.GraphQL.Draft.Syntax
+import Language.GraphQL.Draft.Parser
+
+import qualified Language.GraphQL.Draft.Printer.Text as PP.TB
+import qualified Language.GraphQL.Draft.Printer      as P
+
+primitiveTests :: IsString s => [(s, Property)]
+primitiveTests =
+  [ ("property [ parse (print nameValue) == nameValue ]", propNullNameValue)
+  , ("property [ parse (print nameBool) == nameBool ]",   propBoolNameValue)
+  , ("property [ parse (print nameName) == nameName ]",   propNullNameName)
+  ]
+
+propNullNameValue :: Property
+propNullNameValue = property $ either (fail . Protolude.show) (ast ===) astRoundTrip
+  where
+    astRoundTrip = (runParser value) printed
+    printed      = PP.TB.render P.value ast
+    ast          = VList (ListValueG { unListValue = [
+                    VEnum (EnumValue{unEnumValue = Name{unName = "nullColumn"}})]})
+
+propBoolNameValue :: Property
+propBoolNameValue = property $ either (fail . Protolude.show) (ast ===) astRoundTrip
+  where
+    astRoundTrip = (runParser value) printed
+    printed      = PP.TB.render P.value ast
+    ast          = VList (ListValueG { unListValue = [
+                    VEnum (EnumValue{unEnumValue = Name{unName = "trueColumn"}})]})
+
+propNullNameName :: Property
+propNullNameName = property $ either (fail . Protolude.show) (ast ===) astRoundTrip
+  where
+    astRoundTrip = (runParser nameParser) printed
+    printed      = PP.TB.render P.nameP ast
+    ast          = Name "nullColumntwo"