From f4ed06741dedb7b19cedc09b1c47afe1f0849f24 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Tue, 7 Jan 2020 13:56:58 +0100 Subject: [PATCH] Parse union definitions --- src/Language/GraphQL/AST/Document.hs | 56 +++++++++++++++--------- src/Language/GraphQL/AST/Parser.hs | 40 ++++++++++++----- tests/Language/GraphQL/AST/ParserSpec.hs | 5 +++ 3 files changed, 69 insertions(+), 32 deletions(-) diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index 619a6f3..74c6ce2 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | This module defines an abstract syntax tree for the @GraphQL@ language. It -- follows closely the structure given in the specification. Please refer to -- . @@ -14,9 +16,9 @@ module Language.GraphQL.AST.Document , FieldDefinition(..) , FragmentDefinition(..) , ImplementsInterfaces(..) - , ImplementsInterfacesOpt(..) , InputValueDefinition(..) , Name + , NamedType , NonNullType(..) , ObjectField(..) , OperationDefinition(..) @@ -29,14 +31,18 @@ module Language.GraphQL.AST.Document , Type(..) , TypeCondition , TypeDefinition(..) + , TypeExtension(..) , TypeSystemDefinition(..) + , UnionMemberTypes(..) , Value(..) , VariableDefinition(..) ) where +import Data.Foldable (toList) import Data.Int (Int32) import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) +import qualified Data.Text as Text import Language.GraphQL.AST.DirectiveLocation -- * Language @@ -274,9 +280,13 @@ newtype Description = Description (Maybe Text) data TypeDefinition = ScalarTypeDefinition Description Name [Directive] | ObjectTypeDefinition - Description Name ImplementsInterfacesOpt [Directive] [FieldDefinition] + Description + Name + (ImplementsInterfaces []) + [Directive] + [FieldDefinition] | InterfaceTypeDefinition Description Name [Directive] [FieldDefinition] - | UnionTypeDefinition Description Name [Directive] UnionMemberTypesOpt + | UnionTypeDefinition Description Name [Directive] (UnionMemberTypes []) | EnumTypeDefinition Description Name [Directive] [EnumValueDefinition] | InputObjectTypeDefinition Description Name [Directive] InputFieldsDefinitionOpt @@ -285,14 +295,16 @@ data TypeDefinition data TypeExtension = ScalarTypeExtension Name (NonEmpty Directive) | ObjectTypeFieldsDefinitionExtension - Name ImplementsInterfacesOpt [Directive] (NonEmpty FieldDefinition) + Name (ImplementsInterfaces []) [Directive] (NonEmpty FieldDefinition) | ObjectTypeDirectivesExtension - Name ImplementsInterfacesOpt (NonEmpty Directive) - | ObjectTypeImplementsInterfacesExtension Name ImplementsInterfaces + Name (ImplementsInterfaces []) (NonEmpty Directive) + | ObjectTypeImplementsInterfacesExtension + Name (ImplementsInterfaces NonEmpty) | InterfaceTypeFieldsDefinitionExtension Name [Directive] (NonEmpty FieldDefinition) | InterfaceTypeDirectivesExtension Name (NonEmpty Directive) - | UnionTypeUnionMemberTypesExtension Name [Directive] UnionMemberTypes + | UnionTypeUnionMemberTypesExtension + Name [Directive] (UnionMemberTypes NonEmpty) | UnionDirectivesExtension Name (NonEmpty Directive) | EnumTypeEnumValuesDefinitionExtension Name [Directive] (NonEmpty EnumValueDefinition) @@ -304,17 +316,17 @@ data TypeExtension -- ** Objects -newtype ImplementsInterfaces = ImplementsInterfaces (NonEmpty NamedType) - deriving (Eq, Show) -newtype ImplementsInterfacesOpt = ImplementsInterfacesOpt [NamedType] - deriving (Eq, Show) +newtype ImplementsInterfaces t = ImplementsInterfaces (t NamedType) -instance Semigroup ImplementsInterfacesOpt where - (ImplementsInterfacesOpt xs) <> (ImplementsInterfacesOpt ys) = - ImplementsInterfacesOpt $ xs <> ys +instance Foldable t => Eq (ImplementsInterfaces t) where + (ImplementsInterfaces xs) == (ImplementsInterfaces ys) + = toList xs == toList ys -instance Monoid ImplementsInterfacesOpt where - mempty = ImplementsInterfacesOpt [] +instance Foldable t => Show (ImplementsInterfaces t) where + show (ImplementsInterfaces interfaces) = Text.unpack + $ Text.append "implements" + $ Text.intercalate " & " + $ toList interfaces data FieldDefinition = FieldDefinition Description Name ArgumentsDefinition Type [Directive] @@ -336,11 +348,15 @@ data InputValueDefinition -- ** Unions -newtype UnionMemberTypes = UnionMemberTypes (NonEmpty NamedType) - deriving (Eq, Show) +newtype UnionMemberTypes t = UnionMemberTypes (t NamedType) -newtype UnionMemberTypesOpt = UnionMemberTypesOpt [NamedType] - deriving (Eq, Show) +instance Foldable t => Eq (UnionMemberTypes t) where + (UnionMemberTypes xs) == (UnionMemberTypes ys) = toList xs == toList ys + +instance Foldable t => Show (UnionMemberTypes t) where + show (UnionMemberTypes memberTypes) = Text.unpack + $ Text.intercalate " | " + $ toList memberTypes -- ** Enums diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index a851a66..274045d 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -8,7 +8,8 @@ module Language.GraphQL.AST.Parser import Control.Applicative (Alternative(..), optional) import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty -import Control.Applicative.Combinators (sepBy) +import Control.Applicative.Combinators (sepBy, sepBy1) +import Data.Text (Text) import Language.GraphQL.AST.Document import Language.GraphQL.AST.Lexer import Text.Megaparsec (lookAhead, option, try, ()) @@ -37,6 +38,7 @@ typeSystemDefinition = schemaDefinition typeDefinition :: Parser TypeDefinition typeDefinition = scalarTypeDefinition <|> objectTypeDefinition + <|> unionTypeDefinition "TypeDefinition" scalarTypeDefinition :: Parser TypeDefinition @@ -52,7 +54,7 @@ objectTypeDefinition = ObjectTypeDefinition <$> description <* symbol "type" <*> name - <*> opt implementsInterfacesOpt + <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1) <*> opt directives <*> braces (many fieldDefinition) "ObjectTypeDefinition" @@ -62,19 +64,33 @@ description = Description <$> optional (string <|> blockString) "Description" -{- TODO: - implementsInterfaces :: Parser ImplementsInterfaces -implementsInterfaces = ImplementsInterfaces - <$ symbol "implements" - <* optional amp - <*> name `sepBy1` amp - "ImplementsInterfaces" -} +unionTypeDefinition :: Parser TypeDefinition +unionTypeDefinition = UnionTypeDefinition + <$> description + <* symbol "union" + <*> name + <*> opt directives + <*> option (UnionMemberTypes []) (unionMemberTypes sepBy1) + "UnionTypeDefinition" -implementsInterfacesOpt :: Parser ImplementsInterfacesOpt -implementsInterfacesOpt = ImplementsInterfacesOpt +unionMemberTypes :: + Foldable t => + (Parser Text -> Parser Text -> Parser (t NamedType)) -> + Parser (UnionMemberTypes t) +unionMemberTypes sepBy' = UnionMemberTypes + <$ equals + <* optional pipe + <*> name `sepBy'` pipe + "UnionMemberTypes" + +implementsInterfaces :: + Foldable t => + (Parser Text -> Parser Text -> Parser (t NamedType)) -> + Parser (ImplementsInterfaces t) +implementsInterfaces sepBy' = ImplementsInterfaces <$ symbol "implements" <* optional amp - <*> name `sepBy` amp + <*> name `sepBy'` amp "ImplementsInterfaces" inputValueDefinition :: Parser InputValueDefinition diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs index 8d6b576..e1b48d8 100644 --- a/tests/Language/GraphQL/AST/ParserSpec.hs +++ b/tests/Language/GraphQL/AST/ParserSpec.hs @@ -69,3 +69,8 @@ spec = describe "Parser" $ do name(first: String, last: String): String } |] + + it "parses minimal union type definition" $ + parse document "" `shouldSucceedOn` [r| + union SearchResult = Photo | Person + |]