From 93a04032886976b540f5fdb1417bd085a642f772 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Wed, 3 Jun 2020 07:20:38 +0200 Subject: [PATCH] Resolve abstract types Objects that can be a part of an union or interface should return __typename as string. --- CHANGELOG.md | 5 +- docs/tutorial/tutorial.lhs | 14 ++- src/Language/GraphQL.hs | 4 +- src/Language/GraphQL/Error.hs | 1 + src/Language/GraphQL/Execute.hs | 4 +- src/Language/GraphQL/Execute/Execution.hs | 129 ++++++++++++++++++++-- src/Language/GraphQL/Schema.hs | 105 ------------------ src/Language/GraphQL/Type/Out.hs | 13 ++- src/Language/GraphQL/Type/Schema.hs | 23 ++-- stack.yaml | 2 +- tests/Test/DirectiveSpec.hs | 2 +- tests/Test/FragmentSpec.hs | 22 ++-- tests/Test/RootOperationSpec.hs | 6 +- tests/Test/StarWars/Schema.hs | 53 ++++++--- 14 files changed, 217 insertions(+), 166 deletions(-) delete mode 100644 src/Language/GraphQL/Schema.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 21e6477..e98fd5b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,8 +17,8 @@ and this project adheres to * Invalid (recusrive or non-existing) fragments should be skipped. ### Changed -- `Schema.Resolver` cannot return arbitrary JSON anymore, but only - `Type.Definition.Value`. +- `Schema.Resolver` was moved to `Type.Out`, it is a field and resolver function + pair. - `AST.Core.Value` was moved into `Type.Definition`. These values are used only in the execution and type system, it is not a part of the parsing tree. - `Type` module is superseded by `Type.Out`. This module contains now only @@ -46,6 +46,7 @@ and this project adheres to - `Schema.wrappedObject`, `Schema.object`, `Schema.resolversToMap`. There is no need in special functions to construct field resolvers anymore, resolvers are normal functions attached to the fields in the schema representation. +- `Schema.resolve` is superseded by `Execute.Execution`. - `Error.runAppendErrs` isn't used anywhere. - `AST.Core`: `Document`, `Directive`, `Field`, `Fragment`, `Selection`, `Alias` `TypeCondition` were modified, moved into `Execute.Transform.Document` and diff --git a/docs/tutorial/tutorial.lhs b/docs/tutorial/tutorial.lhs index 9ca2db0..9a2242e 100644 --- a/docs/tutorial/tutorial.lhs +++ b/docs/tutorial/tutorial.lhs @@ -42,7 +42,10 @@ First we build a GraphQL schema. > queryType :: ObjectType IO > queryType = ObjectType "Query" Nothing [] > $ HashMap.singleton "hello" -> $ Field Nothing (Out.NamedScalarType string) mempty hello +> $ Out.Resolver helloField hello +> +> helloField :: Field IO +> helloField = Field Nothing (Out.NamedScalarType string) mempty > > hello :: ActionT IO Value > hello = pure $ String "it's me" @@ -77,7 +80,10 @@ For this example, we're going to be using time. > queryType2 :: ObjectType IO > queryType2 = ObjectType "Query" Nothing [] > $ HashMap.singleton "time" -> $ Field Nothing (Out.NamedScalarType string) mempty time +> $ Out.Resolver timeField time +> +> timeField :: Field IO +> timeField = Field Nothing (Out.NamedScalarType string) mempty > > time :: ActionT IO Value > time = do @@ -140,8 +146,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", Field Nothing (Out.NamedScalarType string) mempty hello) -> , ("time", Field Nothing (Out.NamedScalarType string) mempty time) +> [ ("hello", Out.Resolver helloField hello) +> , ("time", Out.Resolver timeField time) > ] > > query3 :: Text diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs index aef23f0..961253f 100644 --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -16,7 +16,7 @@ import Language.GraphQL.Type.Schema import Text.Megaparsec (parse) -- | If the text parses correctly as a @GraphQL@ query the query is --- executed using the given 'Schema.Resolver's. +-- executed using the given 'Schema'. graphql :: Monad m => Schema m -- ^ Resolvers. -> Text -- ^ Text representing a @GraphQL@ request document. @@ -25,7 +25,7 @@ graphql = flip graphqlSubs (mempty :: Aeson.Object) -- | If the text parses correctly as a @GraphQL@ query the substitution is -- applied to the query and the query is then executed using to the given --- 'Schema.Resolver's. +-- 'Schema'. graphqlSubs :: (Monad m, VariableValue a) => Schema m -- ^ Resolvers. -> HashMap Name a -- ^ Variable substitution function. diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs index e41782d..59719b0 100644 --- a/src/Language/GraphQL/Error.hs +++ b/src/Language/GraphQL/Error.hs @@ -29,6 +29,7 @@ import Text.Megaparsec , unPos ) +-- | Executor context. data Resolution m = Resolution { errors :: [Aeson.Value] , types :: HashMap Name (Type m) diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index ee009db..cfa935c 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -11,10 +11,10 @@ import Data.Sequence (Seq(..)) import Data.Text (Text) import Language.GraphQL.AST.Document (Document, Name) import Language.GraphQL.Execute.Coerce +import Language.GraphQL.Execute.Execution import qualified Language.GraphQL.Execute.Transform as Transform import Language.GraphQL.Error import Language.GraphQL.Type.Definition -import qualified Language.GraphQL.Schema as Schema import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Type.Schema @@ -68,4 +68,4 @@ executeOperation :: Monad m -> Seq (Transform.Selection m) -> m Aeson.Value executeOperation types' objectType fields = - runCollectErrs types' $ Schema.resolve Null objectType fields + runCollectErrs types' $ executeSelectionSet Null objectType fields diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs index 117df30..140df81 100644 --- a/src/Language/GraphQL/Execute/Execution.hs +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -1,20 +1,38 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE OverloadedStrings #-} + module Language.GraphQL.Execute.Execution - ( aliasOrName - , collectFields + ( executeSelectionSet ) where +import qualified Data.Aeson as Aeson +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Trans.Reader (runReaderT) +import Control.Monad.Trans.State (gets) import Data.Map.Strict (Map) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) -import Data.Sequence (Seq) +import Data.Sequence (Seq(..)) +import Data.Text (Text) +import qualified Data.Text as Text import qualified Data.Sequence as Seq import Language.GraphQL.AST.Document (Name) +import Language.GraphQL.Error import Language.GraphQL.Execute.Transform +import Language.GraphQL.Trans +import Language.GraphQL.Type.Definition import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Type.Schema +resolveFieldValue :: Monad m => Value -> Field m -> ActionT m a -> m (Either Text a) +resolveFieldValue result (Field _ _ args _) = + flip runReaderT (Context {arguments=args, values=result}) + . runExceptT + . runActionT + collectFields :: Monad m => Out.ObjectType m -> Seq (Selection m) @@ -34,6 +52,21 @@ collectFields objectType = foldl forEach Map.empty aliasOrName :: forall m. Field m -> Name aliasOrName (Field alias name _ _) = fromMaybe name alias +resolveAbstractType :: Monad m + => AbstractType m + -> HashMap Name Value + -> CollectErrsT m (Maybe (Out.ObjectType m)) +resolveAbstractType abstractType values' + | Just (String typeName) <- HashMap.lookup "__typename" values' = do + types' <- gets types + case HashMap.lookup typeName types' of + Just (ObjectType objectType) -> + if instanceOf objectType abstractType + then pure $ Just objectType + else pure Nothing + _ -> pure Nothing + | otherwise = pure Nothing + doesFragmentTypeApply :: forall m . CompositeType m -> Out.ObjectType m @@ -43,16 +76,88 @@ doesFragmentTypeApply (CompositeObjectType fragmentType) objectType = Out.ObjectType objectName _ _ _ = objectType in fragmentName == objectName doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType = - let Out.ObjectType _ _ interfaces _ = objectType - in foldr instanceOf False interfaces - where - instanceOf (Out.InterfaceType that _ interfaces _) acc = - let Out.InterfaceType this _ _ _ = fragmentType - in acc || foldr instanceOf (this == that) interfaces + instanceOf objectType $ AbstractInterfaceType fragmentType doesFragmentTypeApply (CompositeUnionType fragmentType) objectType = - let Out.UnionType _ _ members = fragmentType - in foldr instanceOf False members + instanceOf objectType $ AbstractUnionType fragmentType + +instanceOf :: forall m. Out.ObjectType m -> AbstractType m -> Bool +instanceOf objectType (AbstractInterfaceType interfaceType) = + let Out.ObjectType _ _ interfaces _ = objectType + in foldr go False interfaces where - instanceOf (Out.ObjectType that _ _ _) acc = + go (Out.InterfaceType that _ interfaces _) acc = + let Out.InterfaceType this _ _ _ = interfaceType + in acc || foldr go (this == that) interfaces +instanceOf objectType (AbstractUnionType unionType) = + let Out.UnionType _ _ members = unionType + in foldr go False members + where + go (Out.ObjectType that _ _ _) acc = let Out.ObjectType this _ _ _ = objectType in acc || this == that + +executeField :: Monad m + => Value + -> Out.Resolver m + -> Field m + -> CollectErrsT m Aeson.Value +executeField prev (Out.Resolver fieldDefinition resolver) field = do + let Out.Field _ fieldType _ = fieldDefinition + answer <- lift $ resolveFieldValue prev field resolver + case answer of + Right result -> completeValue fieldType field result + Left errorMessage -> errmsg errorMessage + +completeValue :: Monad m + => Out.Type m + -> Field m + -> Value + -> CollectErrsT m Aeson.Value +completeValue _ _ Null = pure Aeson.Null +completeValue _ _ (Int integer) = pure $ Aeson.toJSON integer +completeValue _ _ (Boolean boolean') = pure $ Aeson.Bool boolean' +completeValue _ _ (Float float') = pure $ Aeson.toJSON float' +completeValue _ _ (Enum enum) = pure $ Aeson.String enum +completeValue _ _ (String string') = pure $ Aeson.String string' +completeValue (Out.ObjectBaseType objectType) (Field _ _ _ seqSelection) result = + executeSelectionSet result objectType seqSelection +completeValue (Out.ListBaseType listType) selectionField (List list) = + Aeson.toJSON <$> traverse (completeValue listType selectionField) list +completeValue (Out.InterfaceBaseType interfaceType) (Field _ _ _ seqSelection) result + | Object objectMap <- result = do + abstractType <- resolveAbstractType (AbstractInterfaceType interfaceType) objectMap + case abstractType of + Just objectType -> executeSelectionSet result objectType seqSelection + Nothing -> errmsg "Value completion failed." +completeValue (Out.UnionBaseType unionType) (Field _ _ _ seqSelection) result + | Object objectMap <- result = do + abstractType <- resolveAbstractType (AbstractUnionType unionType) objectMap + case abstractType of + Just objectType -> executeSelectionSet result objectType seqSelection + Nothing -> errmsg "Value completion failed." +completeValue _ _ _ = errmsg "Value completion failed." + +errmsg :: Monad m => Text -> CollectErrsT m Aeson.Value +errmsg errorMessage = addErrMsg errorMessage >> pure Aeson.Null + +-- | Takes an 'Out.ObjectType' and a list of 'Selection's and applies each field +-- to each 'Selection'. Resolves into a value containing the resolved +-- 'Selection', or a null value and error information. +executeSelectionSet :: Monad m + => Value + -> Out.ObjectType m + -> Seq (Selection m) + -> CollectErrsT m Aeson.Value +executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do + resolvedValues <- Map.traverseMaybeWithKey forEach + $ collectFields objectType selectionSet + pure $ Aeson.toJSON resolvedValues + where + forEach _responseKey (field :<| _) = + tryResolvers field >>= lift . pure . pure + forEach _ _ = pure Nothing + lookupResolver = flip HashMap.lookup resolvers + tryResolvers fld@(Field _ name _ _) + | Just typeField <- lookupResolver name = + executeField result typeField fld + | otherwise = errmsg $ Text.unwords ["field", name, "not resolved."] diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs deleted file mode 100644 index 734f070..0000000 --- a/src/Language/GraphQL/Schema.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE OverloadedStrings #-} - --- | This module provides a representation of a @GraphQL@ Schema in addition to --- functions for defining and manipulating schemas. -module Language.GraphQL.Schema - ( Resolver(..) - , resolve - ) where - -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (runExceptT) -import Control.Monad.Trans.Reader (runReaderT) -import qualified Data.Aeson as Aeson -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Map.Strict as Map -import Data.Sequence (Seq(..)) -import Data.Text (Text) -import qualified Data.Text as Text -import Language.GraphQL.AST.Document (Name) -import Language.GraphQL.Error -import Language.GraphQL.Execute.Execution -import Language.GraphQL.Execute.Transform -import Language.GraphQL.Trans -import Language.GraphQL.Type.Definition -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'. --- --- 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 Value) - -resolveFieldValue :: Monad m => Value -> Field m -> ActionT m a -> m (Either Text a) -resolveFieldValue result (Field _ _ args _) = - flip runReaderT (Context {arguments=args, values=result}) - . runExceptT - . runActionT - -executeField :: Monad m - => Value - -> Out.Field m - -> Field m - -> CollectErrsT m Aeson.Value -executeField prev (Out.Field _ fieldType _ resolver) field = do - answer <- lift $ resolveFieldValue prev field resolver - case answer of - Right result -> completeValue fieldType field result - Left errorMessage -> errmsg errorMessage - -completeValue :: Monad m - => Out.Type m - -> Field m - -> Value - -> CollectErrsT m Aeson.Value -completeValue _ _ Null = pure Aeson.Null -completeValue _ _ (Int integer) = pure $ Aeson.toJSON integer -completeValue _ _ (Boolean boolean') = pure $ Aeson.Bool boolean' -completeValue _ _ (Float float') = pure $ Aeson.toJSON float' -completeValue _ _ (Enum enum) = pure $ Aeson.String enum -completeValue _ _ (String string') = pure $ Aeson.String string' -completeValue (Out.ObjectBaseType objectType) (Field _ _ _ seqSelection) result = - resolve result objectType seqSelection -completeValue (Out.ListBaseType listType) selectionField (List list) = - Aeson.toJSON <$> traverse (completeValue listType selectionField) list -completeValue _ _ _ = errmsg "Value completion failed." - -errmsg :: Monad m => Text -> CollectErrsT m Aeson.Value -errmsg errorMessage = addErrMsg errorMessage >> pure 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. -resolve :: Monad m -- executeSelectionSet - => Value - -> Out.ObjectType m - -> Seq (Selection m) - -> CollectErrsT m Aeson.Value -resolve result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do - resolvedValues <- Map.traverseMaybeWithKey forEach - $ collectFields objectType selectionSet - pure $ Aeson.toJSON resolvedValues - where - forEach _responseKey (field :<| _) = - tryResolvers field >>= lift . pure . pure - forEach _ _ = pure Nothing - lookupResolver = flip HashMap.lookup resolvers - tryResolvers fld@(Field _ name _ _) - | Just typeField <- lookupResolver name = - executeField result typeField fld - | otherwise = errmsg $ Text.unwords ["field", name, "not resolved."] - {-tryResolvers (Out.SelectionFragment (Out.Fragment typeCondition selections')) - | Just (Out.Field _ _ _ resolver) <- lookupResolver "__typename" = do - let fakeField = Out.Field Nothing "__typename" mempty mempty - that <- lift $ resolveFieldValue result fakeField resolver - case that of - Right (String typeCondition') - | (Out.CompositeObjectType (Out.ObjectType n _ _ _)) <- typeCondition - , typeCondition' == n -> - fmap fold . traverse tryResolvers $ selections' - _ -> pure mempty - | otherwise = fmap fold . traverse tryResolvers $ selections'-} diff --git a/src/Language/GraphQL/Type/Out.hs b/src/Language/GraphQL/Type/Out.hs index 4808d09..acd348c 100644 --- a/src/Language/GraphQL/Type/Out.hs +++ b/src/Language/GraphQL/Type/Out.hs @@ -10,6 +10,7 @@ module Language.GraphQL.Type.Out ( Field(..) , InterfaceType(..) , ObjectType(..) + , Resolver(..) , Type(..) , UnionType(..) , isNonNullType @@ -27,13 +28,22 @@ import Language.GraphQL.AST.Core 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 (Field m)) + Name (Maybe Text) [InterfaceType m] (HashMap Name (Resolver m)) -- | Interface Type Definition. -- @@ -54,7 +64,6 @@ data Field m = Field (Maybe Text) -- ^ Description. (Type m) -- ^ Field type. (HashMap Name In.Argument) -- ^ Arguments. - (ActionT 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 b6055c5..ff7b5cc 100644 --- a/src/Language/GraphQL/Type/Schema.hs +++ b/src/Language/GraphQL/Type/Schema.hs @@ -1,8 +1,10 @@ {-# LANGUAGE ExplicitForAll #-} --- | Schema Definition. +-- | This module provides a representation of a @GraphQL@ Schema in addition to +-- functions for defining and manipulating schemas. module Language.GraphQL.Type.Schema - ( CompositeType(..) + ( AbstractType(..) + , CompositeType(..) , Schema(..) , Type(..) , collectReferencedTypes @@ -30,6 +32,11 @@ data CompositeType m | CompositeObjectType (Out.ObjectType m) | CompositeInterfaceType (Out.InterfaceType m) +-- | These types may describe the parent context of a selection set. +data AbstractType m + = AbstractUnionType (Out.UnionType m) + | AbstractInterfaceType (Out.InterfaceType m) + -- | A Schema is created by supplying the root types of each type of operation, -- query and mutation (optional). A schema definition is then supplied to the -- validator and executor. @@ -51,7 +58,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 @@ -86,15 +93,17 @@ collectReferencedTypes schema = let (Definition.EnumType typeName _ _) = enumType in collect Prelude.id typeName (EnumType enumType) traverseObjectType objectType foundTypes = - let (Out.ObjectType typeName _ interfaces fields) = objectType + let (Out.ObjectType typeName _ interfaces resolvers) = objectType element = ObjectType objectType - traverser = polymorphicTypeTraverser interfaces fields + fields = extractObjectField <$> resolvers + traverser = polymorphicTraverser interfaces fields in collect traverser typeName element foundTypes traverseInterfaceType interfaceType foundTypes = let (Out.InterfaceType typeName _ interfaces fields) = interfaceType element = InterfaceType interfaceType - traverser = polymorphicTypeTraverser interfaces fields + traverser = polymorphicTraverser interfaces fields in collect traverser typeName element foundTypes - polymorphicTypeTraverser interfaces fields + 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 fcab7ad..df90558 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-15.14 +resolver: lts-15.15 packages: - . diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs index 55a5277..ca1103b 100644 --- a/tests/Test/DirectiveSpec.hs +++ b/tests/Test/DirectiveSpec.hs @@ -20,7 +20,7 @@ experimentalResolver = Schema { query = queryType, mutation = Nothing } resolver = pure $ Int 5 queryType = Out.ObjectType "Query" Nothing [] $ HashMap.singleton "experimentalField" - $ Out.Field Nothing (Out.NamedScalarType int) mempty resolver + $ Out.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 36e88b1..0737706 100644 --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -54,32 +54,38 @@ hasErrors _ = True shirtType :: Out.ObjectType IO shirtType = Out.ObjectType "Shirt" Nothing [] $ HashMap.fromList - [ ("size", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ snd size) - , ("circumference", Out.Field Nothing (Out.NamedScalarType int) mempty $ pure $ snd circumference) - , ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ String "Shirt") + [ ("size", Out.Resolver sizeFieldType $ pure $ snd size) + , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference) ] hatType :: Out.ObjectType IO hatType = Out.ObjectType "Hat" Nothing [] $ HashMap.fromList - [ ("size", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ snd size) - , ("circumference", Out.Field Nothing (Out.NamedScalarType int) mempty $ pure $ snd circumference) - , ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ String "Hat") + [ ("size", Out.Resolver sizeFieldType $ pure $ snd size) + , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference) ] +circumferenceFieldType :: Out.Field IO +circumferenceFieldType = Out.Field Nothing (Out.NamedScalarType int) mempty + +sizeFieldType :: Out.Field IO +sizeFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty + toSchema :: Text -> (Text, Value) -> Schema IO toSchema t (_, resolve) = Schema { query = queryType, mutation = Nothing } where unionMember = if t == "Hat" then hatType else shirtType + typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty + garmentField = Out.Field Nothing (Out.NamedObjectType unionMember) mempty queryType = case t of "circumference" -> hatType "size" -> shirtType _ -> Out.ObjectType "Query" Nothing [] $ HashMap.fromList - [ ("garment", Out.Field Nothing (Out.NamedObjectType unionMember) mempty $ pure resolve) - , ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ String "Shirt") + [ ("garment", Out.Resolver garmentField $ pure resolve) + , ("__typename", Out.Resolver typeNameField $ pure $ String "Shirt") ] spec :: Spec diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs index 3b21788..922e098 100644 --- a/tests/Test/RootOperationSpec.hs +++ b/tests/Test/RootOperationSpec.hs @@ -16,7 +16,7 @@ import Language.GraphQL.Type.Schema hatType :: Out.ObjectType IO hatType = Out.ObjectType "Hat" Nothing [] $ HashMap.singleton "circumference" - $ Out.Field Nothing (Out.NamedScalarType int) mempty + $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty) $ pure $ Int 60 schema :: Schema IO @@ -28,10 +28,10 @@ schema = Schema [ ("circumference", Int 60) ] incrementField = HashMap.singleton "incrementCircumference" - $ Out.Field Nothing (Out.NamedScalarType int) mempty + $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty) $ pure $ Int 61 hatField = HashMap.singleton "garment" - $ Out.Field Nothing (Out.NamedObjectType hatType) mempty garment + $ Out.Resolver (Out.Field Nothing (Out.NamedObjectType hatType) mempty) garment spec :: Spec spec = diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index 0ab10ec..b30da1a 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -24,32 +24,51 @@ schema :: Schema Identity schema = Schema { query = queryType, mutation = Nothing } where queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList - [ ("hero", Out.Field Nothing (Out.NamedObjectType heroObject) mempty hero) - , ("human", Out.Field Nothing (Out.NamedObjectType heroObject) mempty human) - , ("droid", Out.Field Nothing (Out.NamedObjectType droidObject) mempty droid) + [ ("hero", Out.Resolver (Out.Field Nothing (Out.NamedObjectType heroObject) mempty) hero) + , ("human", Out.Resolver (Out.Field Nothing (Out.NamedObjectType heroObject) mempty) human) + , ("droid", Out.Resolver (Out.Field Nothing (Out.NamedObjectType droidObject) mempty) droid) ] heroObject :: Out.ObjectType Identity heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList - [ ("id", Out.Field Nothing (Out.NamedScalarType id) mempty (idField "id")) - , ("name", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "name")) - , ("friends", Out.Field Nothing (Out.ListType $ Out.NamedObjectType heroObject) mempty (idField "friends")) - , ("appearsIn", Out.Field Nothing (Out.ListType $ Out.NamedScalarType int) mempty (idField "appearsIn")) - , ("homePlanet", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "homePlanet")) - , ("secretBackstory", Out.Field Nothing (Out.NamedScalarType string) mempty (String <$> secretBackstory)) - , ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "__typename")) + [ ("id", Out.Resolver idFieldType (idField "id")) + , ("name", Out.Resolver nameFieldType (idField "name")) + , ("friends", Out.Resolver friendsFieldType (idField "friends")) + , ("appearsIn", Out.Resolver appearsInFieldType (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")) ] + where + homePlanetFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty droidObject :: Out.ObjectType Identity droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList - [ ("id", Out.Field Nothing (Out.NamedScalarType id) mempty (idField "id")) - , ("name", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "name")) - , ("friends", Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty (idField "friends")) - , ("appearsIn", Out.Field Nothing (Out.ListType $ Out.NamedScalarType int) mempty (idField "appearsIn")) - , ("primaryFunction", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "primaryFunction")) - , ("secretBackstory", Out.Field Nothing (Out.NamedScalarType string) mempty (String <$> secretBackstory)) - , ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "__typename")) + [ ("id", Out.Resolver idFieldType (idField "id")) + , ("name", Out.Resolver nameFieldType (idField "name")) + , ("friends", Out.Resolver friendsFieldType (idField "friends")) + , ("appearsIn", Out.Resolver appearsInFieldType (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")) ] + where + primaryFunctionFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty + +idFieldType :: Out.Field Identity +idFieldType = Out.Field Nothing (Out.NamedScalarType id) mempty + +nameFieldType :: Out.Field Identity +nameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty + +friendsFieldType :: Out.Field Identity +friendsFieldType = Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty + +appearsInFieldType :: Out.Field Identity +appearsInFieldType = Out.Field Nothing (Out.ListType $ Out.NamedScalarType int) mempty + +secretBackstoryFieldType :: Out.Field Identity +secretBackstoryFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty idField :: Text -> ActionT Identity Value idField f = do