Rewrite the executor tree

src/Language/GraphQL/Executor.hs

@@ -12,7 +12,6 @@ module Language.GraphQL.Executor
    , QueryError(..)
    , Response(..)
    , Segment(..)
-   , coerceVariableValues
    , executeRequest
    ) where
 
@@ -21,10 +20,14 @@ import qualified Data.Aeson as Aeson
 import Data.Foldable (find)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
+import Data.Int (Int32)
+import Data.List.NonEmpty (NonEmpty)
+import Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Language.GraphQL.Execute.Coerce as Coerce
 import qualified Language.GraphQL.Type as Type
 import qualified Language.GraphQL.Type.Internal as Type.Internal
+import Language.GraphQL.Type.Schema (Schema)
 import qualified Language.GraphQL.Type.Schema as Schema
 
 data Segment = Segment String | Index Int
@@ -83,59 +86,198 @@ data Operation = Operation
     Full.OperationType
     (Maybe String)
     [Full.VariableDefinition]
-    Full.SelectionSet
+    SelectionSet
     Full.Location
 
-document :: Full.Document -> [Operation]
+type SelectionSet = NonEmpty Selection
+
+data Selection
+    = FieldSelection Field
+    | FragmentSpreadSelection FragmentSpread
+    | InlineFragmentSelection InlineFragment
+
+type SelectionSetOpt = [Selection]
+
+data Argument = Argument Full.Name (Full.Node Value) Full.Location
+
+data Field =
+    Field (Maybe Full.Name) Full.Name [Argument] [Directive] SelectionSetOpt Full.Location
+
+data InlineFragment = InlineFragment
+    (Maybe Full.TypeCondition) [Directive] SelectionSet Full.Location
+
+data FragmentSpread = FragmentSpread Full.Name [Directive] Full.Location
+
+data Value
+    = Variable Full.Name
+    | Int Int32
+    | Float Double
+    | String Text
+    | Boolean Bool
+    | Null
+    | Enum Full.Name
+    | List [Full.Node Value]
+    | Object [ObjectField]
+
+data ObjectField = ObjectField
+    { name :: Full.Name
+    , value :: Full.Node Value
+    , location :: Full.Location
+    }
+
+data Directive = Directive Full.Name [Argument] Full.Location
+
+document :: Full.Document -> [Full.OperationDefinition]
 document = foldr filterOperation []
   where
     filterOperation (Full.ExecutableDefinition executableDefinition) accumulator
         | Full.DefinitionOperation operationDefinition' <- executableDefinition =
-           operationDefinition operationDefinition' : accumulator
+           operationDefinition' : accumulator
     filterOperation _ accumulator = accumulator -- Fragment.
 
 operationDefinition :: Full.OperationDefinition -> Operation
 operationDefinition = \case
-    Full.OperationDefinition operationType operationName variables _ selectionSet operationLocation ->
+    Full.OperationDefinition operationType operationName variables _ selectionSet' operationLocation ->
         let maybeOperationName = Text.unpack <$> operationName
