From 5390c4ca1e7e6bcf36dbe5e773c1355dd4b65939 Mon Sep 17 00:00:00 2001 From: Danny Navarro Date: Sat, 28 Jan 2017 14:15:14 -0300 Subject: 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/Encoder.hs | 75 ++++++++++++++++++++++++++----------------------- 1 file changed, 40 insertions(+), 35 deletions(-) (limited to 'Data/GraphQL/Encoder.hs') 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 - -node :: Node -> Text -node (Node name vds ds ss) = +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 :: 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 -- cgit v1.2.3