Resolve abstract types
Objects that can be a part of an union or interface should return __typename as string.
This commit is contained in:
parent
d12577ae71
commit
93a0403288
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -29,6 +29,7 @@ import Text.Megaparsec
|
|||
, unPos
|
||||
)
|
||||
|
||||
-- | Executor context.
|
||||
data Resolution m = Resolution
|
||||
{ errors :: [Aeson.Value]
|
||||
, types :: HashMap Name (Type m)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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."]
|
||||
|
|
|
|||
|
|
@ -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'-}
|
||||
|
|
@ -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.
|
||||
--
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
resolver: lts-15.14
|
||||
resolver: lts-15.15
|
||||
|
||||
packages:
|
||||
- .
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue