Initial implementation of GraphQL pretty printer

This just typechecks. It needs to be cleaned and tested. Tests have been
deactivated.
This commit is contained in:
Danny Navarro 2015-09-21 18:26:22 +02:00
parent 3d97b3e2ff
commit e74ee640a8
2 changed files with 248 additions and 14 deletions

233
Data/GraphQL/Printer.hs Normal file
View File

@ -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}"

View File

@ -24,24 +24,25 @@ library
ghc-options: -Wall ghc-options: -Wall
exposed-modules: Data.GraphQL.AST exposed-modules: Data.GraphQL.AST
Data.GraphQL.Parser Data.GraphQL.Parser
Data.GraphQL.Printer
build-depends: base >= 4.7 && < 5, build-depends: base >= 4.7 && < 5,
text >=0.11.3.1, text >=0.11.3.1,
attoparsec >=0.10.4.0 attoparsec >=0.10.4.0
test-suite golden -- test-suite golden
default-language: Haskell2010 -- default-language: Haskell2010
type: exitcode-stdio-1.0 -- type: exitcode-stdio-1.0
hs-source-dirs: tests -- hs-source-dirs: tests
main-is: golden.hs -- main-is: golden.hs
ghc-options: -Wall -- ghc-options: -Wall
other-modules: Paths_graphql -- other-modules: Paths_graphql
build-depends: base >= 4.6 && <5, -- build-depends: base >= 4.6 && <5,
bytestring, -- bytestring,
text, -- text,
attoparsec, -- attoparsec,
tasty >=0.10, -- tasty >=0.10,
tasty-golden, -- tasty-golden,
graphql -- graphql
source-repository head source-repository head
type: git type: git