Restore error handling

3 files changed, 35 insertions, 34 deletions

diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs
index 3d60bef..b227ce2 100644
--- a/Data/GraphQL/Execute.hs
+++ b/Data/GraphQL/Execute.hs
@@ -4,12 +4,10 @@
 module Data.GraphQL.Execute (execute) where
 
 import Control.Applicative (Alternative, empty)
+import Data.GraphQL.Error
 import qualified Data.List.NonEmpty as NE
 import Data.List.NonEmpty (NonEmpty((:|)))
-
 import qualified Data.Aeson as Aeson
-import qualified Data.HashMap.Strict as HashMap
-
 import qualified Data.GraphQL.AST as AST
 import qualified Data.GraphQL.AST.Core as AST.Core
 import qualified Data.GraphQL.AST.Transform as Transform
@@ -33,8 +31,6 @@ document _ _ = error "Multiple operations not supported yet"
 
 operation :: Alternative f => Schema f -> AST.Core.Operation -> f Aeson.Value
 operation schema (AST.Core.Query flds)
-    = Aeson.Object . HashMap.singleton "data"
-    <$> Schema.resolve (NE.toList schema) (NE.toList flds)
+    = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))
 operation schema (AST.Core.Mutation flds)
-    = Aeson.Object . HashMap.singleton "data"
-    <$> Schema.resolve (NE.toList schema) (NE.toList flds)
+    = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))
diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs
index e451981..a63750d 100644
--- a/Data/GraphQL/Schema.hs
+++ b/Data/GraphQL/Schema.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE LambdaCase #-}
 -- | This module provides a representation of a @GraphQL@ Schema in addition to
 --   functions for defining and manipulating Schemas.
@@ -25,15 +26,16 @@ module Data.GraphQL.Schema
   ) where
 
 import Control.Applicative (Alternative(empty), (<|>))
+import Data.Bifunctor (first)
 import Data.Foldable (fold)
+import Data.GraphQL.Error
 import Data.List.NonEmpty (NonEmpty)
 import Data.Maybe (fromMaybe)
 import Data.Monoid (Alt(Alt,getAlt))
-
 import qualified Data.Aeson as Aeson
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
-import Data.Text (Text)
+import qualified Data.Text as T
 
 import Data.GraphQL.AST.Core
 
@@ -43,7 +45,7 @@ type Schema f = NonEmpty (Resolver f)
 
 -- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information
 --   (or 'empty'). @f@ is usually expected to be an instance of 'Alternative'.
-type Resolver f = Field -> f Aeson.Object
+type Resolver f = Field -> CollectErrsT f Aeson.Object
 
 type Resolvers f = [Resolver f]
 
