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 Prelude hiding (unwords)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Data.Text (Text, intercalate, pack, unwords) import Data.Text (Text, cons, intercalate, pack, snoc)
import Data.GraphQL.AST import Data.GraphQL.AST
-- Uniplate could avoid boilerplate, but is it worth bringing the
-- extra dependency?
-- * Document -- * Document
document :: Document -> Text document :: Document -> Text
document (Document defs) = intercalate "\n\n" $ definition <$> defs document (Document defs) = mconcat $ definition <$> defs
definition :: Definition -> Text definition :: Definition -> Text
definition (DefinitionOperation x) = operationDefinition x definition (DefinitionOperation x) = operationDefinition x
@ -29,12 +26,11 @@ node :: Node -> Text
node (Node name vds ds ss) = node (Node name vds ds ss) =
name name
<> optempty variableDefinitions vds <> optempty variableDefinitions vds
<> optempty (("\SP" <>) . directives) ds <> optempty directives ds
<> "\SP"
<> selectionSet ss <> selectionSet ss
variableDefinitions :: [VariableDefinition] -> Text variableDefinitions :: [VariableDefinition] -> Text
variableDefinitions = parens . intercalate ", " . fmap variableDefinition variableDefinitions = parensCommas variableDefinition
variableDefinition :: VariableDefinition -> Text variableDefinition :: VariableDefinition -> Text
variableDefinition (VariableDefinition var ty dv) = variableDefinition (VariableDefinition var ty dv) =
@ -47,7 +43,7 @@ variable :: Variable -> Text
variable (Variable name) = "$" <> name variable (Variable name) = "$" <> name
selectionSet :: SelectionSet -> Text selectionSet :: SelectionSet -> Text
selectionSet = block . fmap selection selectionSet = bracesCommas selection
selection :: Selection -> Text selection :: Selection -> Text
selection (SelectionField x) = field x selection (SelectionField x) = field x
@ -56,14 +52,14 @@ selection (SelectionFragmentSpread x) = fragmentSpread x
field :: Field -> Text field :: Field -> Text
field (Field alias name args ds ss) = field (Field alias name args ds ss) =
optempty (<> ": ") alias optempty (cons ':') alias
<> name <> name
<> optempty arguments args <> optempty arguments args
<> optempty (("\SP" <>) . directives) ds <> optempty directives ds
<> optempty (("\SP" <>) . selectionSet) ss <> optempty selectionSet ss
arguments :: [Argument] -> Text arguments :: [Argument] -> Text
arguments = parens . intercalate ", " . fmap argument arguments = parensCommas argument
argument :: Argument -> Text argument :: Argument -> Text
argument (Argument name v) = name <> ":" <> value v argument (Argument name v) = name <> ":" <> value v
@ -72,19 +68,19 @@ argument (Argument name v) = name <> ": " <> value v
fragmentSpread :: FragmentSpread -> Text fragmentSpread :: FragmentSpread -> Text
fragmentSpread (FragmentSpread name ds) = fragmentSpread (FragmentSpread name ds) =
"..." <> name <> optempty (spaces . directives) ds "..." <> name <> optempty directives ds
inlineFragment :: InlineFragment -> Text inlineFragment :: InlineFragment -> Text
inlineFragment (InlineFragment (NamedType tc) ds ss) = inlineFragment (InlineFragment (NamedType tc) ds ss) =
"... on " <> tc "... on " <> tc
<> optempty (("\SP" <>) . directives) ds <> optempty directives ds
<> optempty (("\SP" <>) . selectionSet) ss <> optempty selectionSet ss
fragmentDefinition :: FragmentDefinition -> Text fragmentDefinition :: FragmentDefinition -> Text
fragmentDefinition (FragmentDefinition name (NamedType tc) ds ss) = fragmentDefinition (FragmentDefinition name (NamedType tc) ds ss) =
"fragment " <> name <> " on " <> tc "fragment " <> name <> " on " <> tc
<> optempty (("\SP" <>) . directives) ds <> optempty directives ds
<> (("\SP" <>) . selectionSet) ss <> selectionSet ss
-- * Values -- * Values
@ -109,10 +105,10 @@ stringValue :: StringValue -> Text
stringValue (StringValue x) = x stringValue (StringValue x) = x
listValue :: ListValue -> Text listValue :: ListValue -> Text
listValue (ListValue vs) = brackets . intercalate ", " $ value <$> vs listValue (ListValue vs) = bracketsCommas value vs
objectValue :: ObjectValue -> Text objectValue :: ObjectValue -> Text
objectValue (ObjectValue ofs) = block $ objectField <$> ofs objectValue (ObjectValue ofs) = bracesCommas objectField ofs
objectField :: ObjectField -> Text objectField :: ObjectField -> Text
objectField (ObjectField name v) = name <> ":" <> value v objectField (ObjectField name v) = name <> ":" <> value v
@ -120,7 +116,7 @@ objectField (ObjectField name v) = name <> ": " <> value v
-- * Directives -- * Directives
directives :: [Directive] -> Text directives :: [Directive] -> Text
directives = withSpaces directive directives = spaces directive
directive :: Directive -> Text directive :: Directive -> Text
directive (Directive name args) = "@" <> name <> optempty arguments args directive (Directive name args) = "@" <> name <> optempty arguments args
@ -136,7 +132,7 @@ namedType :: NamedType -> Text
namedType (NamedType name) = name namedType (NamedType name) = name
listType :: ListType -> Text listType :: ListType -> Text
listType (ListType ty) = "[" <> type_ ty <> "]" listType (ListType ty) = brackets (type_ ty)
nonNullType :: NonNullType -> Text nonNullType :: NonNullType -> Text
nonNullType (NonNullTypeNamed (NamedType x)) = x <> "!" nonNullType (NonNullTypeNamed (NamedType x)) = x <> "!"
@ -154,14 +150,14 @@ typeDefinition (TypeDefinitionTypeExtension x) = typeExtensionDefinition x
objectTypeDefinition :: ObjectTypeDefinition -> Text objectTypeDefinition :: ObjectTypeDefinition -> Text
objectTypeDefinition (ObjectTypeDefinition name ifaces fds) = objectTypeDefinition (ObjectTypeDefinition name ifaces fds) =
"type " <> name "type " <> name
<> optempty (("\SP" <>) . interfaces) ifaces <> optempty (spaced . interfaces) ifaces
<> optempty (("\SP" <>) . fieldDefinitions) fds <> optempty fieldDefinitions fds
interfaces :: Interfaces -> Text interfaces :: Interfaces -> Text
interfaces = ("implements " <>) . unwords . fmap namedType interfaces = ("implements " <>) . spaces namedType
fieldDefinitions :: [FieldDefinition] -> Text fieldDefinitions :: [FieldDefinition] -> Text
fieldDefinitions = block . fmap fieldDefinition fieldDefinitions = bracesCommas fieldDefinition
fieldDefinition :: FieldDefinition -> Text fieldDefinition :: FieldDefinition -> Text
fieldDefinition (FieldDefinition name args ty) = fieldDefinition (FieldDefinition name args ty) =
@ -170,18 +166,11 @@ fieldDefinition (FieldDefinition name args ty) =
<> type_ ty <> type_ ty
argumentsDefinition :: ArgumentsDefinition -> Text argumentsDefinition :: ArgumentsDefinition -> Text
argumentsDefinition = parens . intercalate ", " . fmap inputValueDefinition argumentsDefinition = parensCommas 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 -> Text
interfaceTypeDefinition (InterfaceTypeDefinition name fds) = interfaceTypeDefinition (InterfaceTypeDefinition name fds) =
"interface " <> name <> "\SP" <> fieldDefinitions fds "interface " <> name <> fieldDefinitions fds
unionTypeDefinition :: UnionTypeDefinition -> Text unionTypeDefinition :: UnionTypeDefinition -> Text
unionTypeDefinition (UnionTypeDefinition name ums) = unionTypeDefinition (UnionTypeDefinition name ums) =
@ -196,14 +185,21 @@ scalarTypeDefinition (ScalarTypeDefinition name) = "scalar " <> name
enumTypeDefinition :: EnumTypeDefinition -> Text enumTypeDefinition :: EnumTypeDefinition -> Text
enumTypeDefinition (EnumTypeDefinition name evds) = enumTypeDefinition (EnumTypeDefinition name evds) =
"enum " <> name "enum " <> name
<> block (enumValueDefinition <$> evds) <> bracesCommas enumValueDefinition evds
enumValueDefinition :: EnumValueDefinition -> Text enumValueDefinition :: EnumValueDefinition -> Text
enumValueDefinition (EnumValueDefinition name) = name enumValueDefinition (EnumValueDefinition name) = name
inputObjectTypeDefinition :: InputObjectTypeDefinition -> Text inputObjectTypeDefinition :: InputObjectTypeDefinition -> Text
inputObjectTypeDefinition (InputObjectTypeDefinition name ivds) = 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 -> Text
typeExtensionDefinition (TypeExtensionDefinition otd) = typeExtensionDefinition (TypeExtensionDefinition otd) =
@ -211,23 +207,32 @@ typeExtensionDefinition (TypeExtensionDefinition otd) =
-- * Internal -- * Internal
spaces :: Text -> Text spaced :: Text -> Text
spaces txt = "\SP" <> txt <> "\SP" spaced = cons '\SP'
between :: Char -> Char -> Text -> Text
between open close = cons open . (`snoc` close)
parens :: Text -> Text parens :: Text -> Text
parens txt = "(" <> txt <> ")" parens = between '(' ')'
brackets :: Text -> Text brackets :: Text -> Text
brackets txt = "[" <> txt <> "]" brackets = between '[' ']'
withSpaces :: (a -> Text) -> [a] -> Text braces :: Text -> Text
withSpaces f = intercalate "\SP" . fmap f braces = between '{' '}'
withCommas :: (a -> Text) -> [a] -> Text spaces :: (a -> Text) -> [a] -> Text
withCommas f = intercalate ", " . fmap f 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 :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b
optempty f xs = if xs == mempty then mempty else f xs optempty f xs = if xs == mempty then mempty else f xs
block :: [Text] -> Text
block txts = "{\n" <> intercalate " \n" txts <> "\n}"