Version Bump

This also includes updates to CHANGELOG, TODO and README.

CHANGELOG.md

@@ -1,6 +1,20 @@
 # Change Log
 All notable changes to this project will be documented in this file.
 
+## [0.3] - 2015-09-22
+### Changed
+- Exact match numeric types to spec.
+- Names follow now the spec.
+- AST slightly different for better readability or easier parsing.
+- Replace golden test for test to validate parsing/encoding.
+
+### Added
+- Parsing errors in all cases where `Alternative` is used.
+- GraphQL encoder.
+
+### Fixed
+- Expect braces `inputValueDefinitions` instead of parens when parsing.
+
 ## [0.2.1] - 2015-09-16
 ### Fixed
 - Include data files for golden tests in Cabal package.
@@ -19,5 +33,6 @@ All notable changes to this project will be documented in this file.
 ### Added
 - Data types for the GraphQL language.
 
+[0.3]: https://github.com/jdnavarro/graphql-haskell/compare/v0.2.1...v0.3
 [0.2.1]: https://github.com/jdnavarro/graphql-haskell/compare/v0.2...v0.2.1
 [0.2]: https://github.com/jdnavarro/graphql-haskell/compare/v0.1...v0.2

Data/GraphQL/AST.hs

@@ -1,5 +1,6 @@
 module Data.GraphQL.AST where
 
+import Data.Int (Int32)
 import Data.Text (Text)
 
 -- * Name
@@ -15,12 +16,12 @@ data Definition = DefinitionOperation OperationDefinition
                 | DefinitionType      TypeDefinition
                   deriving (Eq,Show)
 
-data OperationDefinition =
+data OperationDefinition = Query    Node
-    Query        Name [VariableDefinition] [Directive] SelectionSet
+                         | Mutation Node
-  | Mutation     Name [VariableDefinition] [Directive] SelectionSet
+                           deriving (Eq,Show)
-  -- Not official yet
+
-  -- -- | Subscription Name [VariableDefinition] [Directive] SelectionSet
+data Node = Node Name [VariableDefinition] [Directive] SelectionSet
-    deriving (Eq,Show)
+            deriving (Eq,Show)
 
 data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
                           deriving (Eq,Show)
@@ -61,15 +62,18 @@ type TypeCondition = NamedType
 -- * Values
 
 data Value = ValueVariable Variable
-           | ValueInt Int -- TODO: Should this be `Integer`?
+           | ValueInt Int32
-           | ValueFloat Double -- TODO: Should this be `Scientific`?
+           -- GraphQL Float is double precison
+           | ValueFloat Double
            | ValueBoolean Bool
-           | ValueString Text
+           | ValueString StringValue
            | ValueEnum Name
            | ValueList ListValue
            | ValueObject ObjectValue
              deriving (Eq,Show)
 
+newtype StringValue = StringValue Text deriving (Eq,Show)
+
 newtype ListValue = ListValue [Value] deriving (Eq,Show)
 
 newtype ObjectValue = ObjectValue [ObjectField] deriving (Eq,Show)

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

Data/GraphQL/Parser.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE LambdaCase #-}
 module Data.GraphQL.Parser where
 
 import Prelude hiding (takeWhile)
@@ -11,8 +10,10 @@ import Data.Monoid (Monoid, mempty)
 #endif
 import Control.Applicative ((<|>), empty, many, optional)
 import Control.Monad (when)
-import Data.Char
+import Data.Char (isDigit, isSpace)
-import Data.Text (Text, pack)
+import Data.Foldable (traverse_)
+
+import Data.Text (Text, append)
 import Data.Attoparsec.Text
   ( Parser
   , (<?>)
@@ -20,25 +21,27 @@ import Data.Attoparsec.Text
   , decimal
   , double
   , endOfLine
+  , inClass
   , many1
   , manyTill
   , option
   , peekChar
-  , satisfy
   , sepBy1
   , signed
+  , takeWhile
+  , takeWhile1
   )
 
 import Data.GraphQL.AST
 
 -- * Name
 
--- XXX: Handle starting `_` and no number at the beginning:
--- https://facebook.github.io/graphql/#sec-Names
--- TODO: Use takeWhile1 instead for efficiency. With takeWhile1 there is no
--- parsing failure.
 name :: Parser Name
-name = tok $ pack <$> many1 (satisfy isAlphaNum)
+name = tok $ append <$> takeWhile1 isA_z
+                    <*> takeWhile ((||) <$> isDigit <*> isA_z)
+  where
+    -- `isAlpha` handles many more Unicode Chars
+    isA_z =  inClass $ '_' : ['A'..'Z'] ++ ['a'..'z']
 
 -- * Document
 
