graphql/Data/GraphQL/Parser.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
-- | This module defines a parser for @GraphQL@ request documents.
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 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

document :: Parser Document
document = whiteSpace *> manyNE definition

definition :: Parser Definition
definition = DefinitionOperation <$> operationDefinition
         <|> DefinitionFragment  <$> fragmentDefinition
         <?> "definition error!"

operationDefinition :: Parser OperationDefinition
operationDefinition = OperationSelectionSet <$> selectionSet
                  <|> OperationDefinition   <$> operationType
                                            <*> optional name
                                            <*> opt variableDefinitions
                                            <*> opt directives
                                            <*> selectionSet
                  <?> "operationDefinition error"

operationType :: Parser OperationType
operationType = Query    <$ tok "query"
            <|> Mutation <$ tok "mutation"
            <?> "operationType error"

-- * SelectionSet

selectionSet :: Parser SelectionSet
selectionSet = braces $ manyNE selection

selectionSetOpt :: Parser SelectionSetOpt
selectionSetOpt = braces $ many1 selection

selection :: Parser Selection
selection = SelectionField          <$> field
        <|> SelectionFragmentSpread <$> fragmentSpread
        <|> SelectionInlineFragment <$> inlineFragment
        <?> "selection error!"

-- * Field

field :: Parser Field
field = Field <$> optional alias
              <*> name
              <*> opt arguments
              <*> opt directives
              <*> opt selectionSetOpt

alias :: Parser Alias
alias = name <* tok ":"

-- * Arguments

arguments :: Parser Arguments
arguments = parens $ many1 argument

argument :: Parser Argument
argument = Argument <$> name <* tok ":" <*> value

-- * Fragments

fragmentSpread :: Parser FragmentSpread
fragmentSpread = FragmentSpread <$  tok "..."
                                <*> fragmentName
                                <*> opt directives

inlineFragment :: Parser InlineFragment
inlineFragment = InlineFragment <$  tok "..."
                                <*> optional typeCondition
                                <*> opt directives
                                <*> selectionSet

fragmentDefinition :: Parser FragmentDefinition
fragmentDefinition = FragmentDefinition
                 <$  tok "fragment"
                 <*> name
                 <*> typeCondition
                 <*> opt directives
                 <*> selectionSet

fragmentName :: Parser FragmentName
fragmentName = but (tok "on") *> name

typeCondition :: Parser TypeCondition
typeCondition = tok "on" *> name

-- * Input Values

value :: Parser Value
value = ValueVariable <$> variable
    <|> tok floatOrInt32Value
    <|> ValueBoolean  <$> booleanValue
    <|> ValueNull     <$  tok "null"
    <|> ValueString   <$> stringValue
    <|> ValueEnum     <$> 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` 1))
             . floatingOrInteger

    -- TODO: Escape characters. Look at `jsstring_` in aeson package.
    stringValue :: Parser Text
    stringValue = quotes (takeWhile (/= '"'))

    enumValue :: Parser Name
    enumValue = but (tok "true") *> but (tok "false") *> but (tok "null") *> name

    listValue :: Parser [Value]
    listValue = brackets $ many1 value

    objectValue :: Parser [ObjectField]
    objectValue = braces $ many1 objectField

objectField :: Parser ObjectField
objectField = ObjectField <$> name <* tok ":" <*> value

-- * Variables

variableDefinitions :: Parser VariableDefinitions
variableDefinitions = parens $ many1 variableDefinition

variableDefinition :: Parser VariableDefinition
variableDefinition = VariableDefinition <$> variable
                                        <*  tok ":"
                                        <*> type_
                                        <*> optional defaultValue

variable :: Parser Variable
variable = tok "$" *> name

defaultValue :: Parser DefaultValue
defaultValue = tok "=" *> value

-- * Input Types

type_ :: Parser Type
type_ = TypeNamed   <$> name <* but "!"
    <|> TypeList    <$> brackets type_
    <|> TypeNonNull <$> nonNullType
    <?> "type_ error!"

nonNullType :: Parser NonNullType
nonNullType = NonNullTypeNamed <$> name <* tok "!"
          <|> NonNullTypeList  <$> brackets type_  <* tok "!"
          <?> "nonNullType error!"

-- * Directives

directives :: Parser Directives
directives = many1 directive

directive :: Parser Directive
directive = Directive
        <$  tok "@"
        <*> 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 ()

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)