Polish printer code

- Add printing combinators to make code more readable.
- Optimize printing for encoding. Pretty printing will be in a different
  module.

1 files changed, 62 insertions, 57 deletions

diff --git a/Data/GraphQL/Printer.hs b/Data/GraphQL/Printer.hs
index a8ce156..7b222b6 100644
--- a/Data/GraphQL/Printer.hs
+++ b/Data/GraphQL/Printer.hs
@@ -4,17 +4,14 @@ module Data.GraphQL.Printer where
 import Prelude hiding (unwords)
 import Data.Monoid ((<>))
 
-import Data.Text (Text, intercalate, pack, unwords)
+import Data.Text (Text, cons, intercalate, pack, snoc)
 
 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
+document (Document defs) = mconcat $ definition <$> defs
 
 definition :: Definition -> Text
 definition (DefinitionOperation x) = operationDefinition x
@@ -29,25 +26,24 @@ node :: Node -> Text
 node (Node name vds ds ss) =
        name
     <> optempty variableDefinitions vds
-    <> optempty (("\SP" <>) . directives) ds
-    <> "\SP"
+    <> optempty directives ds
     <> selectionSet ss
 
 variableDefinitions :: [VariableDefinition] -> Text
-variableDefinitions = parens . intercalate ", " . fmap variableDefinition
+variableDefinitions = parensCommas variableDefinition
 
 variableDefinition :: VariableDefinition -> Text
 variableDefinition (VariableDefinition var ty dv) =
-    variable var <> ": " <> type_ ty <> maybe mempty defaultValue dv
+    variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv
 
 defaultValue :: DefaultValue -> Text
-defaultValue val = "= " <> value val
+defaultValue val = "=" <> value val
 
 variable :: Variable -> Text
 variable (Variable name) = "$" <> name
 
 selectionSet :: SelectionSet -> Text
-selectionSet = block . fmap selection
+selectionSet = bracesCommas selection
 
 selection :: Selection -> Text
 selection (SelectionField          x) = field x
@@ -56,35 +52,35 @@ selection (SelectionFragmentSpread x) = fragmentSpread x
 
 field :: Field -> Text
 field (Field alias name args ds ss) =
-       optempty (<> ": ") alias
+       optempty (cons ':') alias
     <> name
     <> optempty arguments args
-    <> optempty (("\SP" <>) . directives) ds
-    <> optempty (("\SP" <>) . selectionSet) ss
+    <> optempty directives ds
+    <> optempty selectionSet ss
 
 arguments :: [Argument] -> Text
-arguments = parens . intercalate ", " . fmap argument
+arguments = parensCommas argument
 
 argument :: Argument -> Text
-argument (Argument name v) = name <> ": " <> value v
+argument (Argument name v) = name <> ":" <> value v
 
 -- * Fragments
 
 fragmentSpread :: FragmentSpread -> Text
 fragmentSpread (FragmentSpread name ds) =
-    "..." <> name <> optempty (spaces . directives) ds
+    "..." <> name <> optempty directives ds
 
 inlineFragment :: InlineFragment -> Text
 inlineFragment (InlineFragment (NamedType tc) ds ss) =
-    "... on" <> tc
-             <> optempty (("\SP" <>) . directives) ds
-             <> optempty (("\SP" <>) . selectionSet) ss
+    "... on " <> tc
+              <> optempty directives ds
+              <> optempty selectionSet ss
 
 fragmentDefinition :: FragmentDefinition -> Text
 fragmentDefinition (FragmentDefinition name (NamedType tc) ds ss) =
     "fragment " <> name <> " on " <> tc
-                <> optempty (("\SP" <>) . directives) ds
-                <> (("\SP" <>) . selectionSet) ss
+                <> optempty directives ds
+                <> selectionSet ss
 
 -- * Values
 
@@ -109,18 +105,18 @@ stringValue :: StringValue -> Text
 stringValue (StringValue x) = x
 
 listValue :: ListValue -> Text
-listValue (ListValue vs) = brackets . intercalate ", " $ value <$> vs
+listValue (ListValue vs) = bracketsCommas value vs
 
 objectValue :: ObjectValue -> Text
-objectValue (ObjectValue ofs) = block $ objectField <$> ofs
+objectValue (ObjectValue ofs) = bracesCommas objectField ofs
 
 objectField :: ObjectField -> Text
-objectField (ObjectField name v) = name <> ": " <> value v
+objectField (ObjectField name v) = name <> ":" <> value v
 
--- * Directives 
+-- * Directives
 
 directives :: [Directive] -> Text
-directives = withSpaces directive
+directives = spaces directive
 
 directive :: Directive -> Text
 directive (Directive name args) = "@" <> name <> optempty arguments args
