diff options
Diffstat (limited to 'Data')
| -rw-r--r-- | Data/GraphQL/AST.hs | 147 | ||||
| -rw-r--r-- | Data/GraphQL/Encoder.hs | 246 | ||||
| -rw-r--r-- | Data/GraphQL/Parser.hs | 336 |
3 files changed, 0 insertions, 729 deletions
diff --git a/Data/GraphQL/AST.hs b/Data/GraphQL/AST.hs deleted file mode 100644 index cc631e6..0000000 --- a/Data/GraphQL/AST.hs +++ /dev/null @@ -1,147 +0,0 @@ -module Data.GraphQL.AST where - -import Data.Int (Int32) -import Data.Text (Text) - --- * Name - -type Name = Text - --- * Document - -newtype Document = Document [Definition] deriving (Eq,Show) - -data Definition = DefinitionOperation OperationDefinition - | DefinitionFragment FragmentDefinition - | DefinitionType TypeDefinition - 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) - -newtype Variable = Variable Name deriving (Eq,Show) - -type SelectionSet = [Selection] - -data Selection = SelectionField Field - | SelectionFragmentSpread FragmentSpread - | SelectionInlineFragment InlineFragment - deriving (Eq,Show) - -data Field = Field Alias Name [Argument] - [Directive] - SelectionSet - deriving (Eq,Show) - -type Alias = Name - -data Argument = Argument Name Value deriving (Eq,Show) - --- * Fragments - -data FragmentSpread = FragmentSpread Name [Directive] - deriving (Eq,Show) - -data InlineFragment = - InlineFragment TypeCondition [Directive] SelectionSet - deriving (Eq,Show) - -data FragmentDefinition = - FragmentDefinition Name TypeCondition [Directive] SelectionSet - deriving (Eq,Show) - -type TypeCondition = NamedType - --- * Values - -data Value = ValueVariable Variable - | ValueInt Int32 - -- GraphQL Float is double precison - | 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) - -data ObjectField = ObjectField Name Value deriving (Eq,Show) - -type DefaultValue = Value - --- * Directives - -data Directive = Directive Name [Argument] deriving (Eq,Show) - --- * Type Reference - -data Type = TypeNamed NamedType - | TypeList ListType - | TypeNonNull NonNullType - deriving (Eq,Show) - -newtype NamedType = NamedType Name deriving (Eq,Show) - -newtype ListType = ListType Type deriving (Eq,Show) - -data NonNullType = NonNullTypeNamed NamedType - | NonNullTypeList ListType - deriving (Eq,Show) - --- * Type definition - -data TypeDefinition = TypeDefinitionObject ObjectTypeDefinition - | TypeDefinitionInterface InterfaceTypeDefinition - | TypeDefinitionUnion UnionTypeDefinition - | TypeDefinitionScalar ScalarTypeDefinition - | TypeDefinitionEnum EnumTypeDefinition - | TypeDefinitionInputObject InputObjectTypeDefinition - | TypeDefinitionTypeExtension TypeExtensionDefinition - deriving (Eq,Show) - -data ObjectTypeDefinition = ObjectTypeDefinition Name Interfaces [FieldDefinition] - deriving (Eq,Show) - -type Interfaces = [NamedType] - -data FieldDefinition = FieldDefinition Name ArgumentsDefinition Type - deriving (Eq,Show) - -type ArgumentsDefinition = [InputValueDefinition] - -data InputValueDefinition = InputValueDefinition Name Type (Maybe DefaultValue) - deriving (Eq,Show) - -data InterfaceTypeDefinition = InterfaceTypeDefinition Name [FieldDefinition] - deriving (Eq,Show) - -data UnionTypeDefinition = UnionTypeDefinition Name [NamedType] - deriving (Eq,Show) - -data ScalarTypeDefinition = ScalarTypeDefinition Name - deriving (Eq,Show) - -data EnumTypeDefinition = EnumTypeDefinition Name [EnumValueDefinition] - deriving (Eq,Show) - -newtype EnumValueDefinition = EnumValueDefinition Name - deriving (Eq,Show) - -data InputObjectTypeDefinition = InputObjectTypeDefinition Name [InputValueDefinition] - deriving (Eq,Show) - -newtype TypeExtensionDefinition = TypeExtensionDefinition ObjectTypeDefinition - deriving (Eq,Show) diff --git a/Data/GraphQL/Encoder.hs b/Data/GraphQL/Encoder.hs deleted file mode 100644 index 9eed849..0000000 --- a/Data/GraphQL/Encoder.hs +++ /dev/null @@ -1,246 +0,0 @@ -{-# 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 deleted file mode 100644 index 1f5b8e6..0000000 --- a/Data/GraphQL/Parser.hs +++ /dev/null @@ -1,336 +0,0 @@ -{-# 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) |