Parse queries with megaparsec

2 files changed, 132 insertions, 24 deletions

diff --git a/tests/Language/GraphQL/LexerTest.hs b/tests/Language/GraphQL/LexerTest.hs
new file mode 100644
index 0000000..a8eb4a3
--- /dev/null
+++ b/tests/Language/GraphQL/LexerTest.hs
@@ -0,0 +1,103 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Language.GraphQL.LexerTest
+    ( implementation
+    , reference
+    ) where
+
+import Control.Applicative (Alternative(..))
+import Language.GraphQL.Lexer
+import qualified Data.Text as T
+import Data.Void (Void)
+import Test.Tasty ( TestTree
+                  , testGroup
+                  )
+import Test.Tasty.HUnit ( testCase
+                        , (@?=)
+                        )
+import Text.Megaparsec ( ParseErrorBundle
+                       , parse
+                       )
+import Text.RawString.QQ (r)
+
+reference :: TestTree
+reference = testGroup "Lexer"
+    [ testCase "lexes strings" $ do
+        runParser string [r|"simple"|] @?= Right "simple"
+        runParser string [r|" white space "|] @?= Right " white space "
+        runParser string [r|"quote \""|] @?= Right [r|quote "|]
+        runParser string [r|"escaped \n"|] @?= Right "escaped \n"
+        runParser string [r|"slashes \\ \/"|] @?= Right [r|slashes \ /|]
+        runParser string [r|"unicode \u1234\u5678\u90AB\uCDEF"|]
+            @?= Right "unicode ሴ噸邫췯"
+
+    , testCase "lexes block string" $ do
+        runParser blockString [r|"""simple"""|] @?= Right "simple"
+        runParser blockString [r|""" white space """|]
+            @?= Right " white space "
+        runParser blockString [r|"""contains " quote"""|]
+            @?= Right [r|contains " quote|]
+        runParser blockString [r|"""contains \""" triplequote"""|]
+            @?= Right [r|contains """ triplequote|]
+        runParser blockString "\"\"\"multi\nline\"\"\"" @?= Right "multi\nline"
+        runParser blockString "\"\"\"multi\rline\r\nnormalized\"\"\""
+            @?= Right "multi\nline\nnormalized"
+        runParser blockString "\"\"\"multi\rline\r\nnormalized\"\"\""
+            @?= Right "multi\nline\nnormalized"
+        runParser blockString [r|"""unescaped \n\r\b\t\f\u1234"""|]
+            @?= Right [r|unescaped \n\r\b\t\f\u1234|]
+        runParser blockString [r|"""slashes \\ \/"""|]
+            @?= Right [r|slashes \\ \/|]
+        runParser blockString [r|"""
+
+            spans
+              multiple
+                lines
+
+            """|] @?= Right "spans\n  multiple\n    lines"
+
+    , testCase "lexes numbers" $ do
+        runParser integer "4" @?= Right 4
+        runParser float "4.123" @?= Right 4.123
+        runParser integer "-4" @?= Right (-4)
+        runParser integer "9" @?= Right 9
+        runParser integer "0" @?= Right 0
+        runParser float "-4.123" @?= Right (-4.123)
+        runParser float "0.123" @?= Right 0.123
+        runParser float "123e4" @?= Right 123e4
+        runParser float "123E4" @?= Right 123E4
+        runParser float "123e-4" @?= Right 123e-4
+        runParser float "123e+4" @?= Right 123e+4
+        runParser float "-1.123e4" @?= Right (-1.123e4)
+        runParser float "-1.123E4" @?= Right (-1.123E4)
+        runParser float "-1.123e-4" @?= Right (-1.123e-4)
+        runParser float "-1.123e+4" @?= Right (-1.123e+4)
+        runParser float "-1.123e4567" @?= Right (-1.123e4567)
+
+    , testCase "lexes punctuation" $ do
+        runParser bang "!" @?= Right '!'
+        runParser dollar "$" @?= Right '$'
+        runBetween parens "()" @?= Right ()
+        runParser spread "..." @?= Right "..."
+        runParser colon ":" @?= Right ":"
+        runParser equals "=" @?= Right "="
+        runParser at "@" @?= Right '@'
+        runBetween brackets "[]" @?= Right ()
+        runBetween braces "{}" @?= Right ()
+        runParser pipe "|" @?= Right "|"
+    ]
+
+implementation :: TestTree
+implementation = testGroup "Lexer"
+    [ testCase "lexes empty block strings" $
+        runParser blockString [r|""""""|] @?= Right ""
+    , testCase "lexes ampersand" $
+        runParser amp "&" @?= Right "&"
+    ]
+
+runParser :: forall a. Parser a -> T.Text -> Either (ParseErrorBundle T.Text Void) a
+runParser = flip parse ""
+
+runBetween :: (Parser () -> Parser ()) -> T.Text -> Either (ParseErrorBundle T.Text Void) ()
+runBetween parser = parse (parser $ pure ()) ""
diff --git a/tests/tasty.hs b/tests/tasty.hs
index aa8da50..5d4036d 100644
--- a/tests/tasty.hs
+++ b/tests/tasty.hs
@@ -1,32 +1,37 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
 module Main where
 
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>), (<*>))
-#endif
-
-import Data.Attoparsec.Text (parseOnly)
-import qualified Data.Text.IO as Text
-import Test.Tasty (TestTree, defaultMain, testGroup)
-import Test.Tasty.HUnit
-
-import qualified Data.GraphQL.Parser as Parser
+import Control.Monad.IO.Class (liftIO)
 import qualified Data.GraphQL.Encoder as Encoder
-
-import qualified Test.StarWars.QueryTests as SW
+import qualified Language.GraphQL.LexerTest as LexerTest
+import qualified Data.GraphQL.Parser as Parser
+import qualified Data.Text.IO as T.IO
+import Text.Megaparsec ( errorBundlePretty
+                       , parse
+                       )
+import Test.Tasty ( TestTree
+                  , defaultMain
+                  , testGroup
+                  )
+import Test.Tasty.HUnit ( assertEqual
+                        , assertFailure
+                        , testCase
+                        )
 import Paths_graphql (getDataFileName)
+import qualified Test.StarWars.QueryTests as SW
 
 main :: IO ()
-main = defaultMain . testGroup "Tests" . (: [SW.test]) =<< kitchenTest
+main = defaultMain $ testGroup "Tests"
+    [ testGroup "Reference tests" [LexerTest.reference, SW.test]
+    , testGroup "Implementation tests" [LexerTest.implementation]
+    , kitchenTest
+    ]
 
-kitchenTest :: IO TestTree
-kitchenTest = testCase "Kitchen Sink"
-     <$> (assertEqual "Encode" <$> expected <*> actual)
-  where
-    expected = Text.readFile
-           =<< getDataFileName "tests/data/kitchen-sink.min.graphql"
+kitchenTest :: TestTree
+kitchenTest = testCase "Kitchen Sink" $ do
+    dataFileName <- getDataFileName "tests/data/kitchen-sink.min.graphql"
+    expected <- T.IO.readFile dataFileName
 
-    actual = either (error "Parsing error!") Encoder.document
-          .  parseOnly Parser.document
-         <$> expected
+    either
+        (assertFailure . errorBundlePretty)
+        (assertEqual "Encode" expected . Encoder.document)
+        $ parse Parser.document dataFileName expected