@@ -48,7 +51,8 @@ document = whiteSpace
     -- Try SelectionSet when no definition
     <|> (Document . pure
                   . DefinitionOperation
-                  . Query mempty empty empty
+                  . Query
+                  . Node mempty empty empty
                 <$> selectionSet)
     <?> "document error!"
 
@@ -60,14 +64,15 @@ definition = DefinitionOperation <$> operationDefinition
 
 operationDefinition :: Parser OperationDefinition
 operationDefinition =
-        op Query "query"
+        Query    <$ tok "query"    <*> node
-    <|> op Mutation "mutation"
+    <|> Mutation <$ tok "mutation" <*> node
     <?> "operationDefinition error!"
-  where
+
-    op f n = f <$ tok n <*> tok name
+node :: Parser Node
-                        <*> optempty variableDefinitions
+node = Node <$> name
-                        <*> optempty directives
+            <*> optempty variableDefinitions
-                        <*> selectionSet
+            <*> optempty directives
+            <*> selectionSet
 
 variableDefinitions :: Parser [VariableDefinition]
 variableDefinitions = parens (many1 variableDefinition)
@@ -148,16 +153,24 @@ typeCondition = namedType
 -- explicit types use the `typedValue` parser.
 value :: Parser Value
 value = ValueVariable <$> variable
-        -- TODO: Handle arbitrary precision.
+    -- TODO: Handle maxBound, Int32 in spec.
-    <|> ValueInt     <$> tok (signed decimal)
+    <|> ValueInt      <$> tok (signed decimal)
-    <|> ValueFloat   <$> tok (signed double)
+    <|> ValueFloat    <$> tok (signed double)
-    <|> ValueBoolean <$> bool
+    <|> ValueBoolean  <$> booleanValue
-    -- TODO: Handle escape characters, unicode, etc
+    <|> ValueString   <$> stringValue
-    <|> ValueString  <$> quotes name
     -- `true` and `false` have been tried before
-    <|> ValueEnum    <$> name
+    <|> ValueEnum     <$> name
-    <|> ValueList    <$> listValue
+    <|> ValueList     <$> listValue
-    <|> ValueObject  <$> objectValue
+    <|> ValueObject   <$> objectValue
+    <?> "value error!"
+
+booleanValue :: Parser Bool
+booleanValue = True  <$ tok "true"
+   <|> False <$ tok "false"
+
+-- TODO: Escape characters. Look at `jsstring_` in aeson package.
+stringValue :: Parser StringValue
+stringValue = StringValue <$> quotes (takeWhile (/= '"'))
 
 -- Notice it can be empty
 listValue :: Parser ListValue
@@ -170,10 +183,6 @@ objectValue = ObjectValue <$> braces (many objectField)
 objectField :: Parser ObjectField
 objectField = ObjectField <$> name <* tok ":" <*> value
 
-bool :: Parser Bool
-bool = True  <$ tok "true"
-   <|> False <$ tok "false"
-
 -- * Directives
 
 directives :: Parser [Directive]
@@ -188,9 +197,10 @@ directive = Directive
 -- * Type Reference
 
 type_ :: Parser Type
-type_ = TypeNamed   <$> namedType
+type_ = TypeList    <$> listType
-    <|> TypeList    <$> listType
     <|> TypeNonNull <$> nonNullType
+    <|> TypeNamed   <$> namedType
+    <?> "type_ error!"
 
 namedType :: Parser NamedType
 namedType = NamedType <$> name
@@ -201,6 +211,7 @@ listType = ListType <$> brackets type_
 nonNullType :: Parser NonNullType
 nonNullType = NonNullTypeNamed <$> namedType <* tok "!"
           <|> NonNullTypeList  <$> listType  <* tok "!"
+          <?> "nonNullType error!"
 
 -- * Type Definition
 
@@ -221,7 +232,6 @@ objectTypeDefinition = ObjectTypeDefinition
     <*> name
     <*> optempty interfaces
     <*> fieldDefinitions
-    <?> "objectTypeDefinition error!"
 
 interfaces :: Parser Interfaces
 interfaces = tok "implements" *> many1 namedType
@@ -237,17 +247,7 @@ fieldDefinition = FieldDefinition
     <*> type_
 
 argumentsDefinition :: Parser ArgumentsDefinition
-argumentsDefinition = inputValueDefinitions
+argumentsDefinition = parens $ many1 inputValueDefinition
-
-inputValueDefinitions :: Parser [InputValueDefinition]
-inputValueDefinitions = parens $ many1 inputValueDefinition
-
-inputValueDefinition :: Parser InputValueDefinition
-inputValueDefinition = InputValueDefinition
-    <$> name
-    <*  tok ":"
-    <*> type_
-    <*> optional defaultValue
 
 interfaceTypeDefinition :: Parser InterfaceTypeDefinition
 interfaceTypeDefinition = InterfaceTypeDefinition
