Version Bump

This also includes updates to CHANGELOG, TODO and README.

.ghci

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

.travis.yml

@@ -0,0 +1,79 @@
+# This file has been generated -- see https://github.com/hvr/multi-ghc-travis
+language: c
+sudo: false
+
+cache:
+  directories:
+    - $HOME/.cabsnap
+    - $HOME/.cabal/packages
+
+before_cache:
+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar
+
+matrix:
+  include:
+    - env: CABALVER=1.18 GHCVER=7.8.4
+      compiler: ": #GHC 7.8.4"
+      addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}
+    - env: CABALVER=1.22 GHCVER=7.10.2
+      compiler: ": #GHC 7.10.2"
+      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}}
+
+before_install:
+ - unset CC
+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
+
+install:
+ - cabal --version
+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
+ - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
+   then
+     zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >
+          $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
+   fi
+ - travis_retry cabal update -v
+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
+ - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt
+ - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt
+
+# check whether current requested install-plan matches cached package-db snapshot
+ - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;
+   then
+     echo "cabal build-cache HIT";
+     rm -rfv .ghc;
+     cp -a $HOME/.cabsnap/ghc $HOME/.ghc;
+     cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;
+   else
+     echo "cabal build-cache MISS";
+     rm -rf $HOME/.cabsnap;
+     mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;
+     cabal install --only-dependencies --enable-tests --enable-benchmarks;
+   fi
+ 
+# snapshot package-db on cache miss
+ - if [ ! -d $HOME/.cabsnap ];
+   then
+      echo "snapshotting package-db to build-cache";
+      mkdir $HOME/.cabsnap;
+      cp -a $HOME/.ghc $HOME/.cabsnap/ghc;
+      cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;
+   fi
+
+# Here starts the actual work to be performed for the package under test;
+# any command which exits with a non-zero exit code causes the build to fail.
+script:
+ - if [ -f configure.ac ]; then autoreconf -i; fi
+ - cabal configure --enable-tests --enable-benchmarks -v2  # -v2 provides useful information for debugging
+ - cabal build   # this builds all libraries and executables (including tests/benchmarks)
+ - cabal test
+ - cabal check
+ - cabal sdist   # tests that a source-distribution can be generated
+
+# Check that the resulting source distribution can be built & installed.
+# If there are no other `.tar.gz` files in `dist`, this can be even simpler:
+# `cabal install --force-reinstalls dist/*-*.tar.gz`
+ - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&
+   (cd dist && cabal install --force-reinstalls "$SRC_TGZ")
+
+# EOF

CHANGELOG.md

@@ -1,6 +1,38 @@
 # Change Log
 All notable changes to this project will be documented in this file.
 
-## [0.1] - 2015-09-12
+## [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.
+- Support for ghc-7.8.
+
+## [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.
+
+[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 where
+module Data.GraphQL.AST where
 
+import Data.Int (Int32)
 import Data.Text (Text)
 
 -- * Name
@@ -15,10 +16,11 @@ data Definition = DefinitionOperation OperationDefinition
                 | DefinitionType      TypeDefinition
                   deriving (Eq,Show)
 
-data OperationDefinition =
+data OperationDefinition = Query    Node
-    Query        (Maybe [VariableDefinition]) (Maybe [Directive]) SelectionSet
+                         | Mutation Node
-  | Mutation     (Maybe [VariableDefinition]) (Maybe [Directive]) SelectionSet
+                           deriving (Eq,Show)
-  | Subscription (Maybe [VariableDefinition]) (Maybe [Directive]) SelectionSet
+
+data Node = Node Name [VariableDefinition] [Directive] SelectionSet
             deriving (Eq,Show)
 
 data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
@@ -26,16 +28,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])
+data Field = Field Alias Name [Argument]
-                                      (Maybe [Directive])
+                              [Directive]
-                                      (Maybe SelectionSet)
+                              SelectionSet
              deriving (Eq,Show)
 
 type Alias = Name
@@ -44,15 +46,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,15 +62,18 @@ type TypeCondition = NamedType
 -- * Values
 
 data Value = ValueVariable Variable
-           | ValueInt Int
+           | ValueInt Int32
-           | ValueFloat Float
+           -- GraphQL Float is double precison
-           | ValueString Text
+           | ValueFloat Double
            | ValueBoolean Bool
+           | 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)
@@ -79,7 +84,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 +112,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/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

@@ -0,0 +1,336 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Data.GraphQL.Parser where
+
+import Prelude hiding (takeWhile)
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative ((<$>), (<*>), (*>), (<*), (<$), pure)
+import Data.Monoid (Monoid, mempty)
+#endif
+import Control.Applicative ((<|>), empty, many, optional)
+import Control.Monad (when)
+import Data.Char (isDigit, isSpace)
+import Data.Foldable (traverse_)
+
+import Data.Text (Text, append)
+import Data.Attoparsec.Text
+  ( Parser
+  , (<?>)
+  , anyChar
+  , decimal
+  , double
+  , endOfLine
+  , inClass
+  , many1
+  , manyTill
+  , option
+  , peekChar
+  , sepBy1
+  , signed
+  , takeWhile
+  , takeWhile1
+  )
+
+import Data.GraphQL.AST
+
+-- * Name
+
+name :: Parser Name
+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
+
+document :: Parser Document
+document = whiteSpace
+     *> (Document <$> many1 definition)
+    -- Try SelectionSet when no definition
+    <|> (Document . pure
+                  . DefinitionOperation
+                  . Query
+                  . Node mempty empty empty
+                <$> selectionSet)
+    <?> "document error!"
+
+definition :: Parser Definition
+definition = DefinitionOperation <$> operationDefinition
+         <|> DefinitionFragment  <$> fragmentDefinition
+         <|> DefinitionType      <$> typeDefinition
+         <?> "definition error!"
+
+operationDefinition :: Parser OperationDefinition
+operationDefinition =
+        Query    <$ tok "query"    <*> node
+    <|> Mutation <$ tok "mutation" <*> node
+    <?> "operationDefinition error!"
+
+node :: Parser Node
+node = Node <$> 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 maxBound, Int32 in spec.
+    <|> ValueInt      <$> tok (signed decimal)
+    <|> ValueFloat    <$> tok (signed double)
+    <|> ValueBoolean  <$> booleanValue
+    <|> ValueString   <$> stringValue
+    -- `true` and `false` have been tried before
+    <|> ValueEnum     <$> name
+    <|> ValueList     <$> listValue
+    <|> 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
+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
+
+-- * Directives
+
+directives :: Parser [Directive]
+directives = many1 directive
+
+directive :: Parser Directive
+directive = Directive
+    <$  tok "@"
+    <*> name
+    <*> optempty arguments
+
+-- * Type Reference
+
+type_ :: Parser Type
+type_ = TypeList    <$> listType
+    <|> TypeNonNull <$> nonNullType
+    <|> TypeNamed   <$> namedType
+    <?> "type_ error!"
+
+namedType :: Parser NamedType
+namedType = NamedType <$> name
+
+listType :: Parser ListType
+listType = ListType <$> brackets type_
+
+nonNullType :: Parser NonNullType
+nonNullType = NonNullTypeNamed <$> namedType <* tok "!"
+          <|> NonNullTypeList  <$> listType  <* tok "!"
+          <?> "nonNullType error!"
+
+-- * 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
+
+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 = parens $ many1 inputValueDefinition
+
+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
+
+inputValueDefinitions :: Parser [InputValueDefinition]
+inputValueDefinitions = braces $ many1 inputValueDefinition
+
+inputValueDefinition :: Parser InputValueDefinition
+inputValueDefinition = InputValueDefinition
+    <$> name
+    <*  tok ":"
+    <*> type_
+    <*> optional defaultValue
+
+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 >>= traverse_ (\c ->
+    if isSpace c || c == ','
+       then anyChar *> whiteSpace
+       else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace)

README.md

@@ -1,22 +1,28 @@
 # Haskell GraphQL
 
 [![Hackage Version](https://img.shields.io/hackage/v/graphql.svg)](https://hackage.haskell.org/package/graphql)
+[![Build Status](https://img.shields.io/travis/jdnavarro/graphql-haskell.svg)](https://travis-ci.org/jdnavarro/graphql-haskell)
 
 For now this only provides the data types to represent the GraphQL AST,
 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.
+- [x] GraphQL AST
-- [ ] Data types for the GraphQL Schema language.
+- [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.
 
+See the TODO file for more concrete tasks.
+
 ## Contact
 
 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,3 +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 Location
+- Deal with strictness/unboxing
-- Deal with Strictness/unboxing
+- Deal with location
+
+## Parser
+- Docs
+- Handle escape characters in string literals
+- Guard for `on` in `FragmentSpread`
+- Handle `[Const]` grammar parameter. Need examples
+- Handle `maxBound` Int values.
+- Diagnostics. Perhaps port to `parsers` and use `trifecta` for diagnostics,
+  and `attoparsec` for performance.
+- Optimize `whiteSpace`, perhaps front the main parser with a lexer.
+
+## Printer
+- Add pretty printer.
+- Docs

graphql.cabal

@@ -1,9 +1,9 @@
 name:                graphql
-version:             0.1
+version:             0.3
-synopsis:            GraphQL Haskell implementation
+synopsis:            Haskell GraphQL implementation
 description:
-  For now this package provides the data types for the GraphQL language.
+  This package provides a rudimentary parser for the
-  Further releases will cover more aspects of the GraphQL specification.
+  <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,35 @@ 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.8.4, GHC == 7.10.2
+extra-source-files:  README.md CHANGELOG.md stack.yaml
+data-files:          tests/data/*.graphql
+                     tests/data/*.min.graphql
 
 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.Encoder
+                       Data.GraphQL.Parser
+  build-depends:       base >=4.7 && < 5,
+                       text >=0.11.3.1,
+                       attoparsec >=0.10.4.0
+
+test-suite tasty
+  default-language:    Haskell2010
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      tests
+  main-is:             tasty.hs
+  ghc-options:         -Wall
+  other-modules:       Paths_graphql
+  build-depends:       base >=4.6 && <5,
+                       text >=0.11.3.1,
+                       attoparsec >=0.10.4.0,
+                       tasty >=0.10,
+                       tasty-hunit >=0.9,
+                       graphql
 
 source-repository head
   type:     git

stack-7.10.yaml

@@ -0,0 +1,5 @@
+flags: {}
+packages:
+- '.'
+extra-deps: []
+resolver: lts-3.4

stack-7.8.yaml

@@ -0,0 +1,5 @@
+flags: {}
+packages:
+- '.'
+extra-deps: []
+resolver: lts-2.22

stack.yaml

@@ -1,5 +0,0 @@
-flags: {}
-packages:
-- '.'
-extra-deps: []
-resolver: lts-3.4

stack.yaml

@@ -0,0 +1 @@
+stack-7.10.yaml

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.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/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