Split AST in 2

One AST is meant to be a target parser and tries to adhere as much as possible
to the spec. The other is a simplified version of that AST meant for execution.

Also newtypes have been replaced by type synonyms and NonEmpty lists are being
used where it makes sense.
This commit is contained in:
Danny Navarro 2017-01-28 14:15:14 -03:00
parent 3e991adf4e
commit 5390c4ca1e
No known key found for this signature in database
GPG Key ID: 81E5F99780FA6A32
9 changed files with 281 additions and 287 deletions

View File

@ -1,11 +1,13 @@
-- | This module defines an abstract syntax tree for the @GraphQL@ language based on
-- <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>.
--
-- Target AST for Parser.
module Data.GraphQL.AST where
import Data.Int (Int32)
import Data.String (IsString(fromString))
import Data.Text (Text, pack)
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
-- * Name
@ -13,116 +15,117 @@ type Name = Text
-- * Document
newtype Document = Document [Definition] deriving (Eq,Show)
type Document = NonEmpty Definition
-- * Operations
data Definition = DefinitionOperation OperationDefinition
| DefinitionFragment FragmentDefinition
deriving (Eq,Show)
data OperationDefinition = Query Node
| Mutation Node
data OperationDefinition = OperationSelectionSet SelectionSet
| OperationDefinition OperationType
Name
VariableDefinitions
Directives
SelectionSet
deriving (Eq,Show)
data Node = Node Name [VariableDefinition] [Directive] SelectionSet
deriving (Eq,Show)
data OperationType = Query | Mutation deriving (Eq,Show)
data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
deriving (Eq,Show)
-- * SelectionSet
newtype Variable = Variable Name deriving (Eq,Show)
type SelectionSet = NonEmpty Selection
instance IsString Variable where
fromString = Variable . pack
type SelectionSet = [Selection]
type SelectionSetOpt = [Selection]
data Selection = SelectionField Field
| SelectionFragmentSpread FragmentSpread
| SelectionInlineFragment InlineFragment
deriving (Eq,Show)
-- | A 'SelectionSet' is primarily composed of 'Field's. A 'Field' describes one
-- discrete piece of information available to request within a 'SelectionSet'.
--
-- Some 'Field's describe complex data or relationships to other data. In
-- order to further explore this data, a 'Field' may itself contain a
-- 'SelectionSet', allowing for deeply nested requests. All @GraphQL@ operations
-- must specify their 'Selection's down to 'Field's which return scalar values to
-- ensure an unambiguously shaped response.
--
-- <https://facebook.github.io/graphql/#sec-Language.Query-Document.Fields Field Specification>
data Field = Field Alias Name [Argument] [Directive] SelectionSet
-- * Field
data Field = Field (Maybe Alias) Name Arguments Directives SelectionSetOpt
deriving (Eq,Show)
type Alias = Name
-- | 'Field's are conceptually functions which return values, and occasionally accept
-- 'Argument's which alter their behavior. These 'Argument's often map directly to
-- function arguments within a @GraphQL@ servers implementation.
--
-- <https://facebook.github.io/graphql/#sec-Language.Query-Document.Arguments Argument Specification>
-- * Arguments
type Arguments = [Argument]
data Argument = Argument Name Value deriving (Eq,Show)
-- * Fragments
data FragmentSpread = FragmentSpread Name [Directive]
deriving (Eq,Show)
data FragmentSpread = FragmentSpread Name Directives deriving (Eq,Show)
data InlineFragment =
InlineFragment TypeCondition [Directive] SelectionSet
data InlineFragment = InlineFragment (Maybe TypeCondition) Directives SelectionSet
deriving (Eq,Show)
data FragmentDefinition =
FragmentDefinition Name TypeCondition [Directive] SelectionSet
FragmentDefinition FragmentName TypeCondition Directives SelectionSet
deriving (Eq,Show)
type TypeCondition = NamedType
type FragmentName = Name
-- * Values
type TypeCondition = Name
-- Input Values
-- | 'Field' and 'Directive' 'Arguments' accept input values of various literal
-- primitives; input values can be scalars, enumeration values, lists, or input
-- objects.
--
-- If not defined as constant (for example, in 'DefaultValue'), input values
-- can be specified as a 'Variable'. List and inputs objects may also contain
-- 'Variable's (unless defined to be constant).
--
-- <https://facebook.github.io/graphql/#sec-Input-Values Input Value Specification>
data Value = ValueVariable Variable
| ValueInt Int32
-- GraphQL Float is double precison
| ValueFloat Double
| ValueBoolean Bool
| ValueString Text
| ValueEnum Name
| ValueInt IntValue
| ValueFloat FloatValue
| ValueString StringValue
| ValueBoolean BooleanValue
| ValueNull
| ValueEnum EnumValue
| ValueList ListValue
| ValueObject ObjectValue
deriving (Eq,Show)
newtype ListValue = ListValue [Value] deriving (Eq,Show)
type IntValue = Int32
newtype ObjectValue = ObjectValue [ObjectField] deriving (Eq,Show)
-- GraphQL Float is double precison
type FloatValue = Double
type StringValue = Text
type BooleanValue = Bool
type EnumValue = Name
type ListValue = [Value]
type ObjectValue = [ObjectField]
data ObjectField = ObjectField Name Value deriving (Eq,Show)
-- * Variables
type VariableDefinitions = [VariableDefinition]
data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
deriving (Eq,Show)
type Variable = Name
type DefaultValue = Value
-- * Directives
-- * Input Types
data Directive = Directive Name [Argument] deriving (Eq,Show)
-- * Type Reference
data Type = TypeNamed NamedType
| TypeList ListType
data Type = TypeNamed Name
| TypeList Type
| TypeNonNull NonNullType
deriving (Eq,Show)
newtype NamedType = NamedType Name deriving (Eq,Show)
newtype ListType = ListType Type deriving (Eq,Show)
data NonNullType = NonNullTypeNamed NamedType
| NonNullTypeList ListType
data NonNullType = NonNullTypeNamed Name
| NonNullTypeList Type
deriving (Eq,Show)
-- * Directives
type Directives = [Directive]
data Directive = Directive Name [Argument] deriving (Eq,Show)

