Initial implementation of GraphQL pretty printer

This just typechecks. It needs to be cleaned and tested. Tests have been
deactivated.

2 files changed, 248 insertions, 14 deletions

diff --git a/Data/GraphQL/Printer.hs b/Data/GraphQL/Printer.hs
new file mode 100644
index 0000000..a8ce156
--- /dev/null
+++ b/Data/GraphQL/Printer.hs
@@ -0,0 +1,233 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Data.GraphQL.Printer where
+
+import Prelude hiding (unwords)
+import Data.Monoid ((<>))
+
+import Data.Text (Text, intercalate, pack, unwords)
+
+import Data.GraphQL.AST
+
+-- Uniplate could avoid boilerplate, but is it worth bringing the
+-- extra dependency?
+
+-- * Document
+
+document :: Document -> Text
+document (Document defs) = intercalate "\n\n" $ definition <$> defs
+
+definition :: Definition -> Text
+definition (DefinitionOperation x) = operationDefinition x
+definition (DefinitionFragment  x) = fragmentDefinition x
+definition (DefinitionType      x) = typeDefinition 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) =
+       name
+    <> optempty variableDefinitions vds
+    <> optempty (("\SP" <>) . directives) ds
+    <> "\SP"
+    <> selectionSet ss
+
+variableDefinitions :: [VariableDefinition] -> Text
+variableDefinitions = parens . intercalate ", " . fmap 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 (Variable name) = "$" <> name
+
+selectionSet :: SelectionSet -> Text
+selectionSet = block . fmap 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 ds ss) =
+       optempty (<> ": ") alias
+    <> name
+    <> optempty arguments args
+    <> optempty (("\SP" <>) . directives) ds
+    <> optempty (("\SP" <>) . selectionSet) ss
+
+arguments :: [Argument] -> Text
+arguments = parens . intercalate ", " . fmap argument
+
+argument :: Argument -> Text
+argument (Argument name v) = name <> ": " <> value v
+
+-- * Fragments
+
+fragmentSpread :: FragmentSpread -> Text
+fragmentSpread (FragmentSpread name ds) =
+    "..." <> name <> optempty (spaces . directives) ds
+
+inlineFragment :: InlineFragment -> Text
+inlineFragment (InlineFragment (NamedType tc) ds ss) =
+    "... on" <> tc
+             <> optempty (("\SP" <>) . directives) ds
+             <> optempty (("\SP" <>) . selectionSet) ss
+
+fragmentDefinition :: FragmentDefinition -> Text
+fragmentDefinition (FragmentDefinition name (NamedType tc) ds ss) =
+    "fragment " <> name <> " on " <> tc
+                <> optempty (("\SP" <>) . directives) ds
+                <> (("\SP" <>) . selectionSet) ss
+
+-- * Values
+
+value :: Value -> Text
+value (ValueVariable x) = variable x
+-- TODO: This will be replaced with `decimal` Buidler
+value (ValueInt      x) = pack $ show x
+-- TODO: This will be replaced with `decimal` Buidler
+value (ValueFloat    x) = pack $ show x
+value (ValueBoolean  x) = booleanValue x
+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 :: StringValue -> Text
+stringValue (StringValue x) = x
+
+listValue :: ListValue -> Text
+listValue (ListValue vs) = brackets . intercalate ", " $ value <$> vs
+
+objectValue :: ObjectValue -> Text
+objectValue (ObjectValue ofs) = block $ objectField <$> ofs
+
+objectField :: ObjectField -> Text
+objectField (ObjectField name v) = name <> ": " <> value v
+
+-- * Directives 
+
+directives :: [Directive] -> Text
+directives = withSpaces directive
+
+directive :: Directive -> Text
+directive (Directive name args) = "@" <> name <> optempty arguments args
+
+-- * Type Reference
+
+type_ :: Type -> Text
+type_ (TypeNamed (NamedType 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) = "[" <> type_ ty <> "]"
+
+nonNullType :: NonNullType -> Text
+nonNullType (NonNullTypeNamed (NamedType x)) = x <> "!"
+nonNullType (NonNullTypeList  x) = listType x <> "!"
+
+typeDefinition :: TypeDefinition -> Text
+typeDefinition (TypeDefinitionObject        x) = objectTypeDefinition x
+typeDefinition (TypeDefinitionInterface     x) = interfaceTypeDefinition x
+typeDefinition (TypeDefinitionUnion         x) = unionTypeDefinition x
+typeDefinition (TypeDefinitionScalar        x) = scalarTypeDefinition x
+typeDefinition (TypeDefinitionEnum          x) = enumTypeDefinition x
+typeDefinition (TypeDefinitionInputObject   x) = inputObjectTypeDefinition x
+typeDefinition (TypeDefinitionTypeExtension x) = typeExtensionDefinition x
+
+objectTypeDefinition :: ObjectTypeDefinition -> Text
+objectTypeDefinition (ObjectTypeDefinition name ifaces fds) =
+    "type " <> name
+            <> optempty (("\SP" <>) . interfaces) ifaces
+            <> optempty (("\SP" <>) . fieldDefinitions) fds
+
+interfaces :: Interfaces -> Text
+interfaces = ("implements " <>) . unwords . fmap namedType
+
+fieldDefinitions :: [FieldDefinition] -> Text
+fieldDefinitions = block . fmap fieldDefinition
+
+fieldDefinition :: FieldDefinition -> Text
+fieldDefinition (FieldDefinition name args ty) =
+    name <> optempty argumentsDefinition args
+         <> ": "
+         <> type_ ty
+
+argumentsDefinition :: ArgumentsDefinition -> Text
+argumentsDefinition = parens . intercalate ", " . fmap inputValueDefinition
+
+inputValueDefinitions :: [InputValueDefinition] -> Text
+inputValueDefinitions = block . fmap inputValueDefinition
+
+inputValueDefinition :: InputValueDefinition -> Text
+inputValueDefinition (InputValueDefinition name ty dv) =
+    name <> ": " <> type_ ty <> maybe mempty (("\SP" <>) . defaultValue) dv
+
+interfaceTypeDefinition :: InterfaceTypeDefinition -> Text
+interfaceTypeDefinition (InterfaceTypeDefinition name fds) =
+    "interface " <> name <> "\SP" <> fieldDefinitions fds
+
+unionTypeDefinition :: UnionTypeDefinition -> Text
+unionTypeDefinition (UnionTypeDefinition name ums) =
+    "union " <> name <> " = " <> unionMembers ums
+
+unionMembers :: [NamedType] -> Text
+unionMembers = intercalate " | " . fmap namedType
+
+scalarTypeDefinition :: ScalarTypeDefinition -> Text
+scalarTypeDefinition (ScalarTypeDefinition name) = "scalar " <> name
+
+enumTypeDefinition :: EnumTypeDefinition -> Text
+enumTypeDefinition (EnumTypeDefinition name evds) =
+    "enum " <> name
+            <> block (enumValueDefinition <$> evds)
+
+enumValueDefinition :: EnumValueDefinition -> Text
+enumValueDefinition (EnumValueDefinition name) = name
+
+inputObjectTypeDefinition :: InputObjectTypeDefinition -> Text
+inputObjectTypeDefinition (InputObjectTypeDefinition name ivds) =
+    "input " <> name <> "\SP" <> inputValueDefinitions ivds
+
+typeExtensionDefinition :: TypeExtensionDefinition -> Text
+typeExtensionDefinition (TypeExtensionDefinition otd) =
+    "extend " <> objectTypeDefinition otd
+
+-- * Internal
+
+spaces :: Text -> Text
+spaces txt = "\SP" <> txt <> "\SP"
+
+parens :: Text -> Text
+parens txt = "(" <> txt <> ")"
+
+brackets :: Text -> Text
+brackets txt = "[" <> txt <> "]"
+
+withSpaces :: (a -> Text) -> [a] -> Text
+withSpaces f = intercalate "\SP" . fmap f
+
+withCommas :: (a -> Text) -> [a] -> Text
+withCommas f = 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
+
+block :: [Text] -> Text
+block txts = "{\n" <> intercalate "  \n" txts <> "\n}"
diff --git a/graphql.cabal b/graphql.cabal
index 18684b1..7b47bd9 100644
--- a/graphql.cabal
+++ b/graphql.cabal
@@ -24,24 +24,25 @@ library
   ghc-options:         -Wall
   exposed-modules:     Data.GraphQL.AST
                        Data.GraphQL.Parser
+                       Data.GraphQL.Printer
   build-depends:       base >= 4.7 && < 5,
                        text >=0.11.3.1,
                        attoparsec >=0.10.4.0
 
-test-suite golden
-  default-language:    Haskell2010
-  type:                exitcode-stdio-1.0
-  hs-source-dirs:      tests
-  main-is:             golden.hs
-  ghc-options:         -Wall
-  other-modules:       Paths_graphql
-  build-depends:       base >= 4.6 && <5,
-                       bytestring,
-                       text,
-                       attoparsec,
-                       tasty >=0.10,
-                       tasty-golden,
-                       graphql
+-- test-suite golden
+--   default-language:    Haskell2010
+--   type:                exitcode-stdio-1.0
+--   hs-source-dirs:      tests
+--   main-is:             golden.hs
+--   ghc-options:         -Wall
+--   other-modules:       Paths_graphql
+--   build-depends:       base >= 4.6 && <5,
+--                        bytestring,
+--                        text,
+--                        attoparsec,
+--                        tasty >=0.10,
+--                        tasty-golden,
+--                        graphql
 
 source-repository head
   type:     git