Propagate Maybe in the transform tree

Since the transform tree can already find some errors, it may fail here
and there. Almost all functions return a Maybe to signalize an error.
Will be replaced with an Either of course.

1 files changed, 52 insertions, 39 deletions

diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs
index 60b4f9c..107e1c6 100644
--- a/src/Language/GraphQL/AST/Transform.hs
+++ b/src/Language/GraphQL/AST/Transform.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 -- | After the document is parsed, before getting executed the AST is
 --   transformed into a similar, simpler AST. This module is responsible for
 --   this transformation.
@@ -12,26 +10,24 @@ import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as NonEmpty
-import Data.Maybe (fromMaybe)
 import qualified Language.GraphQL.AST as Full
 import qualified Language.GraphQL.AST.Core as Core
 import qualified Language.GraphQL.Schema as Schema
 
 -- | Associates a fragment name with a list of 'Core.Field's.
-type Fragments = HashMap Core.Name [Core.Field]
+type Fragments = HashMap Core.Name (NonEmpty Core.Field)
 
 -- | Rewrites the original syntax tree into an intermediate representation used
 -- for query execution.
 document :: Schema.Subs -> Full.Document -> Maybe Core.Document
-document subs doc = operations subs fragments operations'
+document subs doc =
+    case fragments of
+      Just fragments' -> operations subs fragments' operations'
+      Nothing -> Nothing
   where
