OSS/graphql
1
1
Fork 1
Code Issues 4 Pull Requests Actions Releases 22 Wiki Activity

Parse queries with megaparsec

Browse Source
This commit is contained in:
Eugen Wissner
2019-06-21 10:44:58 +02:00
parent ce169ecef2
commit 5e9bf9648d
9 changed files with 418 additions and 154 deletions
Download Patch File Download Diff File Expand all files Collapse all files

14
Data/GraphQL.hs
View File

@ -3,10 +3,12 @@ module Data.GraphQL where
import Control.Applicative (Alternative)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Aeson as Aeson
import qualified Data.Attoparsec.Text as Attoparsec
import Text.Megaparsec ( errorBundlePretty
, parse
)
import Data.GraphQL.Execute
import Data.GraphQL.Parser
@ -19,7 +21,7 @@ import Data.GraphQL.Error
-- executed according to the given 'Schema'.
--
-- Returns the response as an @Aeson.@'Aeson.Value'.
graphql :: (Alternative m, Monad m) => Schema m -> Text -> m Aeson.Value
graphql :: (Alternative m, Monad m) => Schema m -> T.Text -> m Aeson.Value
graphql = flip graphqlSubs $ const Nothing
-- | Takes a 'Schema', a variable substitution function and text
@ -28,7 +30,7 @@ graphql = flip graphqlSubs $ const Nothing
-- query and the query is then executed according to the given 'Schema'.
--
-- Returns the response as an @Aeson.@'Aeson.Value'.
graphqlSubs :: (Alternative m, Monad m) => Schema m -> Subs -> Text -> m Aeson.Value
graphqlSubs :: (Alternative m, Monad m) => Schema m -> Subs -> T.Text -> m Aeson.Value
graphqlSubs schema f =
either parseError (execute schema f)
. Attoparsec.parseOnly document
either (parseError . errorBundlePretty) (execute schema f)
. parse document ""