View File

@ -6,15 +6,17 @@ import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
newtype Name = Name Text deriving (Eq,Show)
type Name = Text
newtype Document = Document (NonEmpty Operation) deriving (Eq,Show)
type Document = NonEmpty Operation
data Operation = Query (NonEmpty Field)
| Mutation (NonEmpty Field)
deriving (Eq,Show)
data Field = Field Name [Argument] [Field] deriving (Eq,Show)
data Field = Field (Maybe Alias) Name [Argument] [Field] deriving (Eq,Show)
type Alias = Name
data Argument = Argument Name Value deriving (Eq,Show)

View File

@ -2,7 +2,9 @@
-- | This module defines a printer for the @GraphQL@ language.
module Data.GraphQL.Encoder where
import Data.Foldable (fold)
import Data.Monoid ((<>))
import qualified Data.List.NonEmpty as NonEmpty (toList)
import Data.Text (Text, cons, intercalate, pack, snoc)
@ -10,24 +12,26 @@ import Data.GraphQL.AST
-- * Document
-- TODO: Use query shorthand
document :: Document -> Text
document (Document defs) = (`snoc` '\n') . mconcat $ definition <$> defs
document defs = (`snoc` '\n') . mconcat . NonEmpty.toList $ definition <$> defs
definition :: Definition -> Text
definition (DefinitionOperation x) = operationDefinition x
definition (DefinitionFragment x) = fragmentDefinition x
operationDefinition :: OperationDefinition -> Text
operationDefinition (Query n) = "query " <> node n
operationDefinition (Mutation n) = "mutation " <> node n
operationDefinition (OperationSelectionSet sels) = selectionSet sels
operationDefinition (OperationDefinition Query name vars dirs sels) =
"query " <> node name vars dirs sels
operationDefinition (OperationDefinition Mutation name vars dirs sels) =
"mutation " <> node name vars dirs sels
node :: Node -> Text
node (Node name vds ds ss) =
node :: Name -> VariableDefinitions -> Directives -> SelectionSet -> Text
node name vars dirs sels =
name
<> optempty variableDefinitions vds
<> optempty directives ds
<> selectionSet ss
<> optempty variableDefinitions vars
<> optempty directives dirs
<> selectionSet sels
variableDefinitions :: [VariableDefinition] -> Text
variableDefinitions = parensCommas variableDefinition
@ -40,10 +44,13 @@ defaultValue :: DefaultValue -> Text
defaultValue val = "=" <> value val
variable :: Variable -> Text
variable (Variable name) = "$" <> name
variable var = "$" <> var
selectionSet :: SelectionSet -> Text
selectionSet = bracesCommas selection
selectionSet = bracesCommas selection . NonEmpty.toList
selectionSetOpt :: SelectionSetOpt -> Text
selectionSetOpt = bracesCommas selection
selection :: Selection -> Text
selection (SelectionField x) = field x
@ -51,12 +58,12 @@ selection (SelectionInlineFragment x) = inlineFragment x
selection (SelectionFragmentSpread x) = fragmentSpread x
field :: Field -> Text
field (Field alias name args ds ss) =
optempty (`snoc` ':') alias
field (Field alias name args dirs selso) =
optempty (`snoc` ':') (fold alias)
<> name
<> optempty arguments args
<> optempty directives ds
<> optempty selectionSet ss
<> optempty directives dirs
<> optempty selectionSetOpt selso
arguments :: [Argument] -> Text
arguments = parensCommas argument
@ -71,26 +78,27 @@ fragmentSpread (FragmentSpread name ds) =
"..." <> name <> optempty directives ds
inlineFragment :: InlineFragment -> Text
inlineFragment (InlineFragment (NamedType tc) ds ss) =
"... on " <> tc
<> optempty directives ds
<> optempty selectionSet ss
inlineFragment (InlineFragment tc dirs sels) =
"... on " <> fold tc
<> directives dirs
<> selectionSet sels
fragmentDefinition :: FragmentDefinition -> Text
fragmentDefinition (FragmentDefinition name (NamedType tc) ds ss) =
fragmentDefinition (FragmentDefinition name tc dirs sels) =
"fragment " <> name <> " on " <> tc
<> optempty directives ds
<> selectionSet ss
<> optempty directives dirs
<> selectionSet sels
-- * Values
value :: Value -> Text
value (ValueVariable x) = variable x
-- TODO: This will be replaced with `decimal` Buidler
-- TODO: This will be replaced with `decimal` Builder
value (ValueInt x) = pack $ show x
-- TODO: This will be replaced with `decimal` Buidler
-- TODO: This will be replaced with `decimal` Builder
value (ValueFloat x) = pack $ show x
value (ValueBoolean x) = booleanValue x
value ValueNull = mempty
value (ValueString x) = stringValue x
value (ValueEnum x) = x
value (ValueList x) = listValue x
@ -105,10 +113,10 @@ stringValue :: Text -> Text
stringValue = quotes
listValue :: ListValue -> Text
listValue (ListValue vs) = bracketsCommas value vs
listValue = bracketsCommas value
objectValue :: ObjectValue -> Text
objectValue (ObjectValue ofs) = bracesCommas objectField ofs
objectValue = bracesCommas objectField
objectField :: ObjectField -> Text
objectField (ObjectField name v) = name <> ":" <> value v
@ -124,18 +132,15 @@ directive (Directive name args) = "@" <> name <> optempty arguments args
-- * Type Reference
type_ :: Type -> Text
type_ (TypeNamed (NamedType x)) = x
type_ (TypeNamed x) = x
type_ (TypeList x) = listType x
type_ (TypeNonNull x) = nonNullType x
namedType :: NamedType -> Text
namedType (NamedType name) = name
listType :: ListType -> Text
listType (ListType ty) = brackets (type_ ty)
listType :: Type -> Text
listType x = brackets (type_ x)
nonNullType :: NonNullType -> Text
nonNullType (NonNullTypeNamed (NamedType x)) = x <> "!"
nonNullType (NonNullTypeNamed x) = x <> "!"
nonNullType (NonNullTypeList x) = listType x <> "!"
-- * Internal

