Version bump, CHANGELOG and some gardening

- Add missing variable parsing.
- Reuse `name` in value string.

This parses successfully the `kitchen-sink.graphql` sample from
`graphql-js`.

.ghci

@@ -0,0 +1,2 @@
+import Data.Attoparsec.Text
+import qualified Data.Text.IO as TIO

CHANGELOG.md

@@ -1,6 +1,15 @@
 # Change Log
 All notable changes to this project will be documented in this file.
 
+## [0.2] - 2015-09-14
+### Added
+- Rudimentary parser for `GraphQL` which successfully parses the sample file
+  `kitchen-sink.graphql` from `graphql-js` tests.
+- Golden test for `kitchen-sink.grahql` parsing.
+### Changed
+- Many optional data types in `GraphQl` didn't need to be wrapped in a `Maybe`.
+- Some `newtype`s became type synonyms for easier parsing.
+
 ## [0.1] - 2015-09-12
 ### Added
 - Data types for the GraphQL language.

Data/GraphQL/AST.hs

@@ -1,4 +1,4 @@
-module Data.GraphQL where
+module Data.GraphQL.AST where
 
 import Data.Text (Text)
 
@@ -16,9 +16,10 @@ data Definition = DefinitionOperation OperationDefinition
                   deriving (Eq,Show)
 
 data OperationDefinition =
-    Query        (Maybe [VariableDefinition]) (Maybe [Directive]) SelectionSet
-  | Mutation     (Maybe [VariableDefinition]) (Maybe [Directive]) SelectionSet
-  | Subscription (Maybe [VariableDefinition]) (Maybe [Directive]) SelectionSet
+    Query        Name [VariableDefinition] [Directive] SelectionSet
+  | Mutation     Name [VariableDefinition] [Directive] SelectionSet
+  -- Not official yet
+  -- -- | Subscription Name [VariableDefinition] [Directive] SelectionSet
     deriving (Eq,Show)
 
 data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
@@ -26,16 +27,16 @@ data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
 
 newtype Variable = Variable Name deriving (Eq,Show)
 
-newtype SelectionSet = SelectionSet [Selection] deriving (Eq,Show)
+type SelectionSet = [Selection]
 
 data Selection = SelectionField Field
                | SelectionFragmentSpread FragmentSpread
                | SelectionInlineFragment InlineFragment
                  deriving (Eq,Show)
 
-data Field = Field (Maybe Alias) Name (Maybe [Argument])
-                                      (Maybe [Directive])
-                                      (Maybe SelectionSet)
+data Field = Field Alias Name [Argument]
+                              [Directive]
+                              SelectionSet
              deriving (Eq,Show)
 
 type Alias = Name
@@ -44,15 +45,15 @@ data Argument = Argument Name Value deriving (Eq,Show)
 
 -- * Fragments
 
-data FragmentSpread = FragmentSpread Name (Maybe [Directive])
+data FragmentSpread = FragmentSpread Name [Directive]
                       deriving (Eq,Show)
 
 data InlineFragment =
-    InlineFragment TypeCondition (Maybe [Directive]) SelectionSet
+    InlineFragment TypeCondition [Directive] SelectionSet
     deriving (Eq,Show)
 
 data FragmentDefinition =
-    FragmentDefinition Name TypeCondition (Maybe [Directive]) SelectionSet
+    FragmentDefinition Name TypeCondition [Directive] SelectionSet
     deriving (Eq,Show)
 
 type TypeCondition = NamedType
@@ -60,10 +61,10 @@ type TypeCondition = NamedType
 -- * Values
 
 data Value = ValueVariable Variable
-           | ValueInt Int
-           | ValueFloat Float
-           | ValueString Text
+           | ValueInt Int -- TODO: Should this be `Integer`?
+           | ValueFloat Double -- TODO: Should this be `Scientific`?
            | ValueBoolean Bool