@@ -136,7 +132,7 @@ namedType :: NamedType -> Text
 namedType (NamedType name) = name
 
 listType :: ListType -> Text
-listType (ListType ty) = "[" <> type_ ty <> "]"
+listType (ListType ty) = brackets (type_ ty)
 
 nonNullType :: NonNullType -> Text
 nonNullType (NonNullTypeNamed (NamedType x)) = x <> "!"
@@ -154,41 +150,34 @@ typeDefinition (TypeDefinitionTypeExtension x) = typeExtensionDefinition x
 objectTypeDefinition :: ObjectTypeDefinition -> Text
 objectTypeDefinition (ObjectTypeDefinition name ifaces fds) =
     "type " <> name
-            <> optempty (("\SP" <>) . interfaces) ifaces
-            <> optempty (("\SP" <>) . fieldDefinitions) fds
+            <> optempty (spaced . interfaces) ifaces
+            <> optempty fieldDefinitions fds
 
 interfaces :: Interfaces -> Text
-interfaces = ("implements " <>) . unwords . fmap namedType
+interfaces = ("implements " <>) . spaces namedType
 
 fieldDefinitions :: [FieldDefinition] -> Text
-fieldDefinitions = block . fmap fieldDefinition
+fieldDefinitions = bracesCommas 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
+argumentsDefinition = parensCommas inputValueDefinition
 
 interfaceTypeDefinition :: InterfaceTypeDefinition -> Text
 interfaceTypeDefinition (InterfaceTypeDefinition name fds) =
-    "interface " <> name <> "\SP" <> fieldDefinitions fds
+    "interface " <> name <> fieldDefinitions fds
 
 unionTypeDefinition :: UnionTypeDefinition -> Text
 unionTypeDefinition (UnionTypeDefinition name ums) =
-    "union " <> name <> " = " <> unionMembers ums
+    "union " <> name <> "=" <> unionMembers ums
 
 unionMembers :: [NamedType] -> Text
-unionMembers = intercalate " | " . fmap namedType
+unionMembers = intercalate "|" . fmap namedType
 
 scalarTypeDefinition :: ScalarTypeDefinition -> Text
 scalarTypeDefinition (ScalarTypeDefinition name) = "scalar " <> name
@@ -196,14 +185,21 @@ scalarTypeDefinition (ScalarTypeDefinition name) = "scalar " <> name
 enumTypeDefinition :: EnumTypeDefinition -> Text
 enumTypeDefinition (EnumTypeDefinition name evds) =
     "enum " <> name
-            <> block (enumValueDefinition <$> evds)
+            <> bracesCommas enumValueDefinition evds
 
 enumValueDefinition :: EnumValueDefinition -> Text
 enumValueDefinition (EnumValueDefinition name) = name
 
 inputObjectTypeDefinition :: InputObjectTypeDefinition -> Text
 inputObjectTypeDefinition (InputObjectTypeDefinition name ivds) =
-    "input " <> name <> "\SP" <> inputValueDefinitions ivds
+    "input " <> name <> inputValueDefinitions ivds
+
+inputValueDefinitions :: [InputValueDefinition] -> Text
+inputValueDefinitions = bracesCommas inputValueDefinition
+
+inputValueDefinition :: InputValueDefinition -> Text
+inputValueDefinition (InputValueDefinition name ty dv) =
+    name <> ":" <> type_ ty <> maybe mempty defaultValue dv
 
 typeExtensionDefinition :: TypeExtensionDefinition -> Text
 typeExtensionDefinition (TypeExtensionDefinition otd) =
@@ -211,23 +207,32 @@ typeExtensionDefinition (TypeExtensionDefinition otd) =
 
 -- * Internal
 
-spaces :: Text -> Text
-spaces txt = "\SP" <> txt <> "\SP"
+spaced :: Text -> Text
+spaced = cons '\SP'
+
+between :: Char -> Char -> Text -> Text
+between open close = cons open . (`snoc` close)
 
 parens :: Text -> Text
-parens txt = "(" <> txt <> ")"
+parens = between '(' ')'
 
 brackets :: Text -> Text
-brackets txt = "[" <> txt <> "]"
+brackets = between '[' ']'
 
-withSpaces :: (a -> Text) -> [a] -> Text
-withSpaces f = intercalate "\SP" . fmap f
+braces :: Text -> Text
+braces = between '{' '}'
 
-withCommas :: (a -> Text) -> [a] -> Text
-withCommas f = intercalate ", " . fmap f
+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
-
-block :: [Text] -> Text
-block txts = "{\n" <> intercalate "  \n" txts <> "\n}"