diff --git a/CHANGELOG.md b/CHANGELOG.md index 5f0a1b6..c3609e5 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/docs/tutorial/tutorial.lhs b/docs/tutorial/tutorial.lhs index 13afb81..2c6e877 100644 --- a/docs/tutorial/tutorial.lhs +++ b/docs/tutorial/tutorial.lhs @@ -41,13 +41,12 @@ First we build a GraphQL schema. > > queryType :: ObjectType IO > queryType = ObjectType "Query" Nothing [] -> $ HashMap.singleton "hello" -> $ Out.Resolver helloField hello +> $ HashMap.singleton "hello" helloField > > 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" -> $ Out.Resolver timeField time +> $ HashMap.singleton "time" timeField > > 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) -> , ("time", Out.Resolver timeField time) +> [ ("hello", helloField) +> , ("time", timeField) > ] > > query3 :: Text diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs index 0c10419..0291bf8 100644 --- a/src/Language/GraphQL/Execute/Execution.hs +++ b/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 - let Out.Field _ fieldType argumentDefinitions = fieldDefinition +executeField fieldDefinition prev fields = do + let Out.Field _ fieldType argumentDefinitions resolver = fieldDefinition let (Transform.Field _ _ arguments' _ :| []) = fields case coerceArgumentValues argumentDefinitions arguments' of Nothing -> errmsg "Argument coercing failed." diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs index fa7718a..2ec13be 100644 --- a/src/Language/GraphQL/Trans.hs +++ b/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 @@ -26,42 +26,49 @@ 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 +-- and resolution context (resolver arguments). +-- +-- 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 - fmap f = ActionT . fmap f . runActionT +instance Functor m => Functor (ResolverT m) where + fmap f = ResolverT . fmap f . runResolverT -instance Monad m => Applicative (ActionT m) where - pure = ActionT . pure - (ActionT f) <*> (ActionT x) = ActionT $ f <*> x +instance Monad m => Applicative (ResolverT m) where + pure = ResolverT . pure + (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 - lift = ActionT . lift . lift +instance MonadTrans ResolverT where + 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 - empty = ActionT empty - (ActionT x) <|> (ActionT y) = ActionT $ x <|> y +instance Monad m => Alternative (ResolverT m) where + empty = ResolverT empty + (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 diff --git a/src/Language/GraphQL/Type/Out.hs b/src/Language/GraphQL/Type/Out.hs index 856c4f8..0f14ce8 100644 --- a/src/Language/GraphQL/Type/Out.hs +++ b/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. +-- 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. -- diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs index 4d7b9eb..4420cbb 100644 --- a/src/Language/GraphQL/Type/Schema.hs +++ b/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 diff --git a/stack.yaml b/stack.yaml index e99e8c3..6e55f3d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-16.2 +resolver: lts-16.3 packages: - . diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs index 30568be..632e4dd 100644 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/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" - $ Out.Resolver philosopherField - $ pure - $ Type.Object mempty + $ HashMap.singleton "philosopher" philosopherField where - philosopherField = - Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty + philosopherField + = 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) - , ("lastName", lastNameResolver) + [ ("firstName", firstNameField) + , ("lastName", lastNameField) ] - firstNameResolver = Out.Resolver firstNameField $ pure $ Type.String "Friedrich" - lastNameResolver = Out.Resolver lastNameField $ pure $ Type.String "Nietzsche" - firstNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty - lastNameField = 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 + $ pure $ Type.String "Nietzsche" spec :: Spec spec = diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs index b147d77..3243d2a 100644 --- a/tests/Test/DirectiveSpec.hs +++ b/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 diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index 2924e63..94cc76c 100644 --- a/tests/Test/FragmentSpec.hs +++ b/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) - , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference) + [ ("size", sizeFieldType) + , ("circumference", circumferenceFieldType) ] hatType :: Out.ObjectType IO hatType = Out.ObjectType "Hat" Nothing [] $ HashMap.fromList - [ ("size", Out.Resolver sizeFieldType $ pure $ snd size) - , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference) + [ ("size", sizeFieldType) + , ("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) - , ("__typename", Out.Resolver typeNameField $ pure $ String "Shirt") + [ ("garment", garmentField) + , ("__typename", typeNameField) ] spec :: Spec diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs index 0e534fc..44b19a6 100644 --- a/tests/Test/RootOperationSpec.hs +++ b/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) - $ pure $ Int 60 + $ Out.Field Nothing (Out.NamedScalarType int) mempty + $ 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 = diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs index 427371b..d0806f9 100644 --- a/tests/Test/StarWars/Data.hs +++ b/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 = ActionT $ throwE "secretBackstory is secret." +secretBackstory :: ResolverT Identity Text +secretBackstory = ResolverT $ throwE "secretBackstory is secret." typeName :: Character -> Text typeName = either (const "Droid") (const "Human") diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index 5fcdf3e..0b5971b 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/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) - , ("human", Out.Resolver humanField human) - , ("droid", Out.Resolver droidField droid) + [ ("hero", heroField) + , ("human", humanField) + , ("droid", droidField) ] - heroField = Out.Field Nothing (Out.NamedObjectType heroObject) - $ HashMap.singleton "episode" + heroArguments = HashMap.singleton "episode" $ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing - humanField = Out.Field Nothing (Out.NamedObjectType heroObject) - $ HashMap.singleton "id" + heroField = + 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")) - , ("name", Out.Resolver nameFieldType (idField "name")) - , ("friends", Out.Resolver friendsFieldType (idField "friends")) - , ("appearsIn", Out.Resolver appearsInField (idField "appearsIn")) - , ("homePlanet", Out.Resolver homePlanetFieldType (idField "homePlanet")) - , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory)) - , ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename")) + [ ("id", idFieldType) + , ("name", nameFieldType) + , ("friends", friendsFieldType) + , ("appearsIn", appearsInField) + , ("homePlanet", homePlanetFieldType) + , ("secretBackstory", secretBackstoryFieldType) + , ("__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")) - , ("name", Out.Resolver nameFieldType (idField "name")) - , ("friends", Out.Resolver friendsFieldType (idField "friends")) - , ("appearsIn", Out.Resolver appearsInField (idField "appearsIn")) - , ("primaryFunction", Out.Resolver primaryFunctionFieldType (idField "primaryFunction")) - , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory)) - , ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename")) + [ ("id", idFieldType) + , ("name", nameFieldType) + , ("friends", friendsFieldType) + , ("appearsIn", appearsInField) + , ("primaryFunction", primaryFunctionFieldType) + , ("secretBackstory", secretBackstoryFieldType) + , ("__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