Polish printer code

- Add printing combinators to make code more readable.
- Optimize printing for encoding. Pretty printing will be in a different
  module.
This commit is contained in:
Danny Navarro 2015-09-22 10:45:14 +02:00
parent da97387042
commit 99b4d86702

View File

@ -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,12 +26,11 @@ 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) =
@ -47,7 +43,7 @@ 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,14 +52,14 @@ 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
@ -72,19 +68,19 @@ argument (Argument name v) = name <> ": " <> value v
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
<> 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,10 +105,10 @@ 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
@ -120,7 +116,7 @@ objectField (ObjectField name v) = name <> ": " <> value v
-- * 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,14 +150,14 @@ 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) =
@ -170,18 +166,11 @@ fieldDefinition (FieldDefinition name args ty) =
<> 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) =
@ -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}"