@@ -68,7 +70,7 @@ objectA name f fld@(Field _ _ args flds) = withField name (resolve (f args) flds
 
 
 -- | Create a named 'Resolver' from a list of 'Resolver's.
-object' :: (Alternative f, Monad f) => Text -> f [Resolver f] -> Resolver f
+object' :: (Alternative f, Monad f) => T.Text -> f [Resolver f] -> Resolver f
 object' name resolvs = objectA' name $ \case
      [] -> resolvs
      _  -> empty
@@ -76,7 +78,7 @@ object' name resolvs = objectA' name $ \case
 -- | Like 'object'' but also taking 'Argument's.
 objectA'
   :: (Alternative f, Monad f)
-  => Text -> ([Argument] -> f [Resolver f]) -> Resolver f
+  => T.Text -> ([Argument] -> f [Resolver f]) -> Resolver f
 objectA' name f fld@(Field _ _ args flds) = do
     resolvs <- f args
     withField name (resolve resolvs flds) fld
@@ -92,7 +94,7 @@ scalar name s = scalarA name $ \case
 scalarA
   :: (Alternative f, Aeson.ToJSON a)
   => Name -> (Arguments -> f a) -> Resolver f
-scalarA name f fld@(Field _ _ args []) = withField name (f args) fld
+scalarA name f fld@(Field _ _ args []) = withField name (errWrap $ f args) fld
 scalarA _ _ _ = empty
 
 array :: Alternative f => Name -> [Resolvers f] -> Resolver f
@@ -103,12 +105,12 @@ array name resolvers = arrayA name $ \case
 -- | Like 'array' but also taking 'Argument's.
 arrayA
   :: Alternative f
-  => Text -> (Arguments -> [Resolvers f]) -> Resolver f
+  => T.Text -> (Arguments -> [Resolvers f]) -> Resolver f
 arrayA name f fld@(Field _ _ args sels) =
-     withField name (traverse (`resolve` sels) $ f args) fld
+     withField name (joinErrs $ traverse (`resolve` sels) $ f args) fld
 
 -- | Like 'object'' but taking lists of 'Resolver's instead of a single list.
-array' :: (Alternative f, Monad f) => Text -> f [[Resolver f]] -> Resolver f
+array' :: (Alternative f, Monad f) => T.Text -> f [[Resolver f]] -> Resolver f
 array' name resolvs = arrayA' name $ \case
     [] -> resolvs
     _  -> empty
@@ -116,40 +118,46 @@ array' name resolvs = arrayA' name $ \case
 -- | Like 'array'' but also taking 'Argument's.
 arrayA'
   :: (Alternative f, Monad f)
-  => Text -> ([Argument] -> f [[Resolver f]]) -> Resolver f
+  => T.Text -> ([Argument] -> f [[Resolver f]]) -> Resolver f
 arrayA' name f fld@(Field _ _ args sels) = do
      resolvs <- f args
-     withField name (traverse (`resolve` sels) resolvs) fld
+     withField name (joinErrs $ traverse (`resolve` sels) resolvs) fld
 
 -- | Represents one of a finite set of possible values.
 --   Used in place of a 'scalar' when the possible responses are easily enumerable.
-enum :: Alternative f => Text -> f [Text] -> Resolver f
+enum :: Alternative f => T.Text -> f [T.Text] -> Resolver f
 enum name enums = enumA name $ \case
      [] -> enums
      _  -> empty
 
 -- | Like 'enum' but also taking 'Argument's.
-enumA :: Alternative f => Text -> ([Argument] -> f [Text]) -> Resolver f
-enumA name f fld@(Field _ _ args []) = withField name (f args) fld
+enumA :: Alternative f => T.Text -> ([Argument] -> f [T.Text]) -> Resolver f
+enumA name f fld@(Field _ _ args []) = withField name (errWrap $ f args) fld
 enumA _ _ _ = empty
 
 -- | Helper function to facilitate 'Argument' handling.
 withField
   :: (Alternative f, Aeson.ToJSON a)
-  => Name -> f a -> Field -> f (HashMap Text Aeson.Value)
-withField name v (Field alias name' _ _) =
-  if name == name'
-    then fmap (HashMap.singleton aliasOrName . Aeson.toJSON) v
-         -- TODO: Report error when Non-Nullable type for field argument.
-     <|> pure (HashMap.singleton aliasOrName Aeson.Null)
-    else empty
+  => Name -> CollectErrsT f a -> Field -> CollectErrsT f (HashMap T.Text Aeson.Value)
+withField name v (Field alias name' _ _)
+    | name == name' = fmap getValue v
+    | otherwise = empty
   where
     aliasOrName = fromMaybe name alias
+    getValue (x, []) = (HashMap.singleton aliasOrName $ Aeson.toJSON x, [])
+         -- TODO: Report error when Non-Nullable type for field argument.
+    getValue (_, _) = (HashMap.singleton aliasOrName Aeson.Null, [])
 
 -- | Takes a list of 'Resolver's and a list of 'Field's and applies each
 --   'Resolver' to each 'Field'. Resolves into a value containing the
 --   resolved 'Field', or a null value and error information.
-resolve :: Alternative f => Resolvers f -> Fields -> f Aeson.Value
+resolve :: Alternative f => Resolvers f -> Fields -> CollectErrsT f Aeson.Value
 resolve resolvers =
-    fmap (Aeson.toJSON . fold)
-  . traverse (\fld -> getAlt (foldMap (Alt . ($ fld)) resolvers))
+    fmap (first Aeson.toJSON . fold)
+  . traverse (\fld -> getAlt (foldMap (Alt . ($ fld)) resolvers) <|> errmsg fld)
+  where
+    errmsg (Field alias name _ _) = addErrMsg msg $ (errWrap . pure) val
+      where
+        val = HashMap.singleton aliasOrName Aeson.Null
+        msg = T.unwords ["field", name, "not resolved."]
+        aliasOrName = fromMaybe name alias
diff --git a/tests/Test/StarWars/QueryTests.hs b/tests/Test/StarWars/QueryTests.hs
index 3dd6075..736f5b4 100644
--- a/tests/Test/StarWars/QueryTests.hs
+++ b/tests/Test/StarWars/QueryTests.hs
@@ -149,9 +149,6 @@ test = testGroup "Star Wars Query Tests"
                 name
               }
             }
-        -- The GraphQL spec specifies that an error should be reported when the
-        -- type of the argument is Non-Nullable. However the equivalent test in
-        -- `graphql-js` doesn't check for any errors.
         |] $ object ["data" .= object ["human" .= Aeson.Null]]
     , testCase "Luke aliased" . testQuery
         [r| query FetchLukeAliased {