From 5390c4ca1e7e6bcf36dbe5e773c1355dd4b65939 Mon Sep 17 00:00:00 2001 From: Danny Navarro Date: Sat, 28 Jan 2017 14:15:14 -0300 Subject: [PATCH] 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. --- Data/GraphQL/AST.hs | 143 +++++++++++----------- Data/GraphQL/AST/Core.hs | 10 +- Data/GraphQL/Encoder.hs | 73 +++++------ Data/GraphQL/Execute.hs | 39 +++--- Data/GraphQL/Parser.hs | 223 +++++++++++++++++----------------- Data/GraphQL/Schema.hs | 59 ++++----- graphql.cabal | 5 +- tests/Test/StarWars/Schema.hs | 10 +- tests/tasty.hs | 6 +- 9 files changed, 281 insertions(+), 287 deletions(-) diff --git a/Data/GraphQL/AST.hs b/Data/GraphQL/AST.hs index 58ae20d..8a7bbea 100644 --- a/Data/GraphQL/AST.hs +++ b/Data/GraphQL/AST.hs @@ -1,11 +1,13 @@ -- | This module defines an abstract syntax tree for the @GraphQL@ language based on -- . +-- +-- 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 SelectionSetOpt = [Selection] -type SelectionSet = [Selection] - -data Selection = SelectionField Field +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. --- --- -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@ server’s implementation. --- --- +-- * Arguments + +type Arguments = [Argument] + data Argument = Argument Name Value deriving (Eq,Show) -- * Fragments -data FragmentSpread = FragmentSpread Name [Directive] +data FragmentSpread = FragmentSpread Name Directives deriving (Eq,Show) + +data InlineFragment = InlineFragment (Maybe TypeCondition) Directives SelectionSet deriving (Eq,Show) -data InlineFragment = - InlineFragment TypeCondition [Directive] SelectionSet - deriving (Eq,Show) - data FragmentDefinition = - FragmentDefinition Name TypeCondition [Directive] SelectionSet - deriving (Eq,Show) + 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). --- --- 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) diff --git a/Data/GraphQL/AST/Core.hs b/Data/GraphQL/AST/Core.hs index 2ca3928..b5698c6 100644 --- a/Data/GraphQL/AST/Core.hs +++ b/Data/GraphQL/AST/Core.hs @@ -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) +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) diff --git a/Data/GraphQL/Encoder.hs b/Data/GraphQL/Encoder.hs index 0cf878e..083a31d 100644 --- a/Data/GraphQL/Encoder.hs +++ b/Data/GraphQL/Encoder.hs @@ -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_ (TypeList x) = listType 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 diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs index a7e3c91..4dab56c 100644 --- a/Data/GraphQL/Execute.hs +++ b/Data/GraphQL/Execute.hs @@ -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 diff --git a/Data/GraphQL/Parser.hs b/Data/GraphQL/Parser.hs index 2e72a3a..820a323 100644 --- a/Data/GraphQL/Parser.hs +++ b/Data/GraphQL/Parser.hs @@ -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!" +operationDefinition = OperationSelectionSet <$> selectionSet + <|> OperationDefinition <$> operationType + <*> name + <*> opt variableDefinitions + <*> opt directives + <*> selectionSet + "operationDefinition error" -node :: Parser Node -node = Node <$> name - <*> optempty variableDefinitions - <*> optempty directives - <*> selectionSet +operationType :: Parser OperationType +operationType = Query <$ tok "query" + <|> Mutation <$ tok "mutation" + "operationType error" -variableDefinitions :: Parser [VariableDefinition] -variableDefinitions = parens (many1 variableDefinition) - -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 +selection = SelectionField <$> field <|> 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,98 +102,103 @@ 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 - <*> selectionSet +inlineFragment = InlineFragment <$ tok "..." + <*> optional typeCondition + <*> opt directives + <*> selectionSet fragmentDefinition :: Parser FragmentDefinition fragmentDefinition = FragmentDefinition - <$ tok "fragment" - <*> name - <* tok "on" - <*> typeCondition - <*> optempty directives - <*> selectionSet + <$ tok "fragment" + <*> name + <*> typeCondition + <*> 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" -booleanValue :: Parser Bool -booleanValue = True <$ tok "true" - <|> False <$ tok "false" + -- TODO: Escape characters. Look at `jsstring_` in aeson package. + stringValue :: Parser Text + stringValue = quotes (takeWhile (/= '"')) --- 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 --- Notice it can be empty -listValue :: Parser ListValue -listValue = ListValue <$> brackets (many value) + listValue :: Parser [Value] + listValue = brackets $ many1 value --- Notice it can be empty -objectValue :: Parser ObjectValue -objectValue = ObjectValue <$> braces (many objectField) + 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!" + <$ tok "@" + <*> name + <*> 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 == ',' diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs index b8668d9..2198362 100644 --- a/Data/GraphQL/Schema.hs +++ b/Data/GraphQL/Schema.hs @@ -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,18 +48,16 @@ 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 + [] -> resolvs + _ -> empty -- | 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 diff --git a/graphql.cabal b/graphql.cabal index d330abd..0fec483 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -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, diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index ff79686..29c123e 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -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 diff --git a/tests/tasty.hs b/tests/tasty.hs index fa9bedf..aa8da50 100644 --- a/tests/tasty.hs +++ b/tests/tasty.hs @@ -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