Combine Resolver and ActionT in ResolverT

CHANGELOG.md

@@ -7,6 +7,14 @@ and this project adheres to
 [Haskell Package Versioning Policy](https://pvp.haskell.org/).
 
 ## [Unreleased]
+## Changed
+- `Trans.ActionT` is renamed to `ResolverT`. Since `Type.Out.Resolver` has gone
+  it is a better name for GraphQL resolvers.
+
+## Removed
+- `Type.Out.Resolver`: It is an unneeded layer of complexity. Resolvers are a
+  part of the fields and are called `Trans.ResolverT`.
+
 ## [0.8.0.0] - 2020-06-20
 ### Fixed
 - The parser rejects variables when parsing defaultValue (DefaultValue). The

docs/tutorial/tutorial.lhs

@@ -41,13 +41,12 @@ First we build a GraphQL schema.
 >
 > queryType :: ObjectType IO
 > queryType = ObjectType "Query" Nothing []
->   $ HashMap.singleton "hello"
+>   $ HashMap.singleton "hello" helloField
->   $ Out.Resolver helloField hello
 >
 > helloField :: Field IO
-> helloField = Field Nothing (Out.NamedScalarType string) mempty
+> helloField = Field Nothing (Out.NamedScalarType string) mempty hello
 >
-> hello :: ActionT IO Value
+> hello :: ResolverT IO Value
 > hello = pure $ String "it's me"
 
 This defines a simple schema with one type and one field, that resolves to a fixed value.
@@ -79,13 +78,12 @@ For this example, we're going to be using time.
 >
 > queryType2 :: ObjectType IO
 > queryType2 = ObjectType "Query" Nothing []
->   $ HashMap.singleton "time"
+>   $ HashMap.singleton "time" timeField
->   $ Out.Resolver timeField time
 >
 > timeField :: Field IO
-> timeField = Field Nothing (Out.NamedScalarType string) mempty
+> timeField = Field Nothing (Out.NamedScalarType string) mempty time
 >
-> time :: ActionT IO Value
+> time :: ResolverT IO Value
 > time = do
 >   t <- liftIO getCurrentTime
 >   pure $ String $ Text.pack $ show t
@@ -146,8 +144,8 @@ Now that we have two resolvers, we can define a schema which uses them both.
 >
 > queryType3 :: ObjectType IO
 > queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList
->   [ ("hello", Out.Resolver helloField hello)
+>   [ ("hello", helloField)
->   , ("time", Out.Resolver timeField time)
+>   , ("time", timeField)
 >   ]
 >
 > query3 :: Text

src/Language/GraphQL/Execute/Execution.hs

@@ -33,12 +33,12 @@ import Prelude hiding (null)
 resolveFieldValue :: Monad m
     => Type.Value
     -> Type.Subs
-    -> ActionT m a
+    -> ResolverT m a
     -> m (Either Text a)
 resolveFieldValue result args =
     flip runReaderT (Context {arguments = Arguments args, values = result})
     . runExceptT
-    . runActionT
+    . runResolverT
 
 collectFields :: Monad m
     => Out.ObjectType m
@@ -99,12 +99,12 @@ instanceOf objectType (AbstractUnionType unionType) =
     go unionMemberType acc = acc || objectType == unionMemberType
 
 executeField :: (Monad m, Serialize a)
-    => Out.Resolver m
+    => Out.Field m
     -> Type.Value
     -> NonEmpty (Transform.Field m)
     -> CollectErrsT m a
-executeField (Out.Resolver fieldDefinition resolver) prev fields = do
+executeField fieldDefinition prev fields = do
-    let Out.Field _ fieldType argumentDefinitions = fieldDefinition
+    let Out.Field _ fieldType argumentDefinitions resolver = fieldDefinition
     let (Transform.Field _ _ arguments' _ :| []) = fields
     case coerceArgumentValues argumentDefinitions arguments' of
         Nothing -> errmsg "Argument coercing failed."

src/Language/GraphQL/Trans.hs

@@ -1,7 +1,7 @@
 -- | Monad transformer stack used by the @GraphQL@ resolvers.
 module Language.GraphQL.Trans
     ( argument
-    , ActionT(..)
+    , ResolverT(..)
     , Context(..)
     ) where
 
@@ -27,41 +27,48 @@ data Context = Context
 
 -- | Monad transformer stack used by the resolvers to provide error handling
 -- and resolution context (resolver arguments).
-newtype ActionT m a = ActionT
+--
-    { runActionT :: ExceptT Text (ReaderT Context m) a
+-- Resolves a 'Field' into a 'Value' with error 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.
+newtype ResolverT m a = ResolverT
+    { runResolverT :: ExceptT Text (ReaderT Context m) a
     }
 
-instance Functor m => Functor (ActionT m) where
+instance Functor m => Functor (ResolverT m) where
-    fmap f = ActionT . fmap f . runActionT
+    fmap f = ResolverT . fmap f . runResolverT
 
-instance Monad m => Applicative (ActionT m) where
+instance Monad m => Applicative (ResolverT m) where
-    pure = ActionT . pure
+    pure = ResolverT . pure
-    (ActionT f) <*> (ActionT x) = ActionT $ f <*> x
+    (ResolverT f) <*> (ResolverT x) = ResolverT $ f <*> x
 
-instance Monad m => Monad (ActionT m) where
+instance Monad m => Monad (ResolverT m) where
     return = pure
-    (ActionT action) >>= f = ActionT $ action >>= runActionT . f
+    (ResolverT action) >>= f = ResolverT $ action >>= runResolverT . f
 
-instance MonadTrans ActionT where
+instance MonadTrans ResolverT where
-    lift = ActionT . lift . lift
+    lift = ResolverT . lift . lift
 
-instance MonadIO m => MonadIO (ActionT m) where
+instance MonadIO m => MonadIO (ResolverT m) where
     liftIO = lift . liftIO
 
-instance Monad m => Alternative (ActionT m) where
+instance Monad m => Alternative (ResolverT m) where
-    empty = ActionT empty
+    empty = ResolverT empty
-    (ActionT x) <|> (ActionT y) = ActionT $ x <|> y
+    (ResolverT x) <|> (ResolverT y) = ResolverT $ x <|> y
 
-instance Monad m => MonadPlus (ActionT m) where
+instance Monad m => MonadPlus (ResolverT m) where
     mzero = empty
     mplus = (<|>)
 
 -- | Retrieves an argument by its name. If the argument with this name couldn't
 --   be found, returns 'Null' (i.e. the argument is assumed to
 --   be optional then).
-argument :: Monad m => Name -> ActionT m Value
+argument :: Monad m => Name -> ResolverT m Value
 argument argumentName = do
-    argumentValue <- ActionT $ lift $ asks $ lookup . arguments
+    argumentValue <- ResolverT $ lift $ asks $ lookup . arguments
     pure $ fromMaybe Null argumentValue
   where
     lookup (Arguments argumentMap) = HashMap.lookup argumentName argumentMap

src/Language/GraphQL/Type/Out.hs

@@ -10,7 +10,6 @@ module Language.GraphQL.Type.Out
     ( Field(..)
     , InterfaceType(..)
     , ObjectType(..)
-    , Resolver(..)
     , Type(..)
     , UnionType(..)
     , isNonNullType
@@ -29,21 +28,12 @@ import Language.GraphQL.Trans
 import Language.GraphQL.Type.Definition
 import qualified Language.GraphQL.Type.In as In
 
--- | 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'.
---
--- 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 (Field m) (ActionT m Value)
-
 -- | Object type definition.
 --
 -- Almost all of the GraphQL types you define will be object types. Object
 -- types have a name, but most importantly describe their fields.
 data ObjectType m = ObjectType
-    Name (Maybe Text) [InterfaceType m] (HashMap Name (Resolver m))
+    Name (Maybe Text) [InterfaceType m] (HashMap Name (Field m))
 
 instance forall a. Eq (ObjectType a) where
     (ObjectType this _ _ _) == (ObjectType that _ _ _) = this == that
@@ -73,6 +63,7 @@ data Field m = Field
     (Maybe Text) -- ^ Description.
     (Type m) -- ^ Field type.
     (HashMap Name In.Argument) -- ^ Arguments.
+    (ResolverT m Value) -- ^ Resolver.
 
 -- | These types may be used as output types as the result of fields.
 --

src/Language/GraphQL/Type/Schema.hs

@@ -61,7 +61,7 @@ collectReferencedTypes schema =
     collect traverser typeName element foundTypes
         | HashMap.member typeName foundTypes = foundTypes
         | otherwise = traverser $ HashMap.insert typeName element foundTypes
-    visitFields (Out.Field _ outputType arguments) foundTypes
+    visitFields (Out.Field _ outputType arguments _) foundTypes
         = traverseOutputType outputType
         $ foldr visitArguments foundTypes arguments
     visitArguments (In.Argument _ inputType _) = traverseInputType inputType
@@ -96,9 +96,8 @@ collectReferencedTypes schema =
         let (Definition.EnumType typeName _ _) = enumType
          in collect Prelude.id typeName (EnumType enumType)
     traverseObjectType objectType foundTypes =
-        let (Out.ObjectType typeName _ interfaces resolvers) = objectType
+        let (Out.ObjectType typeName _ interfaces fields) = objectType
             element = ObjectType objectType
-            fields = extractObjectField <$> resolvers
             traverser = polymorphicTraverser interfaces fields
          in collect traverser typeName element foundTypes
     traverseInterfaceType interfaceType foundTypes =
@@ -109,4 +108,3 @@ collectReferencedTypes schema =
     polymorphicTraverser interfaces fields
         = flip (foldr visitFields) fields
         . flip (foldr traverseInterfaceType) interfaces
-    extractObjectField (Out.Resolver field _) = field

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-16.2
+resolver: lts-16.3
 
 packages:
 - .

tests/Language/GraphQL/ExecuteSpec.hs

@@ -22,26 +22,26 @@ schema = Schema {query = queryType, mutation = Nothing}
 
 queryType :: Out.ObjectType Identity
 queryType = Out.ObjectType "Query" Nothing []
-    $ HashMap.singleton "philosopher"
+    $ HashMap.singleton "philosopher" philosopherField
-    $ Out.Resolver philosopherField
-    $ pure
-    $ Type.Object mempty
   where
-    philosopherField =
+    philosopherField
-        Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
+        = Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
+        $ pure $ Type.Object mempty
 
 philosopherType :: Out.ObjectType Identity
 philosopherType = Out.ObjectType "Philosopher" Nothing []
     $ HashMap.fromList resolvers
   where
     resolvers =
-        [ ("firstName", firstNameResolver)
+        [ ("firstName", firstNameField)
-        , ("lastName", lastNameResolver)
+        , ("lastName", lastNameField)
         ]
-    firstNameResolver = Out.Resolver firstNameField $ pure $ Type.String "Friedrich"
+    firstNameField
-    lastNameResolver = Out.Resolver lastNameField $ pure $ Type.String "Nietzsche"
+        = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
-    firstNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
+        $ pure $ Type.String "Friedrich"
-    lastNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
+    lastNameField
+        = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
+        $ pure $ Type.String "Nietzsche"
 
 spec :: Spec
 spec =

tests/Test/DirectiveSpec.hs

@@ -19,7 +19,7 @@ experimentalResolver = Schema { query = queryType, mutation = Nothing }
     resolver = pure $ Int 5
     queryType = Out.ObjectType "Query" Nothing []
         $ HashMap.singleton "experimentalField"
-        $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty) resolver
+        $ Out.Field Nothing (Out.NamedScalarType int) mempty resolver
 
 emptyObject :: Aeson.Value
 emptyObject = object

tests/Test/FragmentSpec.hs

@@ -53,22 +53,24 @@ hasErrors _ = True
 shirtType :: Out.ObjectType IO
 shirtType = Out.ObjectType "Shirt" Nothing []
     $ HashMap.fromList
-        [ ("size", Out.Resolver sizeFieldType $ pure $ snd size)
+        [ ("size", sizeFieldType)
-        , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference)
+        , ("circumference", circumferenceFieldType)
         ]
 
 hatType :: Out.ObjectType IO
 hatType = Out.ObjectType "Hat" Nothing []
     $ HashMap.fromList
-        [ ("size", Out.Resolver sizeFieldType $ pure $ snd size)
+        [ ("size", sizeFieldType)
-        , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference)
+        , ("circumference", circumferenceFieldType)
         ]
 
 circumferenceFieldType :: Out.Field IO
 circumferenceFieldType = Out.Field Nothing (Out.NamedScalarType int) mempty
+    $ pure $ snd circumference
 
 sizeFieldType :: Out.Field IO
 sizeFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+    $ pure $ snd size
 
 toSchema :: Text -> (Text, Value) -> Schema IO
 toSchema t (_, resolve) = Schema
@@ -76,15 +78,17 @@ toSchema t (_, resolve) = Schema
   where
     unionMember = if t == "Hat" then hatType else shirtType
     typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty
+        $ pure $ String "Shirt"
     garmentField = Out.Field Nothing (Out.NamedObjectType unionMember) mempty
+        $ pure resolve
     queryType =
         case t of
             "circumference" -> hatType
             "size" -> shirtType
             _ -> Out.ObjectType "Query" Nothing []
                 $ HashMap.fromList
-                    [ ("garment", Out.Resolver garmentField $ pure resolve)
+                    [ ("garment", garmentField)
-                    , ("__typename", Out.Resolver typeNameField $ pure $ String "Shirt")
+                    , ("__typename", typeNameField)
                     ]
 
 spec :: Spec

tests/Test/RootOperationSpec.hs

@@ -15,8 +15,9 @@ import qualified Language.GraphQL.Type.Out as Out
 hatType :: Out.ObjectType IO
 hatType = Out.ObjectType "Hat" Nothing []
     $ HashMap.singleton "circumference"
-    $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
+    $ Out.Field Nothing (Out.NamedScalarType int) mempty
-    $ pure $ Int 60
+    $ pure
+    $ Int 60
 
 schema :: Schema IO
 schema = Schema
@@ -27,10 +28,10 @@ schema = Schema
         [ ("circumference", Int 60)
         ]
     incrementField = HashMap.singleton "incrementCircumference"
-        $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
+        $ Out.Field Nothing (Out.NamedScalarType int) mempty
         $ pure $ Int 61
     hatField = HashMap.singleton "garment"
-        $ Out.Resolver (Out.Field Nothing (Out.NamedObjectType hatType) mempty) garment
+        $ Out.Field Nothing (Out.NamedObjectType hatType) mempty garment
 
 spec :: Spec
 spec =

tests/Test/StarWars/Data.hs

@@ -66,8 +66,8 @@ appearsIn :: Character -> [Int]
 appearsIn (Left  x) = _appearsIn . _droidChar $ x
 appearsIn (Right x) = _appearsIn . _humanChar $ x
 
-secretBackstory :: ActionT Identity Text
+secretBackstory :: ResolverT Identity Text
-secretBackstory = ActionT $ throwE "secretBackstory is secret."
+secretBackstory = ResolverT $ throwE "secretBackstory is secret."
 
 typeName :: Character -> Text
 typeName = either (const "Droid") (const "Human")

tests/Test/StarWars/Schema.hs

@@ -24,65 +24,78 @@ schema :: Schema Identity
 schema = Schema { query = queryType, mutation = Nothing }
   where
     queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
-        [ ("hero", Out.Resolver heroField hero)
+        [ ("hero", heroField)
-        , ("human", Out.Resolver humanField human)
+        , ("human", humanField)
-        , ("droid", Out.Resolver droidField droid)
+        , ("droid", droidField)
         ]
-    heroField = Out.Field Nothing (Out.NamedObjectType heroObject)
+    heroArguments = HashMap.singleton "episode"
-        $ HashMap.singleton "episode"
         $ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing
-    humanField = Out.Field Nothing (Out.NamedObjectType heroObject)
+    heroField =
-        $ HashMap.singleton "id"
+        Out.Field Nothing (Out.NamedObjectType heroObject) heroArguments hero
+    humanArguments = HashMap.singleton "id"
         $ In.Argument Nothing (In.NonNullScalarType string) Nothing
-    droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty
+    humanField =
+        Out.Field Nothing (Out.NamedObjectType heroObject) humanArguments human
+    droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty droid
 
 heroObject :: Out.ObjectType Identity
 heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
-    [ ("id", Out.Resolver idFieldType (idField "id"))
+    [ ("id", idFieldType)
-    , ("name", Out.Resolver nameFieldType (idField "name"))
+    , ("name", nameFieldType)
-    , ("friends", Out.Resolver friendsFieldType (idField "friends"))
+    , ("friends", friendsFieldType)
-    , ("appearsIn", Out.Resolver appearsInField (idField "appearsIn"))
+    , ("appearsIn", appearsInField)
-    , ("homePlanet", Out.Resolver homePlanetFieldType (idField "homePlanet"))
+    , ("homePlanet", homePlanetFieldType)
-    , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))
+    , ("secretBackstory", secretBackstoryFieldType)
-    , ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename"))
+    , ("__typename", typenameFieldType)
     ]
   where
     homePlanetFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+        $ idField "homePlanet"
 
 droidObject :: Out.ObjectType Identity
 droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
-    [ ("id", Out.Resolver idFieldType (idField "id"))
+    [ ("id", idFieldType)
-    , ("name", Out.Resolver nameFieldType (idField "name"))
+    , ("name", nameFieldType)
-    , ("friends", Out.Resolver friendsFieldType (idField "friends"))
+    , ("friends", friendsFieldType)
-    , ("appearsIn", Out.Resolver appearsInField (idField "appearsIn"))
+    , ("appearsIn", appearsInField)
-    , ("primaryFunction", Out.Resolver primaryFunctionFieldType (idField "primaryFunction"))
+    , ("primaryFunction", primaryFunctionFieldType)
-    , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))
+    , ("secretBackstory", secretBackstoryFieldType)
-    , ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename"))
+    , ("__typename", typenameFieldType)
     ]
   where
     primaryFunctionFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+        $ idField "primaryFunction"
+
+typenameFieldType :: Out.Field Identity
+typenameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+    $ idField "__typename"
 
 idFieldType :: Out.Field Identity
 idFieldType = Out.Field Nothing (Out.NamedScalarType id) mempty
+    $ idField "id"
 
 nameFieldType :: Out.Field Identity
 nameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+    $ idField "name"
 
 friendsFieldType :: Out.Field Identity
 friendsFieldType = Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty
+    $ idField "friends"
 
 appearsInField :: Out.Field Identity
 appearsInField = Out.Field (Just description) fieldType mempty
+    $ idField "appearsIn"
   where
     fieldType = Out.ListType $ Out.NamedEnumType episodeEnum
     description = "Which movies they appear in."
 
 secretBackstoryFieldType :: Out.Field Identity
 secretBackstoryFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+    $ String <$> secretBackstory
 
-idField :: Text -> ActionT Identity Value
+idField :: Text -> ResolverT Identity Value
 idField f = do
-    v <- ActionT $ lift $ asks values
+    v <- ResolverT $ lift $ asks values
     let (Object v') = v
     pure $ v' HashMap.! f
 
@@ -95,7 +108,7 @@ episodeEnum = EnumType "Episode" (Just description)
     empire = ("EMPIRE", EnumValue $ Just "Released in 1980.")
     jedi = ("JEDI", EnumValue $ Just "Released in 1983.")
 
-hero :: ActionT Identity Value
+hero :: ResolverT Identity Value
 hero = do
   episode <- argument "episode"
   pure $ character $ case episode of
@@ -104,7 +117,7 @@ hero = do
       Enum "JEDI" -> getHero 6
       _ -> artoo
 
-human :: ActionT Identity Value
+human :: ResolverT Identity Value
 human = do
     id' <- argument "id"
     case id' of
@@ -113,14 +126,14 @@ human = do
             case humanCharacter of
                 Nothing -> pure Null
                 Just e -> pure $ character e
-        _ -> ActionT $ throwE "Invalid arguments."
+        _ -> ResolverT $ throwE "Invalid arguments."
 
-droid :: ActionT Identity Value
+droid :: ResolverT Identity Value
 droid = do
     id' <- argument "id"
     case id' of
         String i -> character <$> getDroid i
-        _ -> ActionT $ throwE "Invalid arguments."
+        _ -> ResolverT $ throwE "Invalid arguments."
 
 character :: Character -> Value
 character char = Object $ HashMap.fromList