Separate Query and Mutation resolvers

Fixes #33 .

3 files changed, 53 insertions, 31 deletions

diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs
index 57c8bf1..73f9bdc 100644
--- a/src/Language/GraphQL.hs
+++ b/src/Language/GraphQL.hs
@@ -6,7 +6,8 @@ module Language.GraphQL
 
 import qualified Data.Aeson as Aeson
 import Data.List.NonEmpty (NonEmpty)
-import qualified Data.Text as T
+import Data.HashMap.Strict (HashMap)
+import Data.Text (Text)
 import Language.GraphQL.Error
 import Language.GraphQL.Execute
 import Language.GraphQL.AST.Parser
@@ -16,8 +17,8 @@ import Text.Megaparsec (parse)
 -- | If the text parses correctly as a @GraphQL@ query the query is
 -- executed using the given 'Schema.Resolver's.
 graphql :: Monad m
-    => NonEmpty (Schema.Resolver m) -- ^ Resolvers.
-    -> T.Text -- ^ Text representing a @GraphQL@ request document.
+    => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
+    -> Text -- ^ Text representing a @GraphQL@ request document.
     -> m Aeson.Value -- ^ Response.
 graphql = flip graphqlSubs mempty
 
@@ -25,9 +26,9 @@ graphql = flip graphqlSubs mempty
 -- applied to the query and the query is then executed using to the given
 -- 'Schema.Resolver's.
 graphqlSubs :: Monad m
-    => NonEmpty (Schema.Resolver m) -- ^ Resolvers.
+    => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
     -> Schema.Subs -- ^ Variable substitution function.
-    -> T.Text -- ^ Text representing a @GraphQL@ request document.
+    -> Text -- ^ Text representing a @GraphQL@ request document.
     -> m Aeson.Value -- ^ Response.
 graphqlSubs schema f
     = either parseError (execute schema f)
diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs
index de937ee..204d08c 100644
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@@ -7,9 +7,10 @@ module Language.GraphQL.Execute
     ) where
 
 import qualified Data.Aeson as Aeson
-import Data.Foldable (toList)
 import Data.List.NonEmpty (NonEmpty(..))
-import qualified Data.List.NonEmpty as NE
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
 import Data.Text (Text)
 import qualified Data.Text as Text
 import Language.GraphQL.AST.Document
@@ -24,12 +25,13 @@ import qualified Language.GraphQL.Schema as Schema
 -- Returns the result of the query against the schema wrapped in a /data/
 -- field, or errors wrapped in an /errors/ field.
 execute :: Monad m
-    => NonEmpty (Schema.Resolver m) -- ^ Resolvers.
+    => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
     -> Schema.Subs -- ^ Variable substitution function.
     -> Document -- @GraphQL@ document.
     -> m Aeson.Value
 execute schema subs doc =
-    maybe transformError (document schema Nothing) $ Transform.document subs doc
+    maybe transformError (document schema Nothing)
+        $ Transform.document subs doc
   where
     transformError = return $ singleError "Schema transformation error."
 
@@ -40,23 +42,24 @@ execute schema subs doc =
 -- Returns the result of the query against the schema wrapped in a /data/
 -- field, or errors wrapped in an /errors/ field.
 executeWithName :: Monad m
-    => NonEmpty (Schema.Resolver m) -- ^ Resolvers
+    => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers
     -> Text -- ^ Operation name.
     -> Schema.Subs -- ^ Variable substitution function.
     -> Document -- ^ @GraphQL@ Document.
     -> m Aeson.Value
 executeWithName schema name subs doc =
-    maybe transformError (document schema $ Just name) $ Transform.document subs doc
+    maybe transformError (document schema $ Just name)
+        $ Transform.document subs doc
   where
     transformError = return $ singleError "Schema transformation error."
 
 document :: Monad m
-    => NonEmpty (Schema.Resolver m)
+    => HashMap Text (NonEmpty (Schema.Resolver m))
     -> Maybe Text
     -> AST.Core.Document
     -> m Aeson.Value
 document schema Nothing (op :| []) = operation schema op
-document schema (Just name) operations = case NE.dropWhile matchingName operations of
+document schema (Just name) operations = case NonEmpty.dropWhile matchingName operations of
     [] -> return $ singleError
         $ Text.unwords ["Operation", name, "couldn't be found in the document."]
     (op:_)  -> operation schema op
@@ -67,10 +70,17 @@ document schema (Just name) operations = case NE.dropWhile matchingName operatio
 document _ _ _ = return $ singleError "Missing operation name."
 
 operation :: Monad m
-    => NonEmpty (Schema.Resolver m)
+    => HashMap Text (NonEmpty (Schema.Resolver m))
     -> AST.Core.Operation
     -> m Aeson.Value