-    (fragments, operations') = foldr (defrag subs) mempty
+    (fragments, operations') = foldr (defrag subs) (Just HashMap.empty, [])
         $ NonEmpty.toList doc
 
-extractFragment :: Fragments -> Core.Name -> [Core.Selection]
-extractFragment fragments name = Core.SelectionField
-    <$> fromMaybe mempty (HashMap.lookup name fragments)
-
 -- * Operation
 
 -- TODO: Replace Maybe by MonadThrow CustomError
@@ -53,27 +49,27 @@ operation subs fragments (Full.OperationSelectionSet sels) =
   operation subs fragments $ Full.OperationDefinition Full.Query mempty mempty mempty sels
 -- TODO: Validate Variable definitions with substituter
 operation subs fragments (Full.OperationDefinition Full.Query name _vars _dirs sels) =
-    pure $ Core.Query name $ appendSelection subs fragments sels
+    Core.Query name <$> appendSelection subs fragments sels
 operation subs fragments (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =
-    pure $ Core.Mutation name $ appendSelection subs fragments sels
+    Core.Mutation name <$> appendSelection subs fragments sels
 
 selection ::
     Schema.Subs ->
     Fragments ->
     Full.Selection ->
-    Either [Core.Selection] Core.Selection
+    Maybe (Either (NonEmpty Core.Selection) Core.Selection)
 selection subs fragments (Full.SelectionField fld)
-    = Right $ Core.SelectionField $ field subs fragments fld
+    = Right . Core.SelectionField <$> field subs fragments fld
 selection _ fragments (Full.SelectionFragmentSpread (Full.FragmentSpread name _))
-    = Left $ extractFragment fragments name
+    = Left . fmap Core.SelectionField <$> HashMap.lookup name fragments
 selection subs fragments (Full.SelectionInlineFragment fragment)
     | (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment
         = Right
-        $ Core.SelectionFragment
-        $ Core.Fragment typeCondition
-        $ appendSelection subs fragments selectionSet
+        . Core.SelectionFragment
+        . Core.Fragment typeCondition
+        <$> appendSelection subs fragments selectionSet
     | (Full.InlineFragment Nothing _ selectionSet) <- fragment
-        = Left $ NonEmpty.toList $ appendSelection subs fragments selectionSet
+        = Left <$> appendSelection subs fragments selectionSet
 
 -- * Fragment replacement
 
@@ -81,35 +77,37 @@ selection subs fragments (Full.SelectionInlineFragment fragment)
 defrag ::
     Schema.Subs ->
     Full.Definition ->
-    (Fragments, [Full.OperationDefinition]) ->
-    (Fragments, [Full.OperationDefinition])
+    (Maybe Fragments, [Full.OperationDefinition]) ->
+    (Maybe Fragments, [Full.OperationDefinition])
 defrag _ (Full.DefinitionOperation op) (fragments, operations') =
     (fragments, op : operations')
-defrag subs (Full.DefinitionFragment fragDef) (fragments, operations') =
+defrag subs (Full.DefinitionFragment fragDef) (Just fragments, operations') =
     (fragmentDefinition subs fragments fragDef, operations')
+defrag _ _ (Nothing, operations') =
+    (Nothing, operations')
 
 fragmentDefinition ::
     Schema.Subs ->
     Fragments ->
     Full.FragmentDefinition ->
-    Fragments
-fragmentDefinition subs fragments (Full.FragmentDefinition name _tc _dirs sels) =
-    HashMap.insert name (extractField <$> emitValue) fragments
+    Maybe Fragments
+fragmentDefinition subs fragments (Full.FragmentDefinition name _tc _dirs sels) = do
+    emitted <- emitValue
+    newValue <- traverse extractField emitted
+    Just $ HashMap.insert name newValue fragments
   where
+    emitValue :: Maybe (NonEmpty Core.Selection)
     emitValue = do
-        selections <- NonEmpty.toList $ selection subs mempty <$> sels
-        either id pure selections
-    extractField (Core.SelectionField field') = field'
-    extractField _ = error "Fragments within fragments are not supported yet"
+        selections <- traverse (selection subs fragments) sels
+        pure $ selections >>= either id pure
+    extractField :: Core.Selection -> Maybe Core.Field
+    extractField (Core.SelectionField field') = Just field'
+    extractField _ = Nothing -- Fragments within fragments are not supported yet
 
-field :: Schema.Subs -> Fragments -> Full.Field -> Core.Field
+field :: Schema.Subs -> Fragments -> Full.Field -> Maybe Core.Field
 field subs fragments (Full.Field a n args _dirs sels) =
-    Core.Field a n (fold $ argument subs `traverse` args) (foldr go mempty sels)
-  where
-    go :: Full.Selection -> [Core.Selection] -> [Core.Selection]
-    go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) =
-        (extractFragment fragments name <>)
-    go sel = (either id pure (selection subs fragments sel) <>)
+    Core.Field a n (fold $ argument subs `traverse` args)
+    <$> appendSelectionOpt subs fragments sels
 
 argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument
 argument subs (Full.Argument n v) = Core.Argument n <$> value subs v
@@ -130,10 +128,25 @@ value subs (Full.ValueObject   o) =
 objectField :: Schema.Subs -> Full.ObjectField -> Maybe Core.ObjectField
 objectField subs (Full.ObjectField n v) = Core.ObjectField n <$> value subs v
 
+appendSelectionOpt ::
+    Traversable t =>
+    Schema.Subs ->
+    Fragments ->
+    t Full.Selection ->
+    Maybe [Core.Selection]
+appendSelectionOpt subs fragments = foldr go (Just [])
+  where
+    go :: Full.Selection -> Maybe [Core.Selection] -> Maybe [Core.Selection]
+    go _ Nothing = Nothing
+    go sel (Just acc) = append acc <$> selection subs fragments sel
+    append acc (Left list) = NonEmpty.toList list <> acc
+    append acc (Right one) = one : acc
+
 appendSelection ::
     Schema.Subs ->
     Fragments ->
     NonEmpty Full.Selection ->
-    NonEmpty Core.Selection
-appendSelection subs fragments = NonEmpty.fromList
-    . foldr (either (++) (:) . selection subs fragments) []
+    Maybe (NonEmpty Core.Selection)
+appendSelection subs fragments fullSelection = do
+    coreSelection <-appendSelectionOpt subs fragments fullSelection
+    NonEmpty.nonEmpty coreSelection