From 56d88310df7c92a1721cc0dfa08a1d232c47c14b Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Thu, 26 Dec 2019 13:00:47 +0100
Subject: [PATCH] Add definition module

---
 CHANGELOG.md                                  |   9 +-
 src/Language/GraphQL/AST.hs                   |  15 +--
 src/Language/GraphQL/AST/DirectiveLocation.hs |  34 ++++++
 src/Language/GraphQL/AST/Document.hs          | 107 ++++++++++++++++++
 src/Language/GraphQL/AST/Encoder.hs           |  10 +-
 src/Language/GraphQL/AST/Parser.hs            |   5 +-
 src/Language/GraphQL/Execute.hs               |   6 +-
 src/Language/GraphQL/Execute/Transform.hs     |   8 +-
 8 files changed, 164 insertions(+), 30 deletions(-)
 create mode 100644 src/Language/GraphQL/AST/DirectiveLocation.hs
 create mode 100644 src/Language/GraphQL/AST/Document.hs

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 7d4a435..aab1a10 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -7,12 +7,13 @@ and this project adheres to
 [Haskell Package Versioning Policy](https://pvp.haskell.org/).
 
 ## [Unreleased]
+### Added
+- AST for the GraphQL schema.
+
 ### Changed
 - Rename `AST.Definition` into `AST.ExecutableDefinition`.
-  TypeSystemDefinition and TypeSystemExtension can also be definitions.
-- Define `AST.Definition` as
-  `newtype Definition = ExecutableDefinition ExecutableDefinition` for now. It
-  should be soon extended to contain missing definition types.
+  `AST.TypeSystemDefinition` and `AST.TypeSystemExtension` can also be
+  definitions.
 
 ### Removed
 - `AST.Field`, `AST.InlineFragment` and `AST.FragmentSpread`.
diff --git a/src/Language/GraphQL/AST.hs b/src/Language/GraphQL/AST.hs
index 537e870..06aeedf 100644
--- a/src/Language/GraphQL/AST.hs
+++ b/src/Language/GraphQL/AST.hs
@@ -5,10 +5,8 @@
 module Language.GraphQL.AST
     ( Alias
     , Argument(..)
-    , Definition(..)
-    , Directive(..)
-    , Document
     , ExecutableDefinition(..)
+    , Directive(..)
     , FragmentDefinition(..)
     , Name
     , NonNullType(..)
@@ -28,15 +26,6 @@ import Data.Int (Int32)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Text (Text)
 
--- * Document
-
--- | GraphQL document.
-type Document = NonEmpty Definition
-
--- | All kinds of definitions that can occur in a GraphQL document.
-newtype Definition = ExecutableDefinition ExecutableDefinition
-    deriving (Eq, Show)
-
 -- | Name
 type Name = Text
 
@@ -74,8 +63,6 @@ type SelectionSet = NonEmpty Selection
 -- | Field selection.
 type SelectionSetOpt = [Selection]
 
--- * Field
-
 -- | Single GraphQL field.
 --
 -- The only required property of a field is its name. Optionally it can also
diff --git a/src/Language/GraphQL/AST/DirectiveLocation.hs b/src/Language/GraphQL/AST/DirectiveLocation.hs
new file mode 100644
index 0000000..12c7e18
--- /dev/null
+++ b/src/Language/GraphQL/AST/DirectiveLocation.hs
@@ -0,0 +1,34 @@
+module Language.GraphQL.AST.DirectiveLocation
+    ( DirectiveLocation
+    , ExecutableDirectiveLocation
+    , TypeSystemDirectiveLocation
+    ) where
+
+data DirectiveLocation
+    = ExecutableDirectiveLocation ExecutableDirectiveLocation
+    | TypeSystemDirectiveLocation TypeSystemDirectiveLocation
+    deriving (Eq, Show)
+
+data ExecutableDirectiveLocation
+    = Query
+    | Mutation
+    | Subscription
+    | Field
+    | FragmentDefinition
+    | FragmentSpread
+    | InlineFragment
+    deriving (Eq, Show)
+
+data TypeSystemDirectiveLocation
+    = Schema
+    | Scalar
+    | Object
+    | FieldDefinition
+    | ArgumentDefinition
+    | Interface
+    | Union
+    | Enum
+    | EnumValue
+    | InputObject
+    | InputFieldDefinition
+    deriving (Eq, Show)
diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs
new file mode 100644
index 0000000..0350ce1
--- /dev/null
+++ b/src/Language/GraphQL/AST/Document.hs
@@ -0,0 +1,107 @@
+-- | This module defines data structures representing a GraphQL document.
+module Language.GraphQL.AST.Document
+    ( Definition(..)
+    , Document
+    , ExecutableDefinition(..)
+    ) where
+
+import Data.List.NonEmpty (NonEmpty)
+import Data.Text (Text)
+import Language.GraphQL.AST
+    ( ExecutableDefinition(..)
+    , Directive
+    , Name
+    , OperationType
+    , Type
+    , Value
+    )
+import Language.GraphQL.AST.DirectiveLocation
+
+-- | GraphQL document.
+type Document = NonEmpty Definition
+
+type NamedType = Name
+
+newtype Description = Description (Maybe Text)
+    deriving (Eq, Show)
+
+type RootOperationTypeDefinitions = NonEmpty RootOperationTypeDefinition
+
+data RootOperationTypeDefinition
+    = RootOperationTypeDefinition OperationType NamedType
+    deriving (Eq, Show)
+
+-- | All kinds of definitions that can occur in a GraphQL document.
+data Definition
+    = ExecutableDefinition ExecutableDefinition
+    | TypeSystemDefinition TypeSystemDefinition
+    | TypeSystemExtension TypeSystemExtension
+    deriving (Eq, Show)
+
+data TypeSystemDefinition
+    = SchemaDefinition [Directive] RootOperationTypeDefinitions
+    | TypeDefinition TypeDefinition
+    | DirectiveDefinition Description Name ArgumentsDefinition DirectiveLocation
+    deriving (Eq, Show)
+
+data SchemaExtension
+    = SchemaOperationExtension [Directive] RootOperationTypeDefinitions
+    | SchemaDirectiveExtension (NonEmpty Directive)
+    deriving (Eq, Show)
+
+data TypeSystemExtension
+    = SchemaExtension SchemaExtension
+    | TypeExtension TypeExtension
+    deriving (Eq, Show)
+
+newtype ImplementsInterfaces = ImplementsInterfaces (NonEmpty NamedType)
+    deriving (Eq, Show)
+newtype ImplementsInterfacesOpt = ImplementsInterfacesOpt [NamedType]
+    deriving (Eq, Show)
+
+newtype UnionMemberTypes = UnionMemberTypes (NonEmpty NamedType)
+    deriving (Eq, Show)
+newtype UnionMemberTypesOpt = UnionMemberTypesOpt [NamedType]
+    deriving (Eq, Show)
+
+newtype InputFieldsDefinition = InputFieldsDefinition (NonEmpty InputValueDefinition)
+    deriving (Eq, Show)
+newtype InputFieldsDefinitionOpt = InputFieldsDefinitionOpt [InputValueDefinition]
+    deriving (Eq, Show)
+
+data InputValueDefinition
+    = InputValueDefinition Description Name Type (Maybe Value) [Directive]
+    deriving (Eq, Show)
+
+newtype ArgumentsDefinition = ArgumentsDefinition [InputValueDefinition]
+    deriving (Eq, Show)
+
+data EnumValueDefinition = EnumValueDefinition Description Name [Directive]
+    deriving (Eq, Show)
+
+data FieldDefinition = FieldDefinition Description Name ArgumentsDefinition Type
+    deriving (Eq, Show)
+
+data TypeDefinition
+    = ScalarTypeDefinition Description Name [Directive]
+    | ObjectTypeDefinition Description Name ImplementsInterfacesOpt [Directive] [FieldDefinition]
+    | InterfaceTypeDefinition Description Name [Directive] [FieldDefinition]
+    | UnionTypeDefinition Description Name [Directive] UnionMemberTypesOpt
+    | EnumTypeDefinition Description Name [Directive] [EnumValueDefinition]
+    | InputObjectTypeDefinition Description Name [Directive] InputFieldsDefinitionOpt
+    deriving (Eq, Show)
+
+data TypeExtension
+    = ScalarTypeExtension Name (NonEmpty Directive)
+    | ObjectTypeFieldsDefinitionExtension Name ImplementsInterfacesOpt [Directive] (NonEmpty FieldDefinition)
+    | ObjectTypeDirectivesExtension Name ImplementsInterfacesOpt (NonEmpty Directive)
+    | ObjectTypeImplementsInterfacesExtension Name ImplementsInterfaces
+    | InterfaceTypeFieldsDefinitionExtension Name [Directive] (NonEmpty FieldDefinition)
+    | InterfaceTypeDirectivesExtension Name (NonEmpty Directive)
+    | UnionTypeUnionMemberTypesExtension Name [Directive] UnionMemberTypes
+    | UnionDirectivesExtension Name (NonEmpty Directive)
+    | EnumTypeEnumValuesDefinitionExtension Name [Directive] (NonEmpty EnumValueDefinition)
+    | EnumTypeDirectivesExtension Name (NonEmpty Directive)
+    | InputObjectTypeInputFieldsDefinitionExtension Name [Directive] InputFieldsDefinition
+    | InputObjectTypeDirectivesExtension Name (NonEmpty Directive)
+    deriving (Eq, Show)
diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs
index b7378dc..e33068d 100644
--- a/src/Language/GraphQL/AST/Encoder.hs
+++ b/src/Language/GraphQL/AST/Encoder.hs
@@ -26,6 +26,7 @@ import qualified Data.Text.Lazy.Builder as Builder
 import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
 import Data.Text.Lazy.Builder.RealFloat (realFloat)
 import qualified Language.GraphQL.AST as Full
+import Language.GraphQL.AST.Document
 
 -- | Instructs the encoder whether the GraphQL document should be minified or
 --   pretty printed.
@@ -43,17 +44,18 @@ pretty = Pretty 0
 minified :: Formatter
 minified = Minified
 
--- | Converts a 'Full.Document' into a string.
-document :: Formatter -> Full.Document -> Lazy.Text
+-- | Converts a Document' into a string.
+document :: Formatter -> Document -> Lazy.Text
 document formatter defs
     | Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument
     | Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
   where
     encodeDocument = foldr executableDefinition [] defs
-    executableDefinition (Full.ExecutableDefinition x) acc = definition formatter x : acc
+    executableDefinition (ExecutableDefinition x) acc = definition formatter x : acc
+    executableDefinition _ acc = acc
 
 -- | Converts a 'Full.Definition' into a string.
-definition :: Formatter -> Full.ExecutableDefinition -> Lazy.Text
+definition :: Formatter -> ExecutableDefinition -> Lazy.Text
 definition formatter x
     | Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
     | Minified <- formatter = encodeDefinition x
diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs
index dfe1d4a..ad2b96d 100644
--- a/src/Language/GraphQL/AST/Parser.hs
+++ b/src/Language/GraphQL/AST/Parser.hs
@@ -9,14 +9,15 @@ module Language.GraphQL.AST.Parser
 import Control.Applicative (Alternative(..), optional)
 import Data.List.NonEmpty (NonEmpty(..))
 import Language.GraphQL.AST
+import qualified Language.GraphQL.AST.Document as Document
 import Language.GraphQL.AST.Lexer
 import Text.Megaparsec (lookAhead, option, try, (<?>))
 
 -- | Parser for the GraphQL documents.
-document :: Parser Document
+document :: Parser Document.Document
 document = unicodeBOM
     >> spaceConsumer
-    >> lexeme (manyNE $ ExecutableDefinition <$> definition)
+    >> lexeme (manyNE $ Document.ExecutableDefinition <$> definition)
 
 definition :: Parser ExecutableDefinition
 definition = DefinitionOperation <$> operationDefinition
diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs
index 74f33f9..5278606 100644
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@@ -13,7 +13,7 @@ import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NE
 import Data.Text (Text)
 import qualified Data.Text as Text
-import qualified Language.GraphQL.AST as AST
+import Language.GraphQL.AST.Document
 import qualified Language.GraphQL.AST.Core as AST.Core
 import qualified Language.GraphQL.Execute.Transform as Transform
 import Language.GraphQL.Error
@@ -27,7 +27,7 @@ import qualified Language.GraphQL.Schema as Schema
 execute :: MonadIO m
     => NonEmpty (Schema.Resolver m) -- ^ Resolvers.
     -> Schema.Subs -- ^ Variable substitution function.
-    -> AST.Document -- @GraphQL@ document.
+    -> Document -- @GraphQL@ document.
     -> m Aeson.Value
 execute schema subs doc =
     maybe transformError (document schema Nothing) $ Transform.document subs doc
@@ -44,7 +44,7 @@ executeWithName :: MonadIO m
     => NonEmpty (Schema.Resolver m) -- ^ Resolvers
     -> Text -- ^ Operation name.
     -> Schema.Subs -- ^ Variable substitution function.
-    -> AST.Document -- ^ @GraphQL@ Document.
+    -> Document -- ^ @GraphQL@ Document.
     -> m Aeson.Value
 executeWithName schema name subs doc =
     maybe transformError (document schema $ Just name) $ Transform.document subs doc
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 8612381..28b9481 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -19,6 +19,7 @@ import qualified Data.List.NonEmpty as NonEmpty
 import Data.Sequence (Seq, (<|), (><))
 import qualified Language.GraphQL.AST as Full
 import qualified Language.GraphQL.AST.Core as Core
+import Language.GraphQL.AST.Document (Definition(..), Document)
 import qualified Language.GraphQL.Schema as Schema
 import qualified Language.GraphQL.Type.Directive as Directive
 
@@ -35,18 +36,19 @@ liftJust = lift . lift . Just
 
 -- | Rewrites the original syntax tree into an intermediate representation used
 -- for query execution.
-document :: Schema.Subs -> Full.Document -> Maybe Core.Document
+document :: Schema.Subs -> Document -> Maybe Core.Document
 document subs document' =
     flip runReaderT subs
         $ evalStateT (collectFragments >> operations operationDefinitions)
         $ Replacement HashMap.empty fragmentTable
   where
     (fragmentTable, operationDefinitions) = foldr defragment mempty document'
-    defragment (Full.ExecutableDefinition (Full.DefinitionOperation definition)) acc =
+    defragment (ExecutableDefinition (Full.DefinitionOperation definition)) acc =
         (definition :) <$> acc
-    defragment (Full.ExecutableDefinition (Full.DefinitionFragment definition)) acc =
+    defragment (ExecutableDefinition (Full.DefinitionFragment definition)) acc =
         let (Full.FragmentDefinition name _ _ _) = definition
          in first (HashMap.insert name definition) acc
+    defragment _ acc = acc
 
 -- * Operation