View File

@ -21,38 +21,37 @@ import Data.GraphQL.Error
-- errors wrapped in an /errors/ field.
execute :: Alternative f
=> Schema.Schema f -> Schema.Subs -> Document -> f Aeson.Value
execute (Schema resolvs) subs doc = runCollectErrs res
where res = Schema.resolvers resolvs $ rootFields subs doc
execute resolvers subs doc = undefined -- resolver resolvs $ rootFields subs doc
-- | Takes a variable substitution function and a @GraphQL@ document.
-- If the document contains one query (and no other definitions)
-- it applies the substitution to the query's set of selections
-- and then returns their fields.
rootFields :: Schema.Subs -> Document -> [Field]
rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =
Schema.fields $ substitute subs <$> sels
rootFields _ _ = []
-- rootFields :: Schema.Subs -> Document -> [Field]
-- rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =
-- Schema.fields $ substitute subs <$> sels
-- rootFields _ _ = []
-- | Takes a variable substitution function and a selection. If the
-- selection is a field it applies the substitution to the field's
-- arguments using 'subsArg', and recursively applies the substitution to
-- the arguments of fields nested in the primary field.
substitute :: Schema.Subs -> Selection -> Selection
substitute subs (SelectionField (Field alias name args directives sels)) =
SelectionField $ Field
alias
name
-- TODO: Get rid of `catMaybes`, invalid arguments should raise an error
(catMaybes $ subsArg subs <$> args)
directives
(substitute subs <$> sels)
substitute _ sel = sel
-- substitute :: Schema.Subs -> Selection -> Selection
-- substitute subs (SelectionField (Field alias name args directives sels)) =
-- SelectionField $ Field
-- alias
-- name
-- -- TODO: Get rid of `catMaybes`, invalid arguments should raise an error
-- (catMaybes $ subsArg subs <$> args)
-- directives
-- (substitute subs <$> sels)
-- substitute _ sel = sel
-- TODO: Support different value types
-- | Takes a variable substitution function and an argument. If the
-- argument's value is a variable the substitution is applied to the
-- variable's name.
subsArg :: Schema.Subs -> Argument -> Maybe Argument
subsArg subs (Argument n (ValueVariable (Variable v))) =
Argument n . ValueString <$> subs v
subsArg _ arg = Just arg
-- subsArg :: Schema.Subs -> Argument -> Maybe Argument
-- subsArg subs (Argument n (ValueVariable (Variable v))) =
-- Argument n . ValueString <$> subs v
-- subsArg _ arg = Just arg

