Check point

1 files changed, 37 insertions, 50 deletions

diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs
index 69f697e..34abf10 100644
--- a/src/Language/GraphQL/Schema.hs
+++ b/src/Language/GraphQL/Schema.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 -- | This module provides a representation of a @GraphQL@ Schema in addition to
@@ -8,10 +9,6 @@ module Language.GraphQL.Schema
     , object
     , resolve
     , resolversToMap
-    , wrappedObject
-    -- * AST Reexports
-    , Field
-    , Value(..)
     ) where
 
 import Control.Monad.Trans.Class (lift)
@@ -28,38 +25,35 @@ import qualified Data.Text as T
 import Language.GraphQL.AST.Core
 import Language.GraphQL.Error
 import Language.GraphQL.Trans
-import qualified Language.GraphQL.Type.Definition as Definition
-import qualified Language.GraphQL.Type as Type
+import qualified Language.GraphQL.Type.In as In
+import qualified Language.GraphQL.Type.Out as Out
 
 -- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
---   information (if an error has occurred). @m@ is an arbitrary monad, usually
---   'IO'.
-data Resolver m = Resolver Name (Definition.FieldResolver m)
+-- information (if an error has occurred). @m@ is an arbitrary monad, usually
+-- 'IO'.
+--
+-- Resolving a field can result in a leaf value or an object, which is
+-- represented as a list of nested resolvers, used to resolve the fields of that
+-- object.
+data Resolver m = Resolver Name (ActionT m (Out.Value m))
 
 -- | Converts resolvers to a map.
 resolversToMap :: (Foldable f, Functor f)
-    => f (Resolver m)
-    -> HashMap Text (Definition.FieldResolver m)
+    => forall m
+    . f (Resolver m)
+    -> HashMap Text (ActionT m (Out.Value m))
 resolversToMap = HashMap.fromList . toList . fmap toKV
   where
     toKV (Resolver name r) = (name, r)
 
 -- | 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
+type Subs = HashMap Name In.Value
 
--- | Like 'object' but can be null or a list of objects.
-wrappedObject :: Monad m
-    => Name
-    -> ActionT m (Type.Wrapping (Definition.FieldResolver m))
-    -> Resolver m
-wrappedObject name = Resolver name . Definition.NestingResolver
-
--- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
-object :: Monad m
-    => [Resolver m]
-    -> Type.Wrapping (Definition.FieldResolver m)
-object = Type.O . resolversToMap
+-- | Create a new 'Resolver' with the given 'Name' from the given
+-- Resolver's.
+object :: Monad m => [Resolver m] -> Out.Value m
+object = Out.Object . resolversToMap
 
 resolveFieldValue :: Monad m => Field -> ActionT m a -> m (Either Text a)
 resolveFieldValue field@(Field _ _ args _) =
@@ -69,26 +63,25 @@ resolveFieldValue field@(Field _ _ args _) =
 
 withField :: Monad m
     => Field
-    -> Definition.FieldResolver m
+    -> ActionT m (Out.Value m)
     -> CollectErrsT m Aeson.Object
-withField field (Definition.ValueResolver resolver) = do
-    answer <- lift $ resolveFieldValue field resolver
-    either (errmsg field) (pure . HashMap.singleton (aliasOrName field)) answer
-withField field (Definition.NestingResolver resolver) = do
+withField field resolver = do
     answer <- lift $ resolveFieldValue field resolver
     case answer of
-        Right result -> HashMap.singleton (aliasOrName field) <$> toJSON field result
+        Right result -> HashMap.singleton (aliasOrName field)
+            <$> toJSON field result
         Left errorMessage -> errmsg field errorMessage
 
-toJSON :: Monad m => Field -> Type.Wrapping (Definition.FieldResolver m) -> CollectErrsT m Aeson.Value
-toJSON _ Type.Null = pure Aeson.Null
-toJSON _ (Type.I i) = pure $ Aeson.toJSON i
-toJSON _ (Type.B i) = pure $ Aeson.toJSON i
-toJSON _ (Type.F i) = pure $ Aeson.toJSON i
-toJSON _ (Type.E i) = pure $ Aeson.toJSON i
-toJSON _ (Type.S i) = pure $ Aeson.toJSON i
-toJSON field (Type.List list) = Aeson.toJSON <$> traverse (toJSON field) list
-toJSON (Field _ _ _ seqSelection) (Type.O map') = map' `resolve` seqSelection
+toJSON :: Monad m => Field -> Out.Value m -> CollectErrsT m Aeson.Value
+toJSON _ Out.Null = pure Aeson.Null
+toJSON _ (Out.Int integer) = pure $ Aeson.toJSON integer
+toJSON _ (Out.Boolean boolean) = pure $ Aeson.Bool boolean
+toJSON _ (Out.Float float) = pure $ Aeson.toJSON float
+toJSON _ (Out.Enum enum) = pure $ Aeson.String enum
+toJSON _ (Out.String string) = pure $ Aeson.String string
+toJSON field (Out.List list) = Aeson.toJSON <$> traverse (toJSON field) list
+toJSON (Field _ _ _ seqSelection) (Out.Object map') =
+    map' `resolve` seqSelection
 
 errmsg :: Monad m => Field -> Text -> CollectErrsT m (HashMap Text Aeson.Value)
 errmsg field errorMessage = do
@@ -96,10 +89,10 @@ errmsg field errorMessage = do
     pure $ HashMap.singleton (aliasOrName field) 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.
+-- 'Resolver' to each 'Field'. Resolves into a value containing the
+-- resolved 'Field', or a null value and error information.
 resolve :: Monad m
-    => HashMap Text (Definition.FieldResolver m)
+    => HashMap Text (ActionT m (Out.Value m))
     -> Seq Selection
     -> CollectErrsT m Aeson.Value
 resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
@@ -109,17 +102,11 @@ resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
         | (Just resolver) <- lookupResolver name = withField fld resolver
         | otherwise = errmsg fld $ T.unwords ["field", name, "not resolved."]
     tryResolvers (SelectionFragment (Fragment typeCondition selections'))
-        | Just (Definition.ValueResolver resolver) <- lookupResolver "__typename" = do
-            let fakeField = Field Nothing "__typename" mempty mempty
-            that <- lift $ resolveFieldValue fakeField resolver
-            if Right (Aeson.String typeCondition) == that
-                then fmap fold . traverse tryResolvers $ selections'
-                else pure mempty
-        | Just (Definition.NestingResolver resolver) <- lookupResolver "__typename" = do
+        | Just resolver <- lookupResolver "__typename" = do
             let fakeField = Field Nothing "__typename" mempty mempty
             that <- lift $ resolveFieldValue fakeField resolver
             case that of
-                Right (Type.S typeCondition')
+                Right (Out.String typeCondition')
                     | typeCondition' == typeCondition ->
                         fmap fold . traverse tryResolvers $ selections'
                 _ -> pure mempty