1 files changed, 57 insertions, 64 deletions

diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs
index fa8bf78..c678e48 100644
--- a/src/Language/GraphQL/Schema.hs
+++ b/src/Language/GraphQL/Schema.hs
@@ -3,28 +3,23 @@
 -- | 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
-    , objectA
-    , scalar
-    , scalarA
     , resolve
+    , resolversToMap
+    , scalar
     , wrappedObject
-    , wrappedObjectA
     , wrappedScalar
-    , wrappedScalarA
     -- * AST Reexports
     , Field
-    , Argument(..)
     , Value(..)
     ) where
 
-import Control.Monad.IO.Class (MonadIO(..))
 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,81 +33,80 @@ import Language.GraphQL.Trans
 import qualified Language.GraphQL.Type as Type
 
 -- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
---   information (if an error has occurred). @m@ is usually expected to be an
---   instance of 'MonadIO'.
+--   information (if an error has occurred). @m@ is an arbitrary monad, usually
+--   'IO'.
 data Resolver m = Resolver
     Text -- ^ Name
     (Field -> CollectErrsT m Aeson.Object) -- ^ Resolver
 
--- | Variable substitution function.
-type Subs = Name -> Maybe Value
+-- | 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
 
 -- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
-object :: MonadIO m => Name -> ActionT m [Resolver m] -> Resolver m
-object name = objectA name . const
-
--- | Like 'object' but also taking 'Argument's.
-objectA :: MonadIO m
-    => Name -> ([Argument] -> ActionT m [Resolver m]) -> Resolver m
-objectA name f = Resolver name $ resolveFieldValue f resolveRight
+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 also taking 'Argument's and can be null or a list of objects.
-wrappedObjectA :: MonadIO m
-    => Name -> ([Argument] -> ActionT m (Type.Wrapping [Resolver m])) -> Resolver m
-wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight
+-- | Like 'object' but can be null or a list of objects.
+wrappedObject ::
+    Monad m =>
+    Name ->
+    ActionT m (Type.Wrapping [Resolver m]) ->
+    Resolver m
+wrappedObject name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld@(Field _ _ _ sels) resolver
-        = withField (traverse (`resolve` sels) resolver) fld
-
--- | Like 'object' but can be null or a list of objects.
-wrappedObject :: MonadIO m
-    => Name -> ActionT m (Type.Wrapping [Resolver m]) -> Resolver m
-wrappedObject name = wrappedObjectA name . const
+        = withField (traverse (resolveMap sels) resolver) fld
+    resolveMap = flip (resolve . resolversToMap)
 
 -- | A scalar represents a primitive value, like a string or an integer.
-scalar :: (MonadIO m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
-scalar name = scalarA name . const
-
--- | Like 'scalar' but also taking 'Argument's.
-scalarA :: (MonadIO m, Aeson.ToJSON a)
-    => Name -> ([Argument] -> ActionT m a) -> Resolver m
-scalarA name f = Resolver name $ resolveFieldValue f resolveRight
+scalar :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
+scalar name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld result = withField (return result) fld
 
--- | Like 'scalar' but also taking 'Argument's and can be null or a list of scalars.
-wrappedScalarA :: (MonadIO m, Aeson.ToJSON a)
-    => Name -> ([Argument] -> ActionT m (Type.Wrapping a)) -> Resolver m
-wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight
+-- | Like 'scalar' but can be null or a list of scalars.
+wrappedScalar ::
+    (Monad m, Aeson.ToJSON a) =>
+    Name ->
+    ActionT m (Type.Wrapping a) ->
+    Resolver m
+wrappedScalar name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld (Type.Named result) = withField (return result) fld
     resolveRight fld Type.Null
         = return $ HashMap.singleton (aliasOrName fld) Aeson.Null
     resolveRight fld (Type.List result) = withField (return result) fld
 
--- | Like 'scalar' but can be null or a list of scalars.
-wrappedScalar :: (MonadIO m, Aeson.ToJSON a)
-    => Name -> ActionT m (Type.Wrapping a) -> Resolver m
-wrappedScalar name = wrappedScalarA name . const
-
-resolveFieldValue :: MonadIO m
-    => ([Argument] -> ActionT m a)
-    -> (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value))
-    -> Field
-    -> CollectErrsT m (HashMap Text Aeson.Value)
+resolveFieldValue ::
+    Monad m =>
+    ActionT m a ->
+    (Field -> a -> CollectErrsT m Aeson.Object) ->
+    Field ->
+    CollectErrsT m (HashMap Text Aeson.Value)
 resolveFieldValue f resolveRight fld@(Field _ _ args _) = do
-    result <- lift $ reader . runExceptT . runActionT $ f args
+    result <- lift $ reader . runExceptT . runActionT $ f
     either resolveLeft (resolveRight fld) result
       where
-        reader = flip runReaderT $ Context mempty
+        reader = flip runReaderT $ Context {arguments=args}
         resolveLeft err = do
             _ <- addErrMsg err
             return $ HashMap.singleton (aliasOrName fld) Aeson.Null
 
--- | Helper function to facilitate 'Argument' handling.
-withField :: (MonadIO m, Aeson.ToJSON a)
+-- | Helper function to facilitate error handling and result emitting.
+withField :: (Monad m, Aeson.ToJSON a)
     => CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value)
 withField v fld
     = HashMap.singleton (aliasOrName fld) . Aeson.toJSON <$> runAppendErrs v
@@ -120,23 +114,22 @@ withField v fld
 -- | 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 :: MonadIO m
-    => [Resolver m] -> Seq Selection -> CollectErrsT m Aeson.Value
+resolve :: Monad m
+    => 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