graphql 0.2.1 → 0.3

raw patch · 10 files changed

+377/−97 lines, 10 filesdep +tasty-hunitdep −bytestringdep −tasty-goldendep ~attoparsecdep ~textPVP ok

version bump matches the API change (PVP)

Dependencies added: tasty-hunit

Dependencies removed: bytestring, tasty-golden

Dependency ranges changed: attoparsec, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−0
• Data/GraphQL/AST.hs +13/−9
• Data/GraphQL/Encoder.hs +246/−0
• Data/GraphQL/Parser.hs +58/−49
• README.md +5/−3
• graphql.cabal +11/−10
• tests/data/kitchen-sink.graphql.golden +0/−1
• tests/data/kitchen-sink.min.graphql +1/−0
• tests/golden.hs +0/−25
• tests/tasty.hs +28/−0

@@ -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

@@ -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) 

@@ -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

@@ -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)

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

@@ -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

@@ -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")]))] [] [])])]

@@ -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"})}

@@ -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)

@@ -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