@@ -288,6 +288,16 @@ inputObjectTypeDefinition = InputObjectTypeDefinition
     <*> name
     <*> inputValueDefinitions
 
+inputValueDefinitions :: Parser [InputValueDefinition]
+inputValueDefinitions = braces $ many1 inputValueDefinition
+
+inputValueDefinition :: Parser InputValueDefinition
+inputValueDefinition = InputValueDefinition
+    <$> name
+    <*  tok ":"
+    <*> type_
+    <*> optional defaultValue
+
 typeExtensionDefinition :: Parser TypeExtensionDefinition
 typeExtensionDefinition = TypeExtensionDefinition
     <$  tok "extend"
@@ -320,8 +330,7 @@ optempty = option mempty
 -- ** WhiteSpace
 --
 whiteSpace :: Parser ()
-whiteSpace = peekChar >>= \case
+whiteSpace = peekChar >>= traverse_ (\c ->
-    Just c -> if isSpace c || c == ','
+    if isSpace c || c == ','
-              then anyChar *> whiteSpace
+       then anyChar *> whiteSpace
-              else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace
+       else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace)
-    _ -> return ()

README.md

@@ -9,9 +9,11 @@ but the idea is to be a Haskell port of
 should include:
 
 - [x] GraphQL AST
-- [x] Parser for the GraphQL language. See TODO for caveats.
+- [x] Parser for the GraphQL language. See TODO for limitations.
+- [x] Printer for GraphQL. This is not pretty yet.
 - [ ] GraphQL Schema AST.
 - [ ] Parser for the GraphQL Schema language.
+- [ ] Printer for the GraphQL Schema language.
 - [ ] Interpreter of GraphQL requests.
 - [ ] Utilities to define GraphQL types and schema.
 
@@ -21,6 +23,6 @@ See the TODO file for more concrete tasks.
 
 Suggestions, contributions and bug reports are welcome.
 