-operation schema (AST.Core.Query _ flds)
-    = runCollectErrs (Schema.resolve (toList schema) flds)
-operation schema (AST.Core.Mutation _ flds)
-    = runCollectErrs (Schema.resolve (toList schema) flds)
+operation schema = schemaOperation
+  where
+    runResolver fields = runCollectErrs
+        . flip Schema.resolve fields
+        . Schema.resolversToMap
+    resolve fields queryType = maybe lookupError (runResolver fields)
+        $ HashMap.lookup queryType schema
+    lookupError = pure
+        $ singleError "Root operation type couldn't be found in the schema."
+    schemaOperation (AST.Core.Query _ fields) = resolve fields "Query"
+    schemaOperation (AST.Core.Mutation _ fields) = resolve fields "Mutation"
diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs
index 8bde54d..c678e48 100644
--- a/src/Language/GraphQL/Schema.hs
+++ b/src/Language/GraphQL/Schema.hs
@@ -3,11 +3,12 @@
 -- | This module provides a representation of a @GraphQL@ Schema in addition to
 -- functions for defining and manipulating schemas.
 module Language.GraphQL.Schema
-    ( Resolver
+    ( Resolver(..)
     , Subs
     , object
-    , scalar
     , resolve
+    , resolversToMap
+    , scalar
     , wrappedObject
     , wrappedScalar
     -- * AST Reexports
@@ -18,7 +19,7 @@ module Language.GraphQL.Schema
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Except (runExceptT)
 import Control.Monad.Trans.Reader (runReaderT)
-import Data.Foldable (find, fold)
+import Data.Foldable (fold, toList)
 import Data.Maybe (fromMaybe)
 import qualified Data.Aeson as Aeson
 import Data.HashMap.Strict (HashMap)
@@ -38,6 +39,15 @@ data Resolver m = Resolver
     Text -- ^ Name
     (Field -> CollectErrsT m Aeson.Object) -- ^ Resolver
 
+-- | Converts resolvers to a map.
+resolversToMap
+    :: (Foldable f, Functor f)
+    => f (Resolver m)
+    -> HashMap Text (Field -> CollectErrsT m Aeson.Object)
+resolversToMap = HashMap.fromList . toList . fmap toKV
+  where
+    toKV (Resolver name f) = (name, f)
+
 -- | Contains variables for the query. The key of the map is a variable name,
 --   and the value is the variable value.
 type Subs = HashMap Name Value
@@ -46,7 +56,8 @@ type Subs = HashMap Name Value
 object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m
 object name f = Resolver name $ resolveFieldValue f resolveRight
   where
-    resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld
+    resolveRight fld@(Field _ _ _ flds) resolver
+        = withField (resolve (resolversToMap resolver) flds) fld
 
 -- | Like 'object' but can be null or a list of objects.
 wrappedObject ::
@@ -57,7 +68,8 @@ wrappedObject ::
 wrappedObject name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld@(Field _ _ _ sels) resolver
-        = withField (traverse (`resolve` sels) resolver) fld
+        = withField (traverse (resolveMap sels) resolver) fld
+    resolveMap = flip (resolve . resolversToMap)
 
 -- | A scalar represents a primitive value, like a string or an integer.
 scalar :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
@@ -81,7 +93,7 @@ wrappedScalar name f = Resolver name $ resolveFieldValue f resolveRight
 resolveFieldValue ::
     Monad m =>
     ActionT m a ->
-    (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value)) ->
+    (Field -> a -> CollectErrsT m Aeson.Object) ->
     Field ->
     CollectErrsT m (HashMap Text Aeson.Value)
 resolveFieldValue f resolveRight fld@(Field _ _ args _) = do
@@ -103,22 +115,21 @@ withField v fld
 --   'Resolver' to each 'Field'. Resolves into a value containing the
 --   resolved 'Field', or a null value and error information.
 resolve :: Monad m
-    => [Resolver m] -> Seq Selection -> CollectErrsT m Aeson.Value
+    => HashMap Text (Field -> CollectErrsT m Aeson.Object)
+    -> Seq Selection
+    -> CollectErrsT m Aeson.Value
 resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
   where
-    resolveTypeName (Resolver "__typename" f) = do
+    resolveTypeName f = do
         value <- f $ Field Nothing "__typename" mempty mempty
         return $ HashMap.lookupDefault "" "__typename" value
-    resolveTypeName _ = return ""
     tryResolvers (SelectionField fld@(Field _ name _ _))
-        = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers name) resolvers
+        = fromMaybe (errmsg fld) $ HashMap.lookup name resolvers <*> Just fld
     tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do
-        that <- traverse resolveTypeName (find (compareResolvers "__typename") resolvers)
+        that <- traverse resolveTypeName $ HashMap.lookup "__typename" resolvers
         if maybe True (Aeson.String typeCondition ==) that
             then fmap fold . traverse tryResolvers $ selections'
             else return mempty
-    compareResolvers name (Resolver name' _) = name == name'
-    tryResolver fld (Resolver _ resolver)  = resolver fld
     errmsg fld@(Field _ name _ _) = do
         addErrMsg $ T.unwords ["field", name, "not resolved."]
         return $ HashMap.singleton (aliasOrName fld) Aeson.Null