3
Data/GraphQL/Error.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Data.GraphQL.Error (
parseError,
CollectErrsT,
@ -31,7 +32,7 @@ joinErrs = fmap $ fmap fst &&& concatMap snd
-- | Wraps the given 'Applicative' to handle errors
errWrap :: Functor f => f a -> f (a, [Aeson.Value])
errWrap = fmap (flip (,) [])
errWrap = fmap (, [])
-- | Adds an error to the list of errors.
addErr :: Functor f => Aeson.Value -> CollectErrsT f a -> CollectErrsT f a

166
Data/GraphQL/Parser.hs
View File

@ -1,50 +1,22 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
-- | This module defines a parser for @GraphQL@ request documents.
{-# LANGUAGE OverloadedStrings #-}
module Data.GraphQL.Parser where
import Prelude hiding (takeWhile)
import Control.Applicative ((<|>), Alternative, empty, many, optional)
import Control.Monad (when)
import Data.Char (isDigit, isSpace)
import Data.Foldable (traverse_)
import Data.Monoid ((<>))
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Scientific (floatingOrInteger, scientific, toBoundedInteger)
import Data.Text (Text, append)
import Data.Attoparsec.Combinator (lookAhead)
import Data.Attoparsec.Text
( Parser
, (<?>)
, anyChar
, endOfLine
, inClass
, many1
, manyTill
, option
, peekChar
, takeWhile
, takeWhile1
)
import qualified Data.Attoparsec.Text as Attoparsec (scientific)
import Control.Applicative ( Alternative(..)
, optional
)
import Data.GraphQL.AST
-- * Name
name :: Parser Name
name = tok $ append <$> takeWhile1 isA_z
<*> takeWhile ((||) <$> isDigit <*> isA_z)
where
-- `isAlpha` handles many more Unicode Chars
isA_z = inClass $ '_' : ['A'..'Z'] <> ['a'..'z']
-- * Document
import Language.GraphQL.Lexer
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Text as T
import Text.Megaparsec ( lookAhead
, option
, try
, (<?>)
)
document :: Parser Document
document = whiteSpace *> manyNE definition
document = spaceConsumer >> lexeme (manyNE definition)
definition :: Parser Definition
definition = DefinitionOperation <$> operationDefinition
@ -61,9 +33,9 @@ operationDefinition = OperationSelectionSet <$> selectionSet
<?> "operationDefinition error"
operationType :: Parser OperationType
operationType = Query <$ tok "query"
<|> Mutation <$ tok "mutation"
<?> "operationType error"
operationType = Query <$ symbol "query"
<|> Mutation <$ symbol "mutation"
<?> "operationType error"
-- * SelectionSet
@ -71,11 +43,11 @@ selectionSet :: Parser SelectionSet
selectionSet = braces $ manyNE selection
selectionSetOpt :: Parser SelectionSetOpt
selectionSetOpt = braces $ many1 selection
selectionSetOpt = braces $ some selection
selection :: Parser Selection
selection = SelectionField <$> field
<|> SelectionFragmentSpread <$> fragmentSpread
<|> try (SelectionFragmentSpread <$> fragmentSpread)
<|> SelectionInlineFragment <$> inlineFragment
<?> "selection error!"
@ -89,160 +61,124 @@ field = Field <$> optional alias
<*> opt selectionSetOpt
alias :: Parser Alias
alias = name <* tok ":"
alias = try $ name <* colon
-- * Arguments
arguments :: Parser Arguments
arguments = parens $ many1 argument
arguments = parens $ some argument
argument :: Parser Argument
argument = Argument <$> name <* tok ":" <*> value
argument = Argument <$> name <* colon <*> value
-- * Fragments
fragmentSpread :: Parser FragmentSpread
fragmentSpread = FragmentSpread <$ tok "..."
fragmentSpread = FragmentSpread <$ spread
<*> fragmentName
<*> opt directives
inlineFragment :: Parser InlineFragment
inlineFragment = InlineFragment <$ tok "..."
inlineFragment = InlineFragment <$ spread
<*> optional typeCondition
<*> opt directives
<*> selectionSet
fragmentDefinition :: Parser FragmentDefinition
fragmentDefinition = FragmentDefinition
<$ tok "fragment"
<$ symbol "fragment"
<*> name
<*> typeCondition
<*> opt directives
<*> selectionSet
fragmentName :: Parser FragmentName
fragmentName = but (tok "on") *> name
fragmentName = but (symbol "on") *> name
typeCondition :: Parser TypeCondition
typeCondition = tok "on" *> name
typeCondition = symbol "on" *> name
-- * Input Values
value :: Parser Value
value = ValueVariable <$> variable
<|> tok floatOrInt32Value
<|> ValueFloat <$> try float
<|> ValueInt <$> integer
<|> ValueBoolean <$> booleanValue
<|> ValueNull <$ tok "null"
<|> ValueString <$> stringValue
<|> ValueEnum <$> enumValue
<|> ValueNull <$ symbol "null"
<|> ValueString <$> string
<|> ValueString <$> blockString
<|> ValueEnum <$> try enumValue
<|> ValueList <$> listValue
<|> ValueObject <$> objectValue
<?> "value error!"
where
booleanValue :: Parser Bool
booleanValue = True <$ tok "true"
<|> False <$ tok "false"
floatOrInt32Value :: Parser Value
floatOrInt32Value =
Attoparsec.scientific >>=
either (pure . ValueFloat)
(maybe (fail "Integer value is out of range.")
(pure . ValueInt)
. toBoundedInteger . (`scientific` 0))
. floatingOrInteger
-- TODO: Escape characters. Look at `jsstring_` in aeson package.
stringValue :: Parser Text
stringValue = quotes (takeWhile (/= '"'))
booleanValue = True <$ symbol "true"
<|> False <$ symbol "false"
enumValue :: Parser Name
enumValue = but (tok "true") *> but (tok "false") *> but (tok "null") *> name
enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name
listValue :: Parser [Value]
listValue = brackets $ many1 value
listValue = brackets $ some value
objectValue :: Parser [ObjectField]
objectValue = braces $ many1 objectField
objectValue = braces $ some objectField
objectField :: Parser ObjectField
objectField = ObjectField <$> name <* tok ":" <*> value
objectField = ObjectField <$> name <* symbol ":" <*> value
-- * Variables
variableDefinitions :: Parser VariableDefinitions
variableDefinitions = parens $ many1 variableDefinition
variableDefinitions = parens $ some variableDefinition
variableDefinition :: Parser VariableDefinition
variableDefinition = VariableDefinition <$> variable
<* tok ":"
<* colon
<*> type_
<*> optional defaultValue
variable :: Parser Variable
variable = tok "$" *> name
variable = dollar *> name
defaultValue :: Parser DefaultValue
defaultValue = tok "=" *> value
defaultValue = equals *> value
-- * Input Types
type_ :: Parser Type
type_ = TypeNamed <$> name <* but "!"
<|> TypeList <$> brackets type_
<|> TypeNonNull <$> nonNullType
type_ = try (TypeNamed <$> name <* but "!")
<|> TypeList <$> brackets type_
<|> TypeNonNull <$> nonNullType
<?> "type_ error!"
nonNullType :: Parser NonNullType
nonNullType = NonNullTypeNamed <$> name <* tok "!"
<|> NonNullTypeList <$> brackets type_ <* tok "!"
nonNullType = NonNullTypeNamed <$> name <* bang
<|> NonNullTypeList <$> brackets type_ <* bang
<?> "nonNullType error!"
-- * Directives
directives :: Parser Directives
directives = many1 directive
directives = some directive
directive :: Parser Directive
directive = Directive
<$ tok "@"
<$ at
<*> name
<*> opt arguments
-- * Internal
tok :: Parser a -> Parser a
tok p = p <* whiteSpace
parens :: Parser a -> Parser a
parens = between "(" ")"
braces :: Parser a -> Parser a
braces = between "{" "}"
quotes :: Parser a -> Parser a
quotes = between "\"" "\""
brackets :: Parser a -> Parser a
brackets = between "[" "]"
between :: Parser Text -> Parser Text -> Parser a -> Parser a
between open close p = tok open *> p <* tok close
opt :: Monoid a => Parser a -> Parser a
opt = option mempty
-- Hack to reverse parser success
but :: Parser a -> Parser ()
but pn = False <$ lookAhead pn <|> pure True >>= \case
False -> empty
True -> pure ()
False -> empty
True -> pure ()
manyNE :: Alternative f => f a -> f (NonEmpty a)
manyNE p = (:|) <$> p <*> many p
whiteSpace :: Parser ()
whiteSpace = peekChar >>= traverse_ (\c ->
if isSpace c || c == ','
then anyChar *> whiteSpace
else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace)