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

.circleci/config.yml

@@ -1,6 +1,7 @@
 version: 2
 jobs:
   build:
+    resource_class: large
     docker:
       - image: fpco/stack-build:lts-13.12
     steps:
@@ -21,3 +22,8 @@ jobs:
           paths:
             - "~/.stack"
             - ".stack-work"
+workflows:
+  version: 2
+  workflow_v20190224:
+    jobs:
+    - build

graphql-parser.cabal

@@ -1,6 +1,10 @@
--- This file has been generated from package.yaml by hpack version 0.9.1.
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.31.2.
 --
 -- see: https://github.com/sol/hpack
+--
+-- hash: 7308d13493928552f44b710a082dd9565e8c7fe65cfd138ad60fcfe10d46d637
 
 name:           graphql-parser
 version:        0.1.0.0
@@ -13,11 +17,9 @@ copyright:      2018 Hasura Technologies Pvt. Ltd.
 license:        BSD3
 license-file:   LICENSE
 build-type:     Simple
-cabal-version:  >= 1.10
-
 extra-source-files:
-    ChangeLog.md
     README.md
+    ChangeLog.md
 
 source-repository head
   type: git
@@ -29,23 +31,23 @@ library
   default-extensions: NoImplicitPrelude
   ghc-options: -O2 -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns
   build-depends:
-      base >= 4.7 && < 5
-    , protolude
+      aeson
     , attoparsec
-    , text
-    , aeson
-    , scientific
+    , base >=4.7 && <5
+    , bytestring
     , containers
-    , unordered-containers
-    , vector
-    , template-haskell
-    , th-lift-instances
     , filepath
+    , hedgehog
     , prettyprinter
-    , bytestring
+    , protolude
+    , regex-tdfa >=1.2
+    , scientific
+    , template-haskell
+    , text
     , text-builder
-    , hedgehog
-    , regex-tdfa >= 1.2
+    , th-lift-instances
+    , unordered-containers
+    , vector
   exposed-modules:
       Language.GraphQL.Draft.Generator.Document
       Language.GraphQL.Draft.Generator.Primitives
@@ -60,62 +62,67 @@ library
       Language.GraphQL.Draft.Printer.Text
       Language.GraphQL.Draft.Syntax
       Language.GraphQL.Draft.TH
+  other-modules:
+      Paths_graphql_parser
   default-language: Haskell2010
 
 test-suite graphql-parser-test
   type: exitcode-stdio-1.0
   main-is: Spec.hs
+  other-modules:
+      Keywords
   hs-source-dirs:
       test
   default-extensions: NoImplicitPrelude
   ghc-options: -O2 -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      base >= 4.7 && < 5
-    , protolude
+      aeson
     , attoparsec
-    , text
-    , aeson
-    , scientific
+    , base >=4.7 && <5
+    , bytestring
     , containers
-    , unordered-containers
-    , vector
-    , template-haskell
-    , th-lift-instances
     , filepath
-    , prettyprinter
-    , bytestring
-    , text-builder
-    , hedgehog
-    , regex-tdfa >= 1.2
     , graphql-parser
     , hedgehog
+    , prettyprinter
+    , protolude
+    , regex-tdfa >=1.2
+    , scientific
+    , template-haskell
+    , text
+    , text-builder
+    , th-lift-instances
+    , unordered-containers
+    , vector
   default-language: Haskell2010
 
 benchmark graphql-parser-bench
   type: exitcode-stdio-1.0
   main-is: Benchmark.hs
+  other-modules:
+      Paths_graphql_parser
   hs-source-dirs:
       bench
   default-extensions: NoImplicitPrelude
   ghc-options: -O2 -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wall -O2
   build-depends:
-      base >= 4.7 && < 5
-    , protolude
+      aeson
     , attoparsec
-    , text
-    , aeson
-    , scientific
+    , base >=4.7 && <5
+    , bytestring
     , containers
-    , unordered-containers
-    , vector
-    , template-haskell
-    , th-lift-instances
+    , criterion
     , filepath
+    , graphql-parser
+    , hedgehog
     , prettyprinter
-    , bytestring
+    , protolude
+    , regex-tdfa >=1.2
+    , scientific
+    , template-haskell
+    , text
     , text-builder
-    , hedgehog
-    , regex-tdfa >= 1.2
-    , graphql-parser
-    , criterion
+    , th-lift-instances
+    , unordered-containers
+    , vector
   default-language: Haskell2010

package.yaml

@@ -78,6 +78,7 @@ benchmarks:
 tests:
   graphql-parser-test:
     main:                Spec.hs
+    other-modules:       Keywords
     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
@@ -174,7 +175,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 +201,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 +212,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 +413,29 @@ tok :: AT.Parser a -> AT.Parser a
 tok p = p <* whiteSpace
 {-# INLINE tok #-}
 
+-- |
+-- Literal functions in the same fashion as `tok`,
+-- however there are issues using `tok` when the token may be followed by additional /a-z0-9/i characters.
+-- This manifests in bugs such as #20 where columns in on_conflict clauses prefixed with keywords
+-- e.g. "nullColumn" actually end up parsing as "[null, Column]".
+--
+-- Adding in a seperate lexing pass would probably be the right way to resolve this behaviour.
+-- This is a simple initial fix to address the bug with more involved changes being able to be
+-- considered seperately.
+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 +465,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/Keywords.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Regression tests for issue #20 https://github.com/hasura/graphql-parser-hs/issues/20
+
+module Keywords (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"

test/Spec.hs

@@ -14,12 +14,13 @@ import           Language.GraphQL.Draft.Generator.Document
 import           Language.GraphQL.Draft.Parser             (parseExecutableDoc)
 import           Language.GraphQL.Draft.Syntax
 
+import Keywords
+
 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
 
-
 data TestMode = TMDev | TMQuick | TMRelease
   deriving (Show)
 
@@ -42,12 +43,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)
     ]
+    ++ Keywords.primitiveTests
 
 propParserPrettyPrinter :: TestLimit -> Property
 propParserPrettyPrinter = mkPropParserPrinter PP.renderExecutableDoc