From af42e5577cf9dcb2c55a0d76a2e479880150e7f1 Mon Sep 17 00:00:00 2001 From: Danny Navarro Date: Tue, 22 Sep 2015 14:23:18 +0200 Subject: Rename `Data.GraphQL.Printer` -> `Data.GraphQL.Encoder` --- Data/GraphQL/Encoder.hs | 246 ++++++++++++++++++++++++++++++++++++++++++++++++ Data/GraphQL/Printer.hs | 246 ------------------------------------------------ graphql.cabal | 2 +- tests/tasty.hs | 4 +- 4 files changed, 249 insertions(+), 249 deletions(-) create mode 100644 Data/GraphQL/Encoder.hs delete mode 100644 Data/GraphQL/Printer.hs diff --git a/Data/GraphQL/Encoder.hs b/Data/GraphQL/Encoder.hs new file mode 100644 index 0000000..9eed849 --- /dev/null +++ b/Data/GraphQL/Encoder.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Data.GraphQL.Encoder where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +import Data.Monoid (Monoid, mconcat, mempty) +#endif +import Data.Monoid ((<>)) + +import Data.Text (Text, cons, intercalate, pack, snoc) + +import Data.GraphQL.AST + +-- * Document + +-- TODO: Use query shorthand +document :: Document -> Text +document (Document defs) = (`snoc` '\n') . mconcat $ 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 directives ds + <> selectionSet ss + +variableDefinitions :: [VariableDefinition] -> Text +variableDefinitions = parensCommas 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 = bracesCommas 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 (`snoc` ':') alias + <> name + <> optempty arguments args + <> optempty directives ds + <> optempty selectionSet ss + +arguments :: [Argument] -> Text +arguments = parensCommas argument + +argument :: Argument -> Text +argument (Argument name v) = name <> ":" <> value v + +-- * Fragments + +fragmentSpread :: FragmentSpread -> Text +fragmentSpread (FragmentSpread name ds) = + "..." <> name <> optempty directives ds + +inlineFragment :: InlineFragment -> Text +inlineFragment (InlineFragment (NamedType tc) ds ss) = + "... on " <> tc + <> optempty directives ds + <> optempty selectionSet ss + +fragmentDefinition :: FragmentDefinition -> Text +fragmentDefinition (FragmentDefinition name (NamedType tc) ds ss) = + "fragment " <> name <> " on " <> tc + <> optempty directives ds + <> 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 v) = quotes v + +listValue :: ListValue -> Text +listValue (ListValue vs) = bracketsCommas value vs + +objectValue :: ObjectValue -> Text +objectValue (ObjectValue ofs) = bracesCommas objectField ofs + +objectField :: ObjectField -> Text +objectField (ObjectField name v) = name <> ":" <> value v + +-- * Directives + +directives :: [Directive] -> Text +directives = spaces 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) = brackets (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 (spaced . interfaces) ifaces + <> optempty fieldDefinitions fds + +interfaces :: Interfaces -> Text +interfaces = ("implements " <>) . spaces namedType + +fieldDefinitions :: [FieldDefinition] -> Text +fieldDefinitions = bracesCommas fieldDefinition + +fieldDefinition :: FieldDefinition -> Text +fieldDefinition (FieldDefinition name args ty) = + name <> optempty argumentsDefinition args + <> ":" + <> type_ ty + +argumentsDefinition :: ArgumentsDefinition -> Text +argumentsDefinition = parensCommas inputValueDefinition + +interfaceTypeDefinition :: InterfaceTypeDefinition -> Text +interfaceTypeDefinition (InterfaceTypeDefinition name fds) = + "interface " <> name <> 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 + <> bracesCommas enumValueDefinition evds + +enumValueDefinition :: EnumValueDefinition -> Text +enumValueDefinition (EnumValueDefinition name) = name + +inputObjectTypeDefinition :: InputObjectTypeDefinition -> Text +inputObjectTypeDefinition (InputObjectTypeDefinition name 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) = + "extend " <> objectTypeDefinition otd + +-- * Internal + +spaced :: Text -> Text +spaced = cons '\SP' + +between :: Char -> Char -> Text -> Text +between open close = cons open . (`snoc` close) + +parens :: Text -> Text +parens = between '(' ')' + +brackets :: Text -> Text +brackets = between '[' ']' + +braces :: Text -> Text +braces = between '{' '}' + +quotes :: Text -> Text +quotes = between '"' '"' + +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 diff --git a/Data/GraphQL/Printer.hs b/Data/GraphQL/Printer.hs deleted file mode 100644 index dd0e5de..0000000 --- a/Data/GraphQL/Printer.hs +++ /dev/null @@ -1,246 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -module Data.GraphQL.Printer where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -import Data.Monoid (Monoid, mconcat, mempty) -#endif -import Data.Monoid ((<>)) - -import Data.Text (Text, cons, intercalate, pack, snoc) - -import Data.GraphQL.AST - --- * Document - --- TODO: Use query shorthand -document :: Document -> Text -document (Document defs) = (`snoc` '\n') . mconcat $ 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 directives ds - <> selectionSet ss - -variableDefinitions :: [VariableDefinition] -> Text -variableDefinitions = parensCommas 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 = bracesCommas 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 (`snoc` ':') alias - <> name - <> optempty arguments args - <> optempty directives ds - <> optempty selectionSet ss - -arguments :: [Argument] -> Text -arguments = parensCommas argument - -argument :: Argument -> Text -argument (Argument name v) = name <> ":" <> value v - --- * Fragments - -fragmentSpread :: FragmentSpread -> Text -fragmentSpread (FragmentSpread name ds) = - "..." <> name <> optempty directives ds - -inlineFragment :: InlineFragment -> Text -inlineFragment (InlineFragment (NamedType tc) ds ss) = - "... on " <> tc - <> optempty directives ds - <> optempty selectionSet ss - -fragmentDefinition :: FragmentDefinition -> Text -fragmentDefinition (FragmentDefinition name (NamedType tc) ds ss) = - "fragment " <> name <> " on " <> tc - <> optempty directives ds - <> 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 v) = quotes v - -listValue :: ListValue -> Text -listValue (ListValue vs) = bracketsCommas value vs - -objectValue :: ObjectValue -> Text -objectValue (ObjectValue ofs) = bracesCommas objectField ofs - -objectField :: ObjectField -> Text -objectField (ObjectField name v) = name <> ":" <> value v - --- * Directives - -directives :: [Directive] -> Text -directives = spaces 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) = brackets (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 (spaced . interfaces) ifaces - <> optempty fieldDefinitions fds - -interfaces :: Interfaces -> Text -interfaces = ("implements " <>) . spaces namedType - -fieldDefinitions :: [FieldDefinition] -> Text -fieldDefinitions = bracesCommas fieldDefinition - -fieldDefinition :: FieldDefinition -> Text -fieldDefinition (FieldDefinition name args ty) = - name <> optempty argumentsDefinition args - <> ":" - <> type_ ty - -argumentsDefinition :: ArgumentsDefinition -> Text -argumentsDefinition = parensCommas inputValueDefinition - -interfaceTypeDefinition :: InterfaceTypeDefinition -> Text -interfaceTypeDefinition (InterfaceTypeDefinition name fds) = - "interface " <> name <> 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 - <> bracesCommas enumValueDefinition evds - -enumValueDefinition :: EnumValueDefinition -> Text -enumValueDefinition (EnumValueDefinition name) = name - -inputObjectTypeDefinition :: InputObjectTypeDefinition -> Text -inputObjectTypeDefinition (InputObjectTypeDefinition name 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) = - "extend " <> objectTypeDefinition otd - --- * Internal - -spaced :: Text -> Text -spaced = cons '\SP' - -between :: Char -> Char -> Text -> Text -between open close = cons open . (`snoc` close) - -parens :: Text -> Text -parens = between '(' ')' - -brackets :: Text -> Text -brackets = between '[' ']' - -braces :: Text -> Text -braces = between '{' '}' - -quotes :: Text -> Text -quotes = between '"' '"' - -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 diff --git a/graphql.cabal b/graphql.cabal index a9e7f66..3574583 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -23,8 +23,8 @@ library default-language: Haskell2010 ghc-options: -Wall exposed-modules: Data.GraphQL.AST + Data.GraphQL.Encoder Data.GraphQL.Parser - Data.GraphQL.Printer build-depends: base >=4.7 && < 5, text >=0.11.3.1, attoparsec >=0.10.4.0 diff --git a/tests/tasty.hs b/tests/tasty.hs index 32bdd8d..a034a79 100644 --- a/tests/tasty.hs +++ b/tests/tasty.hs @@ -12,7 +12,7 @@ import Test.Tasty (defaultMain) import Test.Tasty.HUnit import qualified Data.GraphQL.Parser as Parser -import qualified Data.GraphQL.Printer as Printer +import qualified Data.GraphQL.Encoder as Encoder import Paths_graphql (getDataFileName) @@ -23,6 +23,6 @@ main = defaultMain =<< testCase "Kitchen Sink" expected = Text.readFile =<< getDataFileName "tests/data/kitchen-sink.min.graphql" - actual = either (error "Parsing error!") Printer.document + actual = either (error "Parsing error!") Encoder.document <$> parseOnly Parser.document <$> expected -- cgit v1.2.3