diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/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 @@ ### 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 diff --git a/Data/GraphQL/AST.hs b/Data/GraphQL/AST.hs --- a/Data/GraphQL/AST.hs +++ b/Data/GraphQL/AST.hs @@ -1,5 +1,6 @@ module Data.GraphQL.AST where +import Data.Int (Int32) import Data.Text (Text) -- * Name @@ -15,13 +16,13 @@ | DefinitionType TypeDefinition deriving (Eq,Show) -data OperationDefinition = - Query Name [VariableDefinition] [Directive] SelectionSet - | Mutation Name [VariableDefinition] [Directive] SelectionSet - -- Not official yet - -- -- | Subscription Name [VariableDefinition] [Directive] SelectionSet - deriving (Eq,Show) +data OperationDefinition = Query Node + | Mutation Node + deriving (Eq,Show) +data Node = Node Name [VariableDefinition] [Directive] SelectionSet + deriving (Eq,Show) + data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue) deriving (Eq,Show) @@ -61,14 +62,17 @@ -- * Values data Value = ValueVariable Variable - | ValueInt Int -- TODO: Should this be `Integer`? - | ValueFloat Double -- TODO: Should this be `Scientific`? + | ValueInt Int32 + -- 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) diff --git a/Data/GraphQL/Encoder.hs b/Data/GraphQL/Encoder.hs new file mode 100644 --- /dev/null +++ b/Data/GraphQL/Encoder.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Data.GraphQL.Encoder where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +import Data.Monoid (Monoid, mconcat, mempty) +#endif +import Data.Monoid ((<>)) + +import Data.Text (Text, cons, intercalate, pack, snoc) + +import Data.GraphQL.AST + +-- * Document + +-- TODO: Use query shorthand +document :: Document -> Text +document (Document defs) = (`snoc` '\n') . mconcat $ definition <$> defs + +definition :: Definition -> Text +definition (DefinitionOperation x) = operationDefinition x +definition (DefinitionFragment x) = fragmentDefinition x +definition (DefinitionType x) = typeDefinition x + +operationDefinition :: OperationDefinition -> Text +operationDefinition (Query n) = "query " <> node n +operationDefinition (Mutation n) = "mutation " <> node n + +node :: Node -> Text +node (Node name vds ds ss) = + name + <> optempty variableDefinitions vds + <> optempty directives ds + <> selectionSet ss + +variableDefinitions :: [VariableDefinition] -> Text +variableDefinitions = parensCommas variableDefinition + +variableDefinition :: VariableDefinition -> Text +variableDefinition (VariableDefinition var ty dv) = + variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv + +defaultValue :: DefaultValue -> Text +defaultValue val = "=" <> value val + +variable :: Variable -> Text +variable (Variable name) = "$" <> name + +selectionSet :: SelectionSet -> Text +selectionSet = bracesCommas selection + +selection :: Selection -> Text +selection (SelectionField x) = field x +selection (SelectionInlineFragment x) = inlineFragment x +selection (SelectionFragmentSpread x) = fragmentSpread x + +field :: Field -> Text +field (Field alias name args ds ss) = + optempty (`snoc` ':') alias + <> name + <> optempty arguments args + <> optempty directives ds + <> optempty selectionSet ss + +arguments :: [Argument] -> Text +arguments = parensCommas argument + +argument :: Argument -> Text +argument (Argument name v) = name <> ":" <> value v + +-- * Fragments + +fragmentSpread :: FragmentSpread -> Text +fragmentSpread (FragmentSpread name ds) = + "..." <> name <> optempty directives ds + +inlineFragment :: InlineFragment -> Text +inlineFragment (InlineFragment (NamedType tc) ds ss) = + "... on " <> tc + <> optempty directives ds + <> optempty selectionSet ss + +fragmentDefinition :: FragmentDefinition -> Text +fragmentDefinition (FragmentDefinition name (NamedType tc) ds ss) = + "fragment " <> name <> " on " <> tc + <> optempty directives ds + <> selectionSet ss + +-- * Values + +value :: Value -> Text +value (ValueVariable x) = variable x +-- TODO: This will be replaced with `decimal` Buidler +value (ValueInt x) = pack $ show x +-- TODO: This will be replaced with `decimal` Buidler +value (ValueFloat x) = pack $ show x +value (ValueBoolean x) = booleanValue x +value (ValueString x) = stringValue x +value (ValueEnum x) = x +value (ValueList x) = listValue x +value (ValueObject x) = objectValue x + +booleanValue :: Bool -> Text +booleanValue True = "true" +booleanValue False = "false" + +-- TODO: Escape characters +stringValue :: StringValue -> Text +stringValue (StringValue v) = quotes v + +listValue :: ListValue -> Text +listValue (ListValue vs) = bracketsCommas value vs + +objectValue :: ObjectValue -> Text +objectValue (ObjectValue ofs) = bracesCommas objectField ofs + +objectField :: ObjectField -> Text +objectField (ObjectField name v) = name <> ":" <> value v + +-- * Directives + +directives :: [Directive] -> Text +directives = spaces directive + +directive :: Directive -> Text +directive (Directive name args) = "@" <> name <> optempty arguments args + +-- * Type Reference + +type_ :: Type -> Text +type_ (TypeNamed (NamedType x)) = x +type_ (TypeList x) = listType x +type_ (TypeNonNull x) = nonNullType x + +namedType :: NamedType -> Text +namedType (NamedType name) = name + +listType :: ListType -> Text +listType (ListType ty) = brackets (type_ ty) + +nonNullType :: NonNullType -> Text +nonNullType (NonNullTypeNamed (NamedType x)) = x <> "!" +nonNullType (NonNullTypeList x) = listType x <> "!" + +typeDefinition :: TypeDefinition -> Text +typeDefinition (TypeDefinitionObject x) = objectTypeDefinition x +typeDefinition (TypeDefinitionInterface x) = interfaceTypeDefinition x +typeDefinition (TypeDefinitionUnion x) = unionTypeDefinition x +typeDefinition (TypeDefinitionScalar x) = scalarTypeDefinition x +typeDefinition (TypeDefinitionEnum x) = enumTypeDefinition x +typeDefinition (TypeDefinitionInputObject x) = inputObjectTypeDefinition x +typeDefinition (TypeDefinitionTypeExtension x) = typeExtensionDefinition x + +objectTypeDefinition :: ObjectTypeDefinition -> Text +objectTypeDefinition (ObjectTypeDefinition name ifaces fds) = + "type " <> name + <> optempty (spaced . interfaces) ifaces + <> optempty fieldDefinitions fds + +interfaces :: Interfaces -> Text +interfaces = ("implements " <>) . spaces namedType + +fieldDefinitions :: [FieldDefinition] -> Text +fieldDefinitions = bracesCommas fieldDefinition + +fieldDefinition :: FieldDefinition -> Text +fieldDefinition (FieldDefinition name args ty) = + name <> optempty argumentsDefinition args + <> ":" + <> type_ ty + +argumentsDefinition :: ArgumentsDefinition -> Text +argumentsDefinition = parensCommas inputValueDefinition + +interfaceTypeDefinition :: InterfaceTypeDefinition -> Text +interfaceTypeDefinition (InterfaceTypeDefinition name fds) = + "interface " <> name <> fieldDefinitions fds + +unionTypeDefinition :: UnionTypeDefinition -> Text +unionTypeDefinition (UnionTypeDefinition name ums) = + "union " <> name <> "=" <> unionMembers ums + +unionMembers :: [NamedType] -> Text +unionMembers = intercalate "|" . fmap namedType + +scalarTypeDefinition :: ScalarTypeDefinition -> Text +scalarTypeDefinition (ScalarTypeDefinition name) = "scalar " <> name + +enumTypeDefinition :: EnumTypeDefinition -> Text +enumTypeDefinition (EnumTypeDefinition name evds) = + "enum " <> name + <> bracesCommas enumValueDefinition evds + +enumValueDefinition :: EnumValueDefinition -> Text +enumValueDefinition (EnumValueDefinition name) = name + +inputObjectTypeDefinition :: InputObjectTypeDefinition -> Text +inputObjectTypeDefinition (InputObjectTypeDefinition name ivds) = + "input " <> name <> inputValueDefinitions ivds + +inputValueDefinitions :: [InputValueDefinition] -> Text +inputValueDefinitions = bracesCommas inputValueDefinition + +inputValueDefinition :: InputValueDefinition -> Text +inputValueDefinition (InputValueDefinition name ty dv) = + name <> ":" <> type_ ty <> maybe mempty defaultValue dv + +typeExtensionDefinition :: TypeExtensionDefinition -> Text +typeExtensionDefinition (TypeExtensionDefinition otd) = + "extend " <> objectTypeDefinition otd + +-- * Internal + +spaced :: Text -> Text +spaced = cons '\SP' + +between :: Char -> Char -> Text -> Text +between open close = cons open . (`snoc` close) + +parens :: Text -> Text +parens = between '(' ')' + +brackets :: Text -> Text +brackets = between '[' ']' + +braces :: Text -> Text +braces = between '{' '}' + +quotes :: Text -> Text +quotes = between '"' '"' + +spaces :: (a -> Text) -> [a] -> Text +spaces f = intercalate "\SP" . fmap f + +parensCommas :: (a -> Text) -> [a] -> Text +parensCommas f = parens . intercalate "," . fmap f + +bracketsCommas :: (a -> Text) -> [a] -> Text +bracketsCommas f = brackets . intercalate "," . fmap f + +bracesCommas :: (a -> Text) -> [a] -> Text +bracesCommas f = braces . intercalate "," . fmap f + +optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b +optempty f xs = if xs == mempty then mempty else f xs diff --git a/Data/GraphQL/Parser.hs b/Data/GraphQL/Parser.hs --- a/Data/GraphQL/Parser.hs +++ b/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 @@ #endif import Control.Applicative ((<|>), empty, many, optional) import Control.Monad (when) -import Data.Char -import Data.Text (Text, pack) +import Data.Char (isDigit, isSpace) +import Data.Foldable (traverse_) + +import Data.Text (Text, append) import Data.Attoparsec.Text ( Parser , () @@ -20,25 +21,27 @@ , 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 @@ -- Try SelectionSet when no definition <|> (Document . pure . DefinitionOperation - . Query mempty empty empty + . Query + . Node mempty empty empty <$> selectionSet) "document error!" @@ -60,15 +64,16 @@ operationDefinition :: Parser OperationDefinition operationDefinition = - op Query "query" - <|> op Mutation "mutation" + Query <$ tok "query" <*> node + <|> Mutation <$ tok "mutation" <*> node "operationDefinition error!" - where - op f n = f <$ tok n <*> tok name - <*> optempty variableDefinitions - <*> optempty directives - <*> selectionSet +node :: Parser Node +node = Node <$> name + <*> optempty variableDefinitions + <*> optempty directives + <*> selectionSet + variableDefinitions :: Parser [VariableDefinition] variableDefinitions = parens (many1 variableDefinition) @@ -148,17 +153,25 @@ -- 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 + -- 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 + <|> 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) @@ -170,10 +183,6 @@ 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 @@ -- * Type Reference type_ :: Parser Type -type_ = TypeNamed <$> namedType - <|> TypeList <$> listType +type_ = TypeList <$> listType <|> TypeNonNull <$> nonNullType + <|> TypeNamed <$> namedType + "type_ error!" namedType :: Parser NamedType namedType = NamedType <$> name @@ -201,6 +211,7 @@ nonNullType :: Parser NonNullType nonNullType = NonNullTypeNamed <$> namedType <* tok "!" <|> NonNullTypeList <$> listType <* tok "!" + "nonNullType error!" -- * Type Definition @@ -221,7 +232,6 @@ <*> name <*> optempty interfaces <*> fieldDefinitions - "objectTypeDefinition error!" interfaces :: Parser Interfaces interfaces = tok "implements" *> many1 namedType @@ -237,17 +247,7 @@ <*> type_ argumentsDefinition :: Parser ArgumentsDefinition -argumentsDefinition = inputValueDefinitions - -inputValueDefinitions :: Parser [InputValueDefinition] -inputValueDefinitions = parens $ many1 inputValueDefinition - -inputValueDefinition :: Parser InputValueDefinition -inputValueDefinition = InputValueDefinition - <$> name - <* tok ":" - <*> type_ - <*> optional defaultValue +argumentsDefinition = parens $ many1 inputValueDefinition interfaceTypeDefinition :: Parser InterfaceTypeDefinition interfaceTypeDefinition = InterfaceTypeDefinition @@ -288,6 +288,16 @@ <*> 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 @@ -- ** WhiteSpace -- whiteSpace :: Parser () -whiteSpace = peekChar >>= \case - Just c -> if isSpace c || c == ',' - then anyChar *> whiteSpace - else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace - _ -> return () +whiteSpace = peekChar >>= traverse_ (\c -> + if isSpace c || c == ',' + then anyChar *> whiteSpace + else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -9,9 +9,11 @@ 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 @@ Suggestions, contributions and bug reports are welcome. -Feel free to contact me, jdnavarro, on the #haskell channel on the -[GraphQL Slack Server](https://graphql.slack.com). You can obtain an +Feel free to contact on Slack in [#haskell on +GraphQL](https://graphql.slack.com/messages/haskell/). You can obtain an invitation [here](https://graphql-slack.herokuapp.com/). diff --git a/graphql.cabal b/graphql.cabal --- a/graphql.cabal +++ b/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 @@ 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, - bytestring, - text, - attoparsec, + other-modules: Paths_graphql + build-depends: base >=4.6 && <5, + text >=0.11.3.1, + attoparsec >=0.10.4.0, tasty >=0.10, - tasty-golden, + tasty-hunit >=0.9, graphql source-repository head diff --git a/tests/data/kitchen-sink.graphql.golden b/tests/data/kitchen-sink.graphql.golden deleted file mode 100644 --- a/tests/data/kitchen-sink.graphql.golden +++ /dev/null @@ -1,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")]))] [] [])])] diff --git a/tests/data/kitchen-sink.min.graphql b/tests/data/kitchen-sink.min.graphql new file mode 100644 --- /dev/null +++ b/tests/data/kitchen-sink.min.graphql @@ -0,0 +1,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"})} diff --git a/tests/golden.hs b/tests/golden.hs deleted file mode 100644 --- a/tests/golden.hs +++ /dev/null @@ -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) diff --git a/tests/tasty.hs b/tests/tasty.hs new file mode 100644 --- /dev/null +++ b/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