-Feel free to contact me, jdnavarro, on the #haskell channel on the
+Feel free to contact on Slack in [#haskell on
-[GraphQL Slack Server](https://graphql.slack.com). You can obtain an
+GraphQL](https://graphql.slack.com/messages/haskell/). You can obtain an
 invitation [here](https://graphql-slack.herokuapp.com/).

TODO

@@ -1,21 +1,21 @@
 ## AST
+- Docs
 - Simplify unnecessary `newtypes` with type synonyms
+- Simplify wrapper type constructors. Some types can be just constructors.
 - Data type accessors
-- Deal with Strictness/unboxing
+- Deal with strictness/unboxing
-- Deal with Location
+- Deal with location
 
 ## Parser
-- Secure Names
+- Docs
-- Optimize `name` and `whiteSpace`: `take...`, `T.fold`, ...
 - Handle escape characters in string literals
 - Guard for `on` in `FragmentSpread`
-- Tests!
 - Handle `[Const]` grammar parameter. Need examples
-- Arbitrary precision for number values?
+- Handle `maxBound` Int values.
-- Handle errors. Perhaps port to `parsers` or use a lexer and
+- Diagnostics. Perhaps port to `parsers` and use `trifecta` for diagnostics,
- `regex-applicative`
+  and `attoparsec` for performance.
+- Optimize `whiteSpace`, perhaps front the main parser with a lexer.
 
-## Tests
+## Printer
-
+- Add pretty printer.
-- Golden data within package, `path_graphql` macro.
+- Docs
-- Pretty Print golden result

graphql.cabal

@@ -1,5 +1,5 @@
 name:                graphql
-version:             0.2.1
+version:             0.3
 synopsis:            Haskell GraphQL implementation
 description:
   This package provides a rudimentary parser for the
@@ -17,29 +17,30 @@ cabal-version:       >=1.10
 tested-with:         GHC == 7.8.4, GHC == 7.10.2
 extra-source-files:  README.md CHANGELOG.md stack.yaml
 data-files:          tests/data/*.graphql
-                     tests/data/*.graphql.golden
+                     tests/data/*.min.graphql
 
 library
   default-language:    Haskell2010
   ghc-options:         -Wall
   exposed-modules:     Data.GraphQL.AST
+                       Data.GraphQL.Encoder
                        Data.GraphQL.Parser
-  build-depends:       base >= 4.7 && < 5,
+  build-depends:       base >=4.7 && < 5,
                        text >=0.11.3.1,
                        attoparsec >=0.10.4.0
 
-test-suite golden
+test-suite tasty
   default-language:    Haskell2010
   type:                exitcode-stdio-1.0
   hs-source-dirs:      tests
-  main-is:             golden.hs
+  main-is:             tasty.hs
   ghc-options:         -Wall
-  build-depends:       base >= 4.6 && <5,
+  other-modules:       Paths_graphql
-                       bytestring,
+  build-depends:       base >=4.6 && <5,
-                       text,
+                       text >=0.11.3.1,
-                       attoparsec,
+                       attoparsec >=0.10.4.0,
                        tasty >=0.10,
-                       tasty-golden,
+                       tasty-hunit >=0.9,
                        graphql
 
 source-repository head

tests/data/kitchen-sink.graphql.golden

@@ -1 +0,0 @@
-Document [DefinitionOperation (Query "queryName" [VariableDefinition (Variable "foo") (TypeNamed (NamedType "ComplexType")) Nothing,VariableDefinition (Variable "site") (TypeNamed (NamedType "Site")) (Just (ValueEnum "MOBILE"))] [] [SelectionField (Field "whoever123is" "node" [Argument "id" (ValueList (ListValue [ValueInt 123,ValueInt 456]))] [] [SelectionField (Field "" "id" [] [] []),SelectionInlineFragment (InlineFragment (NamedType "User") [Directive "defer" []] [SelectionField (Field "" "field2" [] [] [SelectionField (Field "" "id" [] [] []),SelectionField (Field "alias" "field1" [Argument "first" (ValueInt 10),Argument "after" (ValueVariable (Variable "foo"))] [Directive "include" [Argument "if" (ValueVariable (Variable "foo"))]] [SelectionField (Field "" "id" [] [] []),SelectionFragmentSpread (FragmentSpread "frag" [])])])])])]),DefinitionOperation (Mutation "likeStory" [] [] [SelectionField (Field "" "like" [Argument "story" (ValueInt 123)] [Directive "defer" []] [SelectionField (Field "" "story" [] [] [SelectionField (Field "" "id" [] [] [])])])]),DefinitionFragment (FragmentDefinition "frag" (NamedType "Friend") [] [SelectionField (Field "" "foo" [Argument "size" (ValueVariable (Variable "size")),Argument "bar" (ValueVariable (Variable "b")),Argument "obj" (ValueObject (ObjectValue [ObjectField "key" (ValueString "value")]))] [] [])])]

tests/data/kitchen-sink.min.graphql

@@ -0,0 +1 @@
+query queryName($foo:ComplexType,$site:Site=MOBILE){whoever123is:node(id:[123,456]){id,... on User@defer{field2{id,alias:field1(first:10,after:$foo)@include(if:$foo){id,...frag}}}}}mutation likeStory{like(story:123)@defer{story{id}}}fragment frag on Friend{foo(size:$size,bar:$b,obj:{key:"value"})}

tests/golden.hs

@@ -1,25 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Main where
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>), (<*>), pure)
-#endif
-import Control.Monad ((>=>))
-import Data.Attoparsec.Text (parseOnly)
-import Data.ByteString.Lazy.Char8 as B8
-import qualified Data.Text.IO as TIO
-import Test.Tasty (defaultMain)
-import Test.Tasty.Golden (goldenVsString)
-
-import Paths_graphql (getDataFileName)
-import Data.GraphQL.Parser (document)
-
-main :: IO ()
-main = defaultMain
-   =<< goldenVsString "kitchen-sink.graphql"
-   <$> getDataFileName "tests/data/kitchen-sink.graphql.graphql.golden"
-   <*> (parse <$> getDataFileName "tests/data/kitchen-sink.graphql")
-  where
-    parse = fmap (parseOnly document) . TIO.readFile
-        >=> pure . either B8.pack (flip B8.snoc '\n' . B8.pack . show)

tests/tasty.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative ((<$>), (<*>))
+#endif
+
+import Data.Attoparsec.Text (parseOnly)
+import qualified Data.Text.IO as Text
+import Test.Tasty (defaultMain)
+import Test.Tasty.HUnit
+
+import qualified Data.GraphQL.Parser as Parser
+import qualified Data.GraphQL.Encoder as Encoder
+
+import Paths_graphql (getDataFileName)
+
+main :: IO ()
+main = defaultMain =<< testCase "Kitchen Sink"
+                   <$> (assertEqual "Encode" <$> expected <*> actual)
+  where
+    expected = Text.readFile
+           =<< getDataFileName "tests/data/kitchen-sink.min.graphql"
+
+    actual = either (error "Parsing error!") Encoder.document
+         <$> parseOnly Parser.document
+         <$> expected