1 files changed, 45 insertions, 62 deletions
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 882b324..5a9eef8 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -11,7 +11,7 @@ module Language.GraphQL.Execute.Transform
 import Control.Arrow (first)
 import Control.Monad (foldM, unless)
 import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
+import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
 import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
@@ -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.DefinitionOperation definition) acc =
+    defragment (ExecutableDefinition (Full.DefinitionOperation definition)) acc =
         (definition :) <$> acc
-    defragment (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
 
@@ -56,26 +58,47 @@ operations operations' = do
     lift . lift $ NonEmpty.nonEmpty coreOperations
 
 operation :: Full.OperationDefinition -> TransformT Core.Operation
-operation (Full.OperationSelectionSet sels) =
-    operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels
--- TODO: Validate Variable definitions with substituter
-operation (Full.OperationDefinition Full.Query name _vars _dirs sels) =
-    Core.Query name <$> appendSelection sels
-operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =
-    Core.Mutation name <$> appendSelection sels
+operation (Full.SelectionSet sels)
+    = operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels
+operation (Full.OperationDefinition Full.Query name _vars _dirs sels)
+    = Core.Query name <$> appendSelection sels
+operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels)
+    = Core.Mutation name <$> appendSelection sels
 
 -- * Selection
 
 selection ::
     Full.Selection ->
     TransformT (Either (Seq Core.Selection) Core.Selection)
-selection (Full.SelectionField field') =
-    maybe (Left mempty) (Right . Core.SelectionField) <$> field field'
-selection (Full.SelectionFragmentSpread fragment) =
-    maybe (Left mempty) (Right . Core.SelectionFragment)
-    <$> fragmentSpread fragment
-selection (Full.SelectionInlineFragment fragment) =
-    inlineFragment fragment
+selection (Full.Field alias name arguments' directives' selections) =
+    maybe (Left mempty) (Right . Core.SelectionField) <$> do
+        fieldArguments <- arguments arguments'
+        fieldSelections <- appendSelection selections
+        fieldDirectives <- Directive.selection <$> directives directives'
+        let field' = Core.Field alias name fieldArguments fieldSelections
+        pure $ field' <$ fieldDirectives
+selection (Full.FragmentSpread name directives') =
+    maybe (Left mempty) (Right . Core.SelectionFragment) <$> do
+        spreadDirectives <- Directive.selection <$> directives directives'
+        fragments' <- gets fragments
+        fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments')
+        pure $ fragment <$ spreadDirectives
+  where
+    lookupDefinition = do
+        fragmentDefinitions' <- gets fragmentDefinitions
+        found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
+        fragmentDefinition found
+selection (Full.InlineFragment type' directives' selections) = do
+    fragmentDirectives <- Directive.selection <$> directives directives'
+    case fragmentDirectives of
+        Nothing -> pure $ Left mempty
+        _ -> do
+            fragmentSelectionSet <- appendSelection selections
+            pure $ maybe Left selectionFragment type' fragmentSelectionSet
+  where
+    selectionFragment typeName = Right
+        . Core.SelectionFragment
+        . Core.Fragment typeName
 
 appendSelection ::
     Traversable t =>
@@ -104,33 +127,6 @@ collectFragments = do
         _ <- fragmentDefinition nextValue
         collectFragments
 
-inlineFragment ::
-    Full.InlineFragment ->
-    TransformT (Either (Seq Core.Selection) Core.Selection)
-inlineFragment (Full.InlineFragment type' directives' selectionSet) = do
-    fragmentDirectives <- Directive.selection <$> directives directives'
-    case fragmentDirectives of
-        Nothing -> pure $ Left mempty
-        _ -> do
-            fragmentSelectionSet <- appendSelection selectionSet
-            pure $ maybe Left selectionFragment type' fragmentSelectionSet
-  where
-    selectionFragment typeName = Right
-        . Core.SelectionFragment
-        . Core.Fragment typeName
-
-fragmentSpread :: Full.FragmentSpread -> TransformT (Maybe Core.Fragment)
-fragmentSpread (Full.FragmentSpread name directives') = do
-    spreadDirectives <- Directive.selection <$> directives directives'
-    fragments' <- gets fragments
-    fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments')
-    pure $ fragment <$ spreadDirectives 
-  where
-    lookupDefinition = do
-        fragmentDefinitions' <- gets fragmentDefinitions
-        found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
-        fragmentDefinition found
-
 fragmentDefinition ::
     Full.FragmentDefinition ->
     TransformT Core.Fragment
@@ -147,28 +143,15 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
         let newFragments = HashMap.insert name newValue fragments'
          in Replacement newFragments fragmentDefinitions'
 
-field :: Full.Field -> TransformT (Maybe Core.Field)
-field (Full.Field alias name arguments' directives' selections) = do
-    fieldArguments <- traverse argument arguments'
-    fieldSelections <- appendSelection selections
-    fieldDirectives <- Directive.selection <$> directives directives'
-    let field' = Core.Field alias name fieldArguments fieldSelections
-    pure $ field' <$ fieldDirectives
-
 arguments :: [Full.Argument] -> TransformT Core.Arguments
 arguments = fmap Core.Arguments . foldM go HashMap.empty
   where
-    go arguments' argument' = do
-        (Core.Argument name value') <- argument argument'
-        return $ HashMap.insert name value' arguments'
-
-argument :: Full.Argument -> TransformT Core.Argument
-argument (Full.Argument n v) = Core.Argument n <$> value v
+    go arguments' (Full.Argument name value') = do
+        substitutedValue <- value value'
+        return $ HashMap.insert name substitutedValue arguments'
 
 value :: Full.Value -> TransformT Core.Value
-value (Full.Variable n) = do
-    substitute' <- lift ask
-    lift . lift $ substitute' n
+value (Full.Variable name) = lift (asks $ HashMap.lookup name) >>= lift . lift
 value (Full.Int i) = pure $ Core.Int i
 value (Full.Float f) = pure $ Core.Float f
 value (Full.String x) = pure $ Core.String x