-         in Operation operationType maybeOperationName variables selectionSet operationLocation
+         in Operation
-    Full.SelectionSet selectionSet operationLocation ->
+            operationType
-        Operation Full.Query Nothing [] selectionSet operationLocation
+            maybeOperationName
+            variables
+            (selectionSet selectionSet')
+            operationLocation
+    Full.SelectionSet selectionSet' operationLocation ->
+        Operation Full.Query Nothing [] (selectionSet selectionSet') operationLocation
 
-executeRequest :: Type.Internal.Schema IO
+selectionSet :: Full.SelectionSet -> SelectionSet
+selectionSet = fmap selection
+
+selectionSetOpt :: Full.SelectionSetOpt -> SelectionSetOpt
+selectionSetOpt = fmap selection
+
+selection :: Full.Selection -> Selection
+selection (Full.FieldSelection field') = FieldSelection $ field field'
+selection (Full.FragmentSpreadSelection fragmentSpread') =
+    FragmentSpreadSelection $ fragmentSpread fragmentSpread'
+selection (Full.InlineFragmentSelection inlineFragment') =
+    InlineFragmentSelection $ inlineFragment inlineFragment'
+
+inlineFragment :: Full.InlineFragment -> InlineFragment
+inlineFragment (Full.InlineFragment typeCondition directives selectionSet' location) =
+    InlineFragment
+        typeCondition
+        (directive <$> directives)
+        (selectionSet selectionSet')
+        location
+
+fragmentSpread :: Full.FragmentSpread -> FragmentSpread
+fragmentSpread (Full.FragmentSpread name' directives location) =
+    FragmentSpread name' (directive <$> directives) location
+
+field :: Full.Field -> Field
+field (Full.Field alias' name' arguments' directives' selectionSet' location') =
+    Field
+        alias'
+        name'
+        (argument <$> arguments')
+        (directive <$> directives')
+        (selectionSetOpt selectionSet')
+        location'
+
+argument :: Full.Argument -> Argument
+argument (Full.Argument name' valueNode location') =
+    Argument name' (node valueNode) location'
+
+directive :: Full.Directive -> Directive
+directive (Full.Directive name' arguments location') =
+    Directive name' (argument <$> arguments) location'
+
+variableValue :: Full.Value -> Value
+variableValue (Full.Variable name') = Variable name'
+variableValue (Full.Int integer) = Int integer
+variableValue (Full.Float double) = Float double
+variableValue (Full.String string) = String string
+variableValue (Full.Boolean boolean) = Boolean boolean
+variableValue Full.Null = Null
+variableValue (Full.Enum enum) = Enum enum
+variableValue (Full.List list) = List $ node <$> list
+variableValue (Full.Object objectFields) = Object $ objectField <$> objectFields
+
+node :: Full.Node Full.Value -> Full.Node Value
+node Full.Node{node = node', ..} = Full.Node (variableValue node') location
+
+objectField :: Full.ObjectField Full.Value -> ObjectField
+objectField Full.ObjectField{..} = ObjectField
+    { name = name
+    , value = node value
+    , location = location
+    }
+
+executeRequest :: Schema IO
     -> Full.Document
     -> Maybe String
     -> Aeson.Object
     -> Aeson.Object
     -> IO Response
-executeRequest _schema sourceDocument operationName _variableValues _initialValue =
+executeRequest schema sourceDocument operationName variableValues initialValue =
-   let transformedDocument = document sourceDocument
+    case operationAndVariables of
-       operation = getOperation transformedDocument operationName
-    in case operation of
         Left queryError' -> pure $ respondWithQueryError queryError'
-        Right (Operation Full.Query _ _ _ _) -> executeQuery
+        Right (operation, coercedVariableValues')
-        Right (Operation Full.Mutation _ _ _ _) -> executeMutation
+            | Operation Full.Query _ _ _ _ <- operation ->
-        Right (Operation Full.Subscription _ _ _ _) -> subscribe
+                executeQuery operation schema coercedVariableValues' initialValue
+            | Operation Full.Mutation _ _ _ _ <- operation ->
+                executeMutation operation schema coercedVariableValues' initialValue
+            | Operation Full.Subscription _ _ _ _ <- operation ->
+                subscribe operation schema coercedVariableValues' initialValue
+  where
+    schemaTypes = Schema.types schema
+    transformedDocument = document sourceDocument
+    operationAndVariables = do
+        operation <- operationDefinition
+            <$> getOperation transformedDocument operationName
+        coercedVariableValues <- coerceVariableValues
+            schemaTypes
+            operation
+            variableValues
+        pure (operation, coercedVariableValues)
 
-getOperation :: [Operation] -> Maybe String -> Either QueryError Operation
+getOperation :: [Full.OperationDefinition] -> Maybe String -> Either QueryError Full.OperationDefinition
 getOperation [operation] Nothing = Right operation
 getOperation operations (Just givenOperationName)
     = maybe (Left $ OperationNotFound givenOperationName) Right
     $ find findOperationByName operations
   where
-    findOperationByName (Operation _ (Just operationName) _ _ _) =
+    findOperationByName (Full.OperationDefinition _ (Just operationName) _ _ _ _) =
-        givenOperationName == operationName
+        givenOperationName == Text.unpack operationName
     findOperationByName _ = False
 getOperation _ _ = Left OperationNameRequired
 
-executeQuery :: IO Response
+executeQuery :: forall m
-executeQuery = pure $ Response mempty mempty
+    . Operation
+    -> Schema m
+    -> Type.Subs
+    -> Aeson.Object
+    -> IO Response
+executeQuery _operation schema _coercedVariableValues _initialValue =
+    let _queryType = Schema.query schema
+     in pure $ Response mempty mempty
 
-executeMutation :: IO Response
+executeMutation :: forall m
-executeMutation = pure $ Response mempty mempty
+    . Operation
+    -> Schema m
+    -> Type.Subs
+    -> Aeson.Object
+    -> IO Response
+executeMutation _operation _schema _coercedVariableValues _initialValue =
+    pure $ Response mempty mempty
 
-subscribe :: IO Response
+subscribe :: forall m
-subscribe = pure $ Response mempty mempty
+    . Operation
+    -> Schema m
+    -> Type.Subs
+    -> Aeson.Object
+    -> IO Response
+subscribe _operation _schema _coercedVariableValues _initialValue =
+    pure $ Response mempty mempty
 
 coerceVariableValues :: Coerce.VariableValue a
     => forall m