diff options
| -rw-r--r-- | graphql.cabal | 3 | ||||
| -rw-r--r-- | src/Language/GraphQL/Lexer.hs | 11 | ||||
| -rw-r--r-- | src/Language/GraphQL/Parser.hs | 2 | ||||
| -rw-r--r-- | tests/Language/GraphQL/LexerSpec.hs | 19 | ||||
| -rw-r--r-- | tests/Language/GraphQL/ParserSpec.hs | 18 |
5 files changed, 44 insertions, 9 deletions
diff --git a/graphql.cabal b/graphql.cabal index 3fa5a4b..510e3da 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 36fc8a7c107b61579191035619873e2001628165d12013cef25921cd7e31a240 +-- hash: 0738bb4bfceb40525227c29cb0c32d360f528ba3a84890817c65f5950e37b311 name: graphql version: 0.4.0.0 @@ -67,6 +67,7 @@ test-suite tasty main-is: Spec.hs other-modules: Language.GraphQL.LexerSpec + Language.GraphQL.ParserSpec Test.KitchenSinkSpec Test.StarWars.Data Test.StarWars.QuerySpec diff --git a/src/Language/GraphQL/Lexer.hs b/src/Language/GraphQL/Lexer.hs index 655be3d..8ca03bf 100644 --- a/src/Language/GraphQL/Lexer.hs +++ b/src/Language/GraphQL/Lexer.hs @@ -1,5 +1,8 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE OverloadedStrings #-} + +-- | This module defines a bunch of small parsers used to parse individual +-- lexemes. module Language.GraphQL.Lexer ( Parser , amp @@ -22,6 +25,7 @@ module Language.GraphQL.Lexer , spread , string , symbol + , unicodeBOM ) where import Control.Applicative ( Alternative(..) @@ -44,6 +48,7 @@ import Text.Megaparsec ( Parsec , notFollowedBy , oneOf , option + , optional , satisfy , sepBy , skipSome @@ -73,9 +78,11 @@ spaceConsumer = Lexer.space ignoredCharacters comment empty comment :: Parser () comment = Lexer.skipLineComment "#" +-- | Lexeme definition which ignores whitespaces and commas. lexeme :: forall a. Parser a -> Parser a lexeme = Lexer.lexeme spaceConsumer +-- | Symbol definition which ignores whitespaces and commas. symbol :: T.Text -> Parser T.Text symbol = Lexer.symbol spaceConsumer @@ -213,3 +220,7 @@ escapeSequence = do _ -> return escaped where step accumulator = (accumulator * 16 +) . digitToInt + +-- | Parser for the "Byte Order Mark". +unicodeBOM :: Parser () +unicodeBOM = optional (char '\xfeff') >> pure () diff --git a/src/Language/GraphQL/Parser.hs b/src/Language/GraphQL/Parser.hs index f18621a..dac15c2 100644 --- a/src/Language/GraphQL/Parser.hs +++ b/src/Language/GraphQL/Parser.hs @@ -17,7 +17,7 @@ import Text.Megaparsec ( lookAhead ) document :: Parser Document -document = spaceConsumer >> lexeme (manyNE definition) +document = unicodeBOM >> spaceConsumer >> lexeme (manyNE definition) definition :: Parser Definition definition = DefinitionOperation <$> operationDefinition diff --git a/tests/Language/GraphQL/LexerSpec.hs b/tests/Language/GraphQL/LexerSpec.hs index 2a370ea..b5b605d 100644 --- a/tests/Language/GraphQL/LexerSpec.hs +++ b/tests/Language/GraphQL/LexerSpec.hs @@ -5,14 +5,16 @@ module Language.GraphQL.LexerSpec ( spec ) where -import Language.GraphQL.Lexer -import qualified Data.Text as T +import Data.Either (isRight) +import Data.Text (Text) import Data.Void (Void) +import Language.GraphQL.Lexer import Test.Hspec ( Spec , context , describe , it , shouldBe + , shouldSatisfy ) import Text.Megaparsec ( ParseErrorBundle , parse @@ -22,6 +24,9 @@ import Text.RawString.QQ (r) spec :: Spec spec = describe "Lexer" $ do context "Reference tests" $ do + it "accepts BOM header" $ + runParser unicodeBOM "\xfeff" `shouldSatisfy` isRight + it "lexes strings" $ do runParser string [r|"simple"|] `shouldBe` Right "simple" runParser string [r|" white space "|] `shouldBe` Right " white space " @@ -77,13 +82,13 @@ spec = describe "Lexer" $ do it "lexes punctuation" $ do runParser bang "!" `shouldBe` Right '!' runParser dollar "$" `shouldBe` Right '$' - runBetween parens "()" `shouldBe` Right () + runBetween parens "()" `shouldSatisfy` isRight runParser spread "..." `shouldBe` Right "..." runParser colon ":" `shouldBe` Right ":" runParser equals "=" `shouldBe` Right "=" runParser at "@" `shouldBe` Right '@' - runBetween brackets "[]" `shouldBe` Right () - runBetween braces "{}" `shouldBe` Right () + runBetween brackets "[]" `shouldSatisfy` isRight + runBetween braces "{}" `shouldSatisfy` isRight runParser pipe "|" `shouldBe` Right "|" context "Implementation tests" $ do @@ -92,8 +97,8 @@ spec = describe "Lexer" $ do it "lexes ampersand" $ runParser amp "&" `shouldBe` Right "&" -runParser :: forall a. Parser a -> T.Text -> Either (ParseErrorBundle T.Text Void) a +runParser :: forall a. Parser a -> Text -> Either (ParseErrorBundle Text Void) a runParser = flip parse "" -runBetween :: (Parser () -> Parser ()) -> T.Text -> Either (ParseErrorBundle T.Text Void) () +runBetween :: (Parser () -> Parser ()) -> Text -> Either (ParseErrorBundle Text Void) () runBetween parser = parse (parser $ pure ()) "" diff --git a/tests/Language/GraphQL/ParserSpec.hs b/tests/Language/GraphQL/ParserSpec.hs new file mode 100644 index 0000000..c412c85 --- /dev/null +++ b/tests/Language/GraphQL/ParserSpec.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.GraphQL.ParserSpec + ( spec + ) where + +import Data.Either (isRight) +import Language.GraphQL.Parser (document) +import Test.Hspec ( Spec + , describe + , it + , shouldSatisfy + ) +import Text.Megaparsec (parse) + +spec :: Spec +spec = describe "Parser" $ + it "accepts BOM header" $ + parse document "" "\xfeff{foo}" `shouldSatisfy` isRight |