aboutsummaryrefslogtreecommitdiff
path: root/Data/GraphQL
diff options
context:
space:
mode:
Diffstat (limited to 'Data/GraphQL')
-rw-r--r--Data/GraphQL/AST.hs22
-rw-r--r--Data/GraphQL/Encoder.hs246
-rw-r--r--Data/GraphQL/Parser.hs107
3 files changed, 317 insertions, 58 deletions
diff --git a/Data/GraphQL/AST.hs b/Data/GraphQL/AST.hs
index 0a09671..cc631e6 100644
--- 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,12 +16,12 @@ data Definition = DefinitionOperation OperationDefinition
| 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,15 +62,18 @@ type TypeCondition = NamedType
-- * 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)
newtype ObjectValue = ObjectValue [ObjectField] deriving (Eq,Show)
diff --git a/Data/GraphQL/Encoder.hs b/Data/GraphQL/Encoder.hs
new file mode 100644
index 0000000..9eed849
--- /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
index c999004..1f5b8e6 100644
--- 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 @@ import Data.Monoid (Monoid, mempty)
#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 @@ import Data.Attoparsec.Text
, 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 @@ document = whiteSpace
-- Try SelectionSet when no definition
<|> (Document . pure
. DefinitionOperation
- . Query mempty empty empty
+ . Query
+ . Node mempty empty empty
<$> selectionSet)
<?> "document error!"
@@ -60,14 +64,15 @@ definition = DefinitionOperation <$> operationDefinition
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,16 +153,24 @@ typeCondition = namedType
-- 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
@@ -170,10 +183,6 @@ 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]
@@ -188,9 +197,10 @@ directive = Directive
-- * 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 @@ listType = ListType <$> brackets type_
nonNullType :: Parser NonNullType
nonNullType = NonNullTypeNamed <$> namedType <* tok "!"
<|> NonNullTypeList <$> listType <* tok "!"
+ <?> "nonNullType error!"
-- * Type Definition
@@ -221,7 +232,6 @@ objectTypeDefinition = ObjectTypeDefinition
<*> name
<*> optempty interfaces
<*> fieldDefinitions
- <?> "objectTypeDefinition error!"
interfaces :: Parser Interfaces
interfaces = tok "implements" *> many1 namedType
@@ -237,17 +247,7 @@ fieldDefinition = FieldDefinition
<*> 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 @@ inputObjectTypeDefinition = InputObjectTypeDefinition
<*> 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 @@ 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 ()
+whiteSpace = peekChar >>= traverse_ (\c ->
+ if isSpace c || c == ','
+ then anyChar *> whiteSpace
+ else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace)
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 08:51:09 +0000