View File

@ -1,27 +1,31 @@
{-# 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 ((<|>), empty, many, optional)
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)
import Data.Text (Text, append)
import Data.Attoparsec.Combinator (lookAhead)
import Data.Attoparsec.Text
( Parser
, (<?>)
, anyChar
, scientific
, endOfLine
, inClass
, many1
, manyTill
, option
, peekChar
, scientific
, takeWhile
, takeWhile1
)
@ -35,20 +39,12 @@ name = tok $ append <$> takeWhile1 isA_z
<*> takeWhile ((||) <$> isDigit <*> isA_z)
where
-- `isAlpha` handles many more Unicode Chars
isA_z = inClass $ '_' : ['A'..'Z'] ++ ['a'..'z']
isA_z = inClass $ '_' : ['A'..'Z'] <> ['a'..'z']
-- * Document
document :: Parser Document
document = whiteSpace
*> (Document <$> many1 definition)
-- Try SelectionSet when no definition
<|> (Document . pure
. DefinitionOperation
. Query
. Node mempty empty empty
<$> selectionSet)
<?> "document error!"
document = whiteSpace *> manyNE definition
definition :: Parser Definition
definition = DefinitionOperation <$> operationDefinition
@ -56,54 +52,48 @@ definition = DefinitionOperation <$> operationDefinition
<?> "definition error!"
operationDefinition :: Parser OperationDefinition
operationDefinition =
Query <$ tok "query" <*> node
<|> Mutation <$ tok "mutation" <*> node
<?> "operationDefinition error!"
node :: Parser Node
node = Node <$> name
<*> optempty variableDefinitions
<*> optempty directives
operationDefinition = OperationSelectionSet <$> selectionSet
<|> OperationDefinition <$> operationType
<*> name
<*> opt variableDefinitions
<*> opt directives
<*> selectionSet
<?> "operationDefinition error"
variableDefinitions :: Parser [VariableDefinition]
variableDefinitions = parens (many1 variableDefinition)
operationType :: Parser OperationType
operationType = Query <$ tok "query"
<|> Mutation <$ tok "mutation"
<?> "operationType error"
variableDefinition :: Parser VariableDefinition
variableDefinition =
VariableDefinition <$> variable
<* tok ":"
<*> type_
<*> optional defaultValue
defaultValue :: Parser DefaultValue
defaultValue = tok "=" *> value
variable :: Parser Variable
variable = Variable <$ tok "$" <*> name
-- * SelectionSet
selectionSet :: Parser SelectionSet
selectionSet = braces $ many1 selection
selectionSet = braces $ manyNE selection
selectionSetOpt :: Parser SelectionSetOpt
selectionSetOpt = braces $ many1 selection
selection :: Parser Selection
selection = SelectionField <$> field
-- Inline first to catch `on` case
<|> SelectionInlineFragment <$> inlineFragment
<|> SelectionFragmentSpread <$> fragmentSpread
<|> SelectionInlineFragment <$> inlineFragment
<?> "selection error!"
-- * Field
field :: Parser Field
field = Field <$> optempty alias
field = Field <$> optional alias
<*> name
<*> optempty arguments
<*> optempty directives
<*> optempty selectionSet
<*> opt arguments
<*> opt directives
<*> opt selectionSetOpt
alias :: Parser Alias
alias = name <* tok ":"
arguments :: Parser [Argument]
-- * Arguments
arguments :: Parser Arguments
arguments = parens $ many1 argument
argument :: Parser Argument
@ -112,50 +102,43 @@ argument = Argument <$> name <* tok ":" <*> value
-- * Fragments
fragmentSpread :: Parser FragmentSpread
-- TODO: Make sure it fails when `... on`.
-- See https://facebook.github.io/graphql/#FragmentSpread
fragmentSpread = FragmentSpread
<$ tok "..."
<*> name
<*> optempty directives
fragmentSpread = FragmentSpread <$ tok "..."
<*> fragmentName
<*> opt directives
-- InlineFragment tried first in order to guard against 'on' keyword
inlineFragment :: Parser InlineFragment
inlineFragment = InlineFragment
<$ tok "..."
<* tok "on"
<*> typeCondition
<*> optempty directives
inlineFragment = InlineFragment <$ tok "..."
<*> optional typeCondition
<*> opt directives
<*> selectionSet
fragmentDefinition :: Parser FragmentDefinition
fragmentDefinition = FragmentDefinition
<$ tok "fragment"
<*> name
<* tok "on"
<*> typeCondition
<*> optempty directives
<*> opt directives
<*> selectionSet
fragmentName :: Parser FragmentName
fragmentName = but (tok "on") *> name
typeCondition :: Parser TypeCondition
typeCondition = namedType
typeCondition = tok "on" *> name
-- * Values
-- * Input Values
-- This will try to pick the first type it can parse. If you are working with
-- explicit types use the `typedValue` parser.
value :: Parser Value
value = ValueVariable <$> variable
-- TODO: Handle maxBound, Int32 in spec.
<|> tok (either ValueFloat ValueInt . floatingOrInteger <$> scientific)
<|> ValueBoolean <$> booleanValue
<|> ValueNull <$ tok "null"
<|> ValueString <$> stringValue
-- `true` and `false` have been tried before
<|> ValueEnum <$> name
<|> ValueEnum <$> enumValue
<|> ValueList <$> listValue
<|> ValueObject <$> objectValue
<?> "value error!"
where
booleanValue :: Parser Bool
booleanValue = True <$ tok "true"
<|> False <$ tok "false"
@ -164,46 +147,58 @@ booleanValue = True <$ tok "true"
stringValue :: Parser Text
stringValue = quotes (takeWhile (/= '"'))
-- Notice it can be empty
listValue :: Parser ListValue
listValue = ListValue <$> brackets (many value)
enumValue :: Parser Name
enumValue = but (tok "true") *> but (tok "false") *> but (tok "null") *> name
-- Notice it can be empty
objectValue :: Parser ObjectValue
objectValue = ObjectValue <$> braces (many objectField)
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
<|> TypeList <$> brackets type_
<|> TypeNonNull <$> nonNullType
<?> "type_ error!"
nonNullType :: Parser NonNullType
nonNullType = NonNullTypeNamed <$> name <* tok "!"
<|> NonNullTypeList <$> brackets type_ <* tok "!"
<?> "nonNullType error!"
-- * Directives
directives :: Parser [Directive]
directives :: Parser Directives
directives = many1 directive
directive :: Parser Directive
directive = Directive
<$ tok "@"
<*> name
<*> optempty arguments
-- * Type Reference
type_ :: Parser Type
type_ = TypeList <$> listType
<|> TypeNonNull <$> nonNullType
<|> TypeNamed <$> namedType
<?> "type_ error!"
namedType :: Parser NamedType
namedType = NamedType <$> name
listType :: Parser ListType
listType = ListType <$> brackets type_
nonNullType :: Parser NonNullType
nonNullType = NonNullTypeNamed <$> namedType <* tok "!"
<|> NonNullTypeList <$> listType <* tok "!"
<?> "nonNullType error!"
<*> opt arguments
-- * Internal
@ -225,12 +220,18 @@ brackets = between "[" "]"
between :: Parser Text -> Parser Text -> Parser a -> Parser a
between open close p = tok open *> p <* tok close
-- `empty` /= `pure mempty` for `Parser`.
optempty :: Monoid a => Parser a -> Parser a
optempty = option mempty
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
--
whiteSpace :: Parser ()
whiteSpace = peekChar >>= traverse_ (\c ->
if isSpace c || c == ','

View File

@ -3,7 +3,7 @@
-- | This module provides a representation of a @GraphQL@ Schema in addition to
-- functions for defining and manipulating Schemas.
module Data.GraphQL.Schema
( Schema(..)
( Schema
, Resolver
, Subs
, object
@ -15,31 +15,31 @@ module Data.GraphQL.Schema
, enum
, enumA
, resolvers
, fields
-- * AST Reexports
, Field
, Argument(..)
, Value(..)
) where
import Data.Bifunctor (first)
import Data.Monoid (Alt(Alt,getAlt))
import Control.Applicative (Alternative((<|>), empty))
import Data.Maybe (catMaybes)
import Data.Bifunctor (first)
import Data.Foldable (fold)
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (fromMaybe)
import Data.Monoid (Alt(Alt,getAlt))
import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import qualified Data.Text as T (null, unwords)
import qualified Data.Text as T (unwords)
import Data.GraphQL.AST
import Data.GraphQL.AST.Core
import Data.GraphQL.Error
-- | A GraphQL schema.
-- @f@ is usually expected to be an instance of 'Alternative'.
data Schema f = Schema [Resolver f]
type Schema f = NonEmpty (Resolver f)
-- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information
-- (or 'empty'). @f@ is usually expected to be an instance of 'Alternative'.
@ -48,8 +48,7 @@ type Resolver f = Field -> CollectErrsT f Aeson.Object
-- | Variable substitution function.
type Subs = Text -> Maybe Text
-- | Create a named 'Resolver' from a list of 'Resolver's.
object :: Alternative f => Text -> [Resolver f] -> Resolver f
object :: Alternative f => Name -> [Resolver f] -> Resolver f
object name resolvs = objectA name $ \case
[] -> resolvs
_ -> empty
@ -57,9 +56,8 @@ object name resolvs = objectA name $ \case
-- | Like 'object' but also taking 'Argument's.
objectA
:: Alternative f
=> Text -> ([Argument] -> [Resolver f]) -> Resolver f
objectA name f fld@(Field _ _ args _ sels) =
withField name (resolvers (f args) $ fields sels) fld
=> Name -> ([Argument] -> [Resolver f]) -> Resolver f
objectA name f fld@(Field _ _ args sels) = withField name (resolvers (f args) sels) fld
-- | A scalar represents a primitive value, like a string or an integer.
scalar :: (Alternative f, Aeson.ToJSON a) => Text -> a -> Resolver f
@ -70,11 +68,10 @@ scalar name s = scalarA name $ \case
-- | Like 'scalar' but also taking 'Argument's.
scalarA
:: (Alternative f, Aeson.ToJSON a)
=> Text -> ([Argument] -> f a) -> Resolver f
scalarA name f fld@(Field _ _ args _ []) = withField name (errWrap $ f args) fld
=> Name -> ([Argument] -> f a) -> Resolver f
scalarA name f fld@(Field _ _ args []) = withField name (errWrap $ f args) fld
scalarA _ _ _ = empty
-- | Like 'object' but taking lists of 'Resolver's instead of a single list.
array :: Alternative f => Text -> [[Resolver f]] -> Resolver f
array name resolvs = arrayA name $ \case
[] -> resolvs
@ -84,8 +81,8 @@ array name resolvs = arrayA name $ \case
arrayA
:: Alternative f
=> Text -> ([Argument] -> [[Resolver f]]) -> Resolver f
arrayA name f fld@(Field _ _ args _ sels) =
withField name (joinErrs $ traverse (flip resolvers $ fields sels) $ f args) fld
arrayA name f fld@(Field _ _ args sels) =
withField name (joinErrs $ traverse (`resolvers` sels) $ f args) fld
-- | Represents one of a finite set of possible values.
-- Used in place of a 'scalar' when the possible responses are easily enumerable.
@ -96,19 +93,19 @@ enum name enums = enumA name $ \case
-- | Like 'enum' but also taking 'Argument's.
enumA :: Alternative f => Text -> ([Argument] -> f [Text]) -> Resolver f
enumA name f fld@(Field _ _ args _ []) = withField name (errWrap $ f args) fld
enumA name f fld@(Field _ _ args []) = withField name (errWrap $ f args) fld
enumA _ _ _ = empty
-- | Helper function to facilitate 'Argument' handling.
withField
:: (Alternative f, Aeson.ToJSON a)
=> Text -> CollectErrsT f a -> Field -> CollectErrsT f (HashMap Text Aeson.Value)
withField name f (Field alias name' _ _ _) =
=> Name -> CollectErrsT f a -> Field -> CollectErrsT f (HashMap Text Aeson.Value)
withField name f (Field alias name' _ _) =
if name == name'
then fmap (first $ HashMap.singleton aliasOrName . Aeson.toJSON) f
else empty
where
aliasOrName = if T.null alias then name' else alias
aliasOrName = fromMaybe name' alias
-- | Takes a list of 'Resolver's and a list of 'Field's and applies each
-- 'Resolver' to each 'Field'. Resolves into a value containing the
@ -118,18 +115,8 @@ resolvers resolvs =
fmap (first Aeson.toJSON . fold)
. traverse (\fld -> getAlt (foldMap (Alt . ($ fld)) resolvs) <|> errmsg fld)
where
errmsg (Field alias name _ _ _) = addErrMsg msg $ (errWrap . pure) val
errmsg (Field alias name _ _) = addErrMsg msg $ (errWrap . pure) val
where
val = HashMap.singleton aliasOrName Aeson.Null
msg = T.unwords ["field", name, "not resolved."]
aliasOrName = if T.null alias then name else alias
-- | Checks whether the given 'Selection' contains a 'Field' and
-- returns the 'Field' if so, else returns 'Nothing'.
field :: Selection -> Maybe Field
field (SelectionField x) = Just x
field _ = Nothing
-- | Returns a list of the 'Field's contained in the given 'SelectionSet'.
fields :: SelectionSet -> [Field]
fields = catMaybes . fmap field
aliasOrName = fromMaybe name alias

View File

@ -25,11 +25,12 @@ library
ghc-options: -Wall
exposed-modules: Data.GraphQL
Data.GraphQL.AST
Data.GraphQL.Encoder
Data.GraphQL.AST.Core
Data.GraphQL.Execute
Data.GraphQL.Encoder
Data.GraphQL.Error
Data.GraphQL.Schema
Data.GraphQL.Parser
Data.GraphQL.Error
build-depends: aeson >= 0.7.0.3,
attoparsec >= 0.10.4.0,
base >= 4.7 && < 5,

View File

@ -1,15 +1,11 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Test.StarWars.Schema where
import Control.Applicative (Alternative, empty)
import Data.List.NonEmpty (NonEmpty((:|)))
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
import Data.Traversable (traverse)
#endif
import Data.GraphQL.Schema
import Data.GraphQL.Schema (Schema, Resolver, Argument(..), Value(..))
import qualified Data.GraphQL.Schema as Schema
import Test.StarWars.Data
@ -18,7 +14,7 @@ import Test.StarWars.Data
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
schema :: Alternative f => Schema f
schema = Schema [hero, human, droid]
schema = hero :| [human, droid]
hero :: Alternative f => Resolver f
hero = Schema.objectA "hero" $ \case

View File

@ -18,10 +18,10 @@ import qualified Test.StarWars.QueryTests as SW
import Paths_graphql (getDataFileName)
main :: IO ()
main = defaultMain . testGroup "Tests" . (: [SW.test]) =<< ksTest
main = defaultMain . testGroup "Tests" . (: [SW.test]) =<< kitchenTest
ksTest :: IO TestTree
ksTest = testCase "Kitchen Sink"
kitchenTest :: IO TestTree
kitchenTest = testCase "Kitchen Sink"
<$> (assertEqual "Encode" <$> expected <*> actual)
where
expected = Text.readFile