+           | ValueString Text
            | ValueEnum Name
            | ValueList ListValue
            | ValueObject ObjectValue
@@ -79,7 +80,7 @@ type DefaultValue = Value
 
 -- * Directives
 
-data Directive = Directive Name (Maybe [Argument]) deriving (Eq,Show)
+data Directive = Directive Name [Argument] deriving (Eq,Show)
 
 -- * Type Reference
 
@@ -107,14 +108,16 @@ data TypeDefinition = TypeDefinitionObject        ObjectTypeDefinition
                     | TypeDefinitionTypeExtension TypeExtensionDefinition
                       deriving (Eq,Show)
 
-data ObjectTypeDefinition = ObjectTypeDefinition Name (Maybe Interfaces) [FieldDefinition]
+data ObjectTypeDefinition = ObjectTypeDefinition Name Interfaces [FieldDefinition]
                             deriving (Eq,Show)
 
 type Interfaces = [NamedType]
 
-data FieldDefinition = FieldDefinition Name [InputValueDefinition]
+data FieldDefinition = FieldDefinition Name ArgumentsDefinition Type
                        deriving (Eq,Show)
 
+type ArgumentsDefinition = [InputValueDefinition]
+
 data InputValueDefinition = InputValueDefinition Name Type (Maybe DefaultValue)
                             deriving (Eq,Show)
 

Data/GraphQL/Parser.hs

@@ -0,0 +1,322 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+module Data.GraphQL.Parser where
+
+import Prelude hiding (takeWhile)
+import Control.Applicative ((<|>), empty, many, optional)
+import Control.Monad (when)
+import Data.Char
+
+import Data.Text (Text, pack)
+import Data.Attoparsec.Text
+  ( Parser
+  , (<?>)
+  , anyChar
+  , decimal
+  , double
+  , endOfLine
+  , many1
+  , manyTill
+  , option
+  , peekChar
+  , satisfy
+  , sepBy1
+  , signed
+  )
+
+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)
+
+-- * Document
+
+document :: Parser Document
+document = whiteSpace
+     *> (Document <$> many1 definition)
+    -- Try SelectionSet when no definition
+    <|> (Document . pure
+                  . DefinitionOperation
+                  . Query mempty empty empty
+                <$> selectionSet)
+    <?> "document error!"
+
+definition :: Parser Definition
+definition = DefinitionOperation <$> operationDefinition
+         <|> DefinitionFragment  <$> fragmentDefinition
+         <|> DefinitionType      <$> typeDefinition
+         <?> "definition error!"
+
+operationDefinition :: Parser OperationDefinition
+operationDefinition =
+        op Query "query"
+    <|> op Mutation "mutation"
+    <?> "operationDefinition error!"
+  where
+    op f n = f <$ tok n <*> tok name
+                        <*> optempty variableDefinitions
+                        <*> optempty directives
+                        <*> selectionSet
+
+variableDefinitions :: Parser [VariableDefinition]
+variableDefinitions = parens (many1 variableDefinition)
+
+variableDefinition :: Parser VariableDefinition
+variableDefinition =
+    VariableDefinition <$> variable
+                       <*  tok ":"
+                       <*> type_
+                       <*> optional defaultValue
+
+defaultValue :: Parser DefaultValue
+defaultValue = tok "=" *> value
+
+variable :: Parser Variable
+variable = Variable <$ tok "$" <*> name
+
+selectionSet :: Parser SelectionSet
+selectionSet = braces $ many1 selection
+
+selection :: Parser Selection
+selection = SelectionField <$> field
+            -- Inline first to catch `on` case
+        <|> SelectionInlineFragment <$> inlineFragment
+        <|> SelectionFragmentSpread <$> fragmentSpread
+        <?> "selection error!"
+
+field :: Parser Field
+field = Field <$> optempty alias
+              <*> name
+              <*> optempty arguments
+              <*> optempty directives
+              <*> optempty selectionSet
+
+alias :: Parser Alias
+alias = name <* tok ":"
+
+arguments :: Parser [Argument]
+arguments = parens $ many1 argument
+
+argument :: Parser Argument
+argument = Argument <$> name <* tok ":" <*> value
+
+-- * Fragments
+
+fragmentSpread :: Parser FragmentSpread
+-- TODO: Make sure it fails when `... on`.
+-- See https://facebook.github.io/graphql/#FragmentSpread
+fragmentSpread = FragmentSpread
+    <$  tok "..."
+    <*> name
+    <*> optempty directives
+
+-- InlineFragment tried first in order to guard against 'on' keyword
+inlineFragment :: Parser InlineFragment
+inlineFragment = InlineFragment
+    <$  tok "..."
+    <*  tok "on"
+    <*> typeCondition
+    <*> optempty directives
+    <*> selectionSet
+
+fragmentDefinition :: Parser FragmentDefinition
+fragmentDefinition = FragmentDefinition
+    <$  tok "fragment"
+    <*> name
+    <*  tok "on"
+    <*> typeCondition
+    <*> optempty directives
+    <*> selectionSet
+
+typeCondition :: Parser TypeCondition
+typeCondition = namedType
+
+-- * Values
+
+-- This will try to pick the first type it can parse. If you are working with
+-- explicit types use the `typedValue` parser.
+value :: Parser Value
+value = ValueVariable <$> variable
+        -- TODO: Handle arbitrary precision.
+    <|> ValueInt     <$> tok (signed decimal)
+    <|> ValueFloat   <$> tok (signed double)
+    <|> ValueBoolean <$> bool
+    -- TODO: Handle escape characters, unicode, etc
+    <|> ValueString  <$> quotes name
+    -- `true` and `false` have been tried before
+    <|> ValueEnum    <$> name
+    <|> ValueList    <$> listValue
+    <|> ValueObject  <$> objectValue
+
+-- Notice it can be empty
+listValue :: Parser ListValue
+listValue = ListValue <$> brackets (many value)
+
+-- Notice it can be empty
+objectValue :: Parser ObjectValue
+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]
+directives = many1 directive
+
+directive :: Parser Directive
+directive = Directive
+    <$  tok "@"
+    <*> name
+    <*> optempty arguments
+
+-- * Type Reference
+
+type_ :: Parser Type
+type_ = TypeNamed   <$> namedType
+    <|> TypeList    <$> listType
+    <|> TypeNonNull <$> nonNullType
+
+namedType :: Parser NamedType
+namedType = NamedType <$> name
+
+listType :: Parser ListType
+listType = ListType <$> brackets type_
+
+nonNullType :: Parser NonNullType
+nonNullType = NonNullTypeNamed <$> namedType <* tok "!"
+          <|> NonNullTypeList  <$> listType  <* tok "!"
+
+-- * Type Definition
+
+typeDefinition :: Parser TypeDefinition
+typeDefinition =
+        TypeDefinitionObject        <$> objectTypeDefinition
+    <|> TypeDefinitionInterface     <$> interfaceTypeDefinition
+    <|> TypeDefinitionUnion         <$> unionTypeDefinition
+    <|> TypeDefinitionScalar        <$> scalarTypeDefinition
+    <|> TypeDefinitionEnum          <$> enumTypeDefinition
+    <|> TypeDefinitionInputObject   <$> inputObjectTypeDefinition
+    <|> TypeDefinitionTypeExtension <$> typeExtensionDefinition
+    <?> "typeDefinition error!"
+
+objectTypeDefinition :: Parser ObjectTypeDefinition
+objectTypeDefinition = ObjectTypeDefinition
+    <$  tok "type"
+    <*> name
+    <*> optempty interfaces
+    <*> fieldDefinitions
+    <?> "objectTypeDefinition error!"
+
+interfaces :: Parser Interfaces
+interfaces = tok "implements" *> many1 namedType
+
+fieldDefinitions :: Parser [FieldDefinition]
+fieldDefinitions = braces $ many1 fieldDefinition
+
+fieldDefinition :: Parser FieldDefinition
+fieldDefinition = FieldDefinition
+    <$> name
+    <*> optempty argumentsDefinition
+    <*  tok ":"
+    <*> type_
+
+argumentsDefinition :: Parser ArgumentsDefinition
+argumentsDefinition = inputValueDefinitions
+
+inputValueDefinitions :: Parser [InputValueDefinition]
+inputValueDefinitions = parens $ many1 inputValueDefinition
+
+inputValueDefinition :: Parser InputValueDefinition
+inputValueDefinition = InputValueDefinition
+    <$> name
+    <*  tok ":"
+    <*> type_
+    <*> optional defaultValue
+
+interfaceTypeDefinition :: Parser InterfaceTypeDefinition
+interfaceTypeDefinition = InterfaceTypeDefinition
+    <$  tok "interface"
+    <*> name
+    <*> fieldDefinitions
+
+unionTypeDefinition :: Parser UnionTypeDefinition
+unionTypeDefinition = UnionTypeDefinition
+    <$  tok "union"
+    <*> name
+    <*  tok "="
+    <*> unionMembers
+
+unionMembers :: Parser [NamedType]
+unionMembers = namedType `sepBy1` tok "|"
+
+scalarTypeDefinition :: Parser ScalarTypeDefinition
+scalarTypeDefinition = ScalarTypeDefinition
+    <$  tok "scalar"
+    <*> name
+
+enumTypeDefinition :: Parser EnumTypeDefinition
+enumTypeDefinition = EnumTypeDefinition
+    <$  tok "enum"
+    <*> name
+    <*> enumValueDefinitions
+
+enumValueDefinitions :: Parser [EnumValueDefinition]
+enumValueDefinitions = braces $ many1 enumValueDefinition
+
+enumValueDefinition :: Parser EnumValueDefinition
+enumValueDefinition = EnumValueDefinition <$> name
+
+inputObjectTypeDefinition :: Parser InputObjectTypeDefinition
+inputObjectTypeDefinition = InputObjectTypeDefinition
+    <$  tok "input"
+    <*> name
+    <*> inputValueDefinitions
+
+typeExtensionDefinition :: Parser TypeExtensionDefinition
+typeExtensionDefinition = TypeExtensionDefinition
+    <$  tok "extend"
+    <*> objectTypeDefinition
+
+-- * Internal
+
+tok :: Parser a -> Parser a
+tok p = p <* whiteSpace
+
+parens :: Parser a -> Parser a
+parens = between "(" ")"
+
+braces :: Parser a -> Parser a
+braces = between "{" "}"
+
+quotes :: Parser a -> Parser a
+quotes = between "\"" "\""
+
+brackets :: Parser a -> Parser a
+brackets = between "[" "]"
+
+between :: Parser Text -> Parser Text -> Parser a -> Parser a
+between open close p = tok open *> p <* tok close
+
+-- `empty` /= `pure mempty` for `Parser`.
+optempty :: Monoid a => Parser a -> Parser a
+optempty = option mempty
+
+-- ** WhiteSpace
+--
+whiteSpace :: Parser ()
+whiteSpace = peekChar >>= \case
+    Just c -> if isSpace c || c == ','
+              then anyChar *> whiteSpace
+              else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace
+    _ -> return ()

README.md

@@ -7,12 +7,15 @@ but the idea is to be a Haskell port of
 [`graphql-js`](https://github.com/graphql/graphql-js). Next releases
 should include:
 
-- [ ] Parser for the GraphQL language.
-- [ ] Data types for the GraphQL Schema language.
+- [x] GraphQL AST
+- [x] Parser for the GraphQL language. See TODO for caveats.
+- [ ] GraphQL Schema AST.
 - [ ] Parser for the GraphQL Schema language.
 - [ ] Interpreter of GraphQL requests.
 - [ ] Utilities to define GraphQL types and schema.
 
+See the TODO file for more concrete tasks.
+
 ## Contact
 
 Suggestions, contributions and bug reports are welcome.

TODO

@@ -1,3 +1,21 @@
+## AST
+- Simplify unnecessary `newtypes` with type synonyms
 - Data type accessors
-- Deal with Location
 - Deal with Strictness/unboxing
+- Deal with Location
+
+## Parser
+- Secure Names
+- 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 errors. Perhaps port to `parsers` or use a lexer and
+ `regex-applicative`
+
+## Tests
+
+- Golden data within package, `path_graphql` macro.
+- Pretty Print golden result

graphql.cabal

@@ -1,9 +1,9 @@
 name:                graphql
-version:             0.1
-synopsis:            GraphQL Haskell implementation
+version:             0.2
+synopsis:            Haskell GraphQL implementation
 description:
-  For now this package provides the data types for the GraphQL language.
-  Further releases will cover more aspects of the GraphQL specification.
+  This package provides a rudimentary parser for the
+  <https://facebook.github.io/graphql/ GraphQL> language.
 homepage:            https://github.com/jdnavarro/graphql-haskell
 bug-reports:         https://github.com/jdnavarro/graphql-haskell/issues
 license:             BSD3
@@ -13,14 +13,32 @@ maintainer:          j@dannynavarro.net
 copyright:           Copyright (C) 2015 J. Daniel Navarro
 category:            Web
 build-type:          Simple
-extra-source-files:  README.md CHANGELOG.md stack.yaml
 cabal-version:       >=1.10
+tested-with:         GHC == 7.10
+extra-source-files:  README.md CHANGELOG.md stack.yaml
 
 library
-  exposed-modules:     Data.GraphQL
-  build-depends:       base >= 4.7 && < 5,
-                       text >=0.11.3.1
   default-language:    Haskell2010
+  ghc-options:         -Wall
+  exposed-modules:     Data.GraphQL.AST
+                       Data.GraphQL.Parser
+  build-depends:       base >= 4.7 && < 5,
+                       text >=0.11.3.1,
+                       attoparsec >=0.10.4.0
+
+test-suite golden
+  default-language:    Haskell2010
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      tests
+  main-is:             golden.hs
+  ghc-options:         -Wall
+  build-depends:       base >= 4.6 && <5,
+                       bytestring,
+                       text,
+                       attoparsec,
+                       tasty >=0.10,
+                       tasty-golden,
+                       graphql
 
 source-repository head
   type:     git

tests/data/kitchen-sink.graphql

@@ -0,0 +1,38 @@
+# Copyright (c) 2015, Facebook, Inc.
+# All rights reserved.
+#
+# This source code is licensed under the BSD-style license found in the
+# LICENSE file in the root directory of this source tree. An additional grant
+# of patent rights can be found in the PATENTS file in the same directory.
+
+query queryName($foo: ComplexType, $site: Site = MOBILE) {
+  whoever123is: node(id: [123, 456]) {
+    id , # Inline test comment
+    ... 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"})
+}
+
+{
+  unnamed(truthy: true, falsey: false),
+  query
+}

tests/data/kitchen-sink.graphql.golden

@@ -0,0 +1 @@
+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/golden.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+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 Data.GraphQL.Parser (document)
+
+main :: IO ()
+main = defaultMain
+     $ goldenVsString "kitchen-sink.graphql"
+                      "./tests/data/kitchen-sink.graphql.golden"
+                      (parse "./tests/data/kitchen-sink.graphql")
+  where
+    parse = fmap (parseOnly document) . TIO.readFile
+        >=> pure . either B8.pack (flip B8.snoc '\n' . B8.pack . show)
+