diff options
| -rw-r--r-- | .ghci | 2 | ||||
| -rw-r--r-- | CHANGELOG.md | 9 | ||||
| -rw-r--r-- | Data/GraphQL/AST.hs (renamed from Data/GraphQL.hs) | 37 | ||||
| -rw-r--r-- | Data/GraphQL/Parser.hs | 322 | ||||
| -rw-r--r-- | README.md | 7 | ||||
| -rw-r--r-- | TODO | 20 | ||||
| -rw-r--r-- | graphql.cabal | 32 | ||||
| -rw-r--r-- | tests/data/kitchen-sink.graphql | 38 | ||||
| -rw-r--r-- | tests/data/kitchen-sink.graphql.golden | 1 | ||||
| -rw-r--r-- | tests/golden.hs | 21 |
10 files changed, 462 insertions, 27 deletions
@@ -0,0 +1,2 @@ +import Data.Attoparsec.Text +import qualified Data.Text.IO as TIO diff --git a/CHANGELOG.md b/CHANGELOG.md index a5ca3ef..8f8d712 100644 --- a/CHANGELOG.md +++ b/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. diff --git a/Data/GraphQL.hs b/Data/GraphQL/AST.hs index d878022..0a09671 100644 --- a/Data/GraphQL.hs +++ b/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) diff --git a/Data/GraphQL/Parser.hs b/Data/GraphQL/Parser.hs new file mode 100644 index 0000000..66d913d --- /dev/null +++ b/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 () @@ -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. @@ -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 diff --git a/graphql.cabal b/graphql.cabal index f653731..2f83aeb 100644 --- a/graphql.cabal +++ b/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 + 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 + 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 diff --git a/tests/data/kitchen-sink.graphql b/tests/data/kitchen-sink.graphql new file mode 100644 index 0000000..46fd10e --- /dev/null +++ b/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 +} diff --git a/tests/data/kitchen-sink.graphql.golden b/tests/data/kitchen-sink.graphql.golden new file mode 100644 index 0000000..2542cd5 --- /dev/null +++ b/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")]))] [] [])])] diff --git a/tests/golden.hs b/tests/golden.hs new file mode 100644 index 0000000..e7ab70f --- /dev/null +++ b/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) + |