1 files changed, 179 insertions, 0 deletions
diff --git a/src/Data/GraphQL/Encoder.hs b/src/Data/GraphQL/Encoder.hs
new file mode 100644
index 0000000..924bdea
--- /dev/null
+++ b/src/Data/GraphQL/Encoder.hs
@@ -0,0 +1,179 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | 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)
+
+import Data.GraphQL.AST
+
+-- * Document
+
+document :: Document -> Text
+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 (OperationSelectionSet sels) = selectionSet sels
+operationDefinition (OperationDefinition Query    name vars dirs sels) =
+  "query " <> node (fold name) vars dirs sels
+operationDefinition (OperationDefinition Mutation name vars dirs sels) =
+  "mutation " <> node (fold name) vars dirs sels
+
+node :: Name -> VariableDefinitions -> Directives -> SelectionSet -> Text
+node name vars dirs sels =
+       name
+    <> optempty variableDefinitions vars
+    <> optempty directives dirs
+    <> selectionSet sels
+
+variableDefinitions :: [VariableDefinition] -> Text
+variableDefinitions = parensCommas variableDefinition
+
+variableDefinition :: VariableDefinition -> Text
+variableDefinition (VariableDefinition var ty dv) =
+    variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv
+
+defaultValue :: DefaultValue -> Text
+defaultValue val = "=" <> value val
+
+variable :: Variable -> Text
+variable var = "$" <> var
+
+selectionSet :: SelectionSet -> Text
+selectionSet = bracesCommas selection . NonEmpty.toList
+
+selectionSetOpt :: SelectionSetOpt -> Text
+selectionSetOpt = bracesCommas selection
+
+selection :: Selection -> Text
+selection (SelectionField          x) = field x
+selection (SelectionInlineFragment x) = inlineFragment x
+selection (SelectionFragmentSpread x) = fragmentSpread x
+
+field :: Field -> Text
+field (Field alias name args dirs selso) =
+       optempty (`snoc` ':') (fold alias)
+    <> name
+    <> optempty arguments args
+    <> optempty directives dirs
+    <> optempty selectionSetOpt selso
+
+arguments :: [Argument] -> Text
+arguments = parensCommas argument
+
+argument :: Argument -> Text
+argument (Argument name v) = name <> ":" <> value v
+
+-- * Fragments
+
+fragmentSpread :: FragmentSpread -> Text
+fragmentSpread (FragmentSpread name ds) =
+    "..." <> name <> optempty directives ds
+
+inlineFragment :: InlineFragment -> Text
+inlineFragment (InlineFragment tc dirs sels) =
+    "... on " <> fold tc
+              <> directives dirs
+              <> selectionSet sels
+
+fragmentDefinition :: FragmentDefinition -> Text
+fragmentDefinition (FragmentDefinition name tc dirs sels) =
+    "fragment " <> name <> " on " <> tc
+                <> optempty directives dirs
+                <> selectionSet sels
+
+-- * Values
+
+value :: Value -> Text
+value (ValueVariable x) = variable x
+-- TODO: This will be replaced with `decimal` Builder
+value (ValueInt      x) = pack $ show x
+-- 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
+value (ValueObject   x) = objectValue x
+
+booleanValue :: Bool -> Text
+booleanValue True  = "true"
+booleanValue False = "false"
+
+-- TODO: Escape characters
+stringValue :: Text -> Text
+stringValue = quotes
+
+listValue :: ListValue -> Text
+listValue = bracketsCommas value
+
+objectValue :: ObjectValue -> Text
+objectValue = bracesCommas objectField
+
+objectField :: ObjectField -> Text
+objectField (ObjectField name v) = name <> ":" <> value v
+
+-- * Directives
+
+directives :: [Directive] -> Text
+directives = spaces directive
+
+directive :: Directive -> Text
+directive (Directive name args) = "@" <> name <> optempty arguments args
+
+-- * Type Reference
+
+type_ :: Type -> Text
+type_ (TypeNamed   x) = x
+type_ (TypeList    x) = listType x
+type_ (TypeNonNull x) = nonNullType x
+
+listType :: Type -> Text
+listType x = brackets (type_ x)
+
+nonNullType :: NonNullType -> Text
+nonNullType (NonNullTypeNamed x) = x <> "!"
+nonNullType (NonNullTypeList  x) = listType x <> "!"
+
+-- * Internal
+
+spaced :: Text -> Text
+spaced = cons '\SP'
+
+between :: Char -> Char -> Text -> Text
+between open close = cons open . (`snoc` close)
+
+parens :: Text -> Text
+parens = between '(' ')'
+
+brackets :: Text -> Text
+brackets = between '[' ']'
+
+braces :: Text -> Text
+braces = between '{' '}'
+
+quotes :: Text -> Text
+quotes = between '"' '"'
+
+spaces :: (a -> Text) -> [a] -> Text
+spaces f = intercalate "\SP" . fmap f
+
+parensCommas :: (a -> Text) -> [a] -> Text
+parensCommas f = parens . intercalate "," . fmap f
+
+bracketsCommas :: (a -> Text) -> [a] -> Text
+bracketsCommas f = brackets . intercalate "," . fmap f
+
+bracesCommas :: (a -> Text) -> [a] -> Text
+bracesCommas f = braces . intercalate "," . fmap f
+
+optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b
+optempty f xs = if xs == mempty then mempty else f xs