1
0
forked from OSS/graphql

Resolve abstract types

Objects that can be a part of an union or interface should return
__typename as string.
This commit is contained in:
Eugen Wissner 2020-06-03 07:20:38 +02:00
parent d12577ae71
commit 93a0403288
14 changed files with 217 additions and 166 deletions

View File

@ -17,8 +17,8 @@ and this project adheres to
* Invalid (recusrive or non-existing) fragments should be skipped. * Invalid (recusrive or non-existing) fragments should be skipped.
### Changed ### Changed
- `Schema.Resolver` cannot return arbitrary JSON anymore, but only - `Schema.Resolver` was moved to `Type.Out`, it is a field and resolver function
`Type.Definition.Value`. pair.
- `AST.Core.Value` was moved into `Type.Definition`. These values are used only - `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. 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 - `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 - `Schema.wrappedObject`, `Schema.object`, `Schema.resolversToMap`. There is no
need in special functions to construct field resolvers anymore, resolvers are need in special functions to construct field resolvers anymore, resolvers are
normal functions attached to the fields in the schema representation. normal functions attached to the fields in the schema representation.
- `Schema.resolve` is superseded by `Execute.Execution`.
- `Error.runAppendErrs` isn't used anywhere. - `Error.runAppendErrs` isn't used anywhere.
- `AST.Core`: `Document`, `Directive`, `Field`, `Fragment`, `Selection`, `Alias` - `AST.Core`: `Document`, `Directive`, `Field`, `Fragment`, `Selection`, `Alias`
`TypeCondition` were modified, moved into `Execute.Transform.Document` and `TypeCondition` were modified, moved into `Execute.Transform.Document` and

View File

@ -42,7 +42,10 @@ First we build a GraphQL schema.
> queryType :: ObjectType IO > queryType :: ObjectType IO
> queryType = ObjectType "Query" Nothing [] > queryType = ObjectType "Query" Nothing []
> $ HashMap.singleton "hello" > $ 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 :: ActionT IO Value
> hello = pure $ String "it's me" > 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 IO
> queryType2 = ObjectType "Query" Nothing [] > queryType2 = ObjectType "Query" Nothing []
> $ HashMap.singleton "time" > $ 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 :: ActionT IO Value
> time = do > 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 IO
> queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList > queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList
> [ ("hello", Field Nothing (Out.NamedScalarType string) mempty hello) > [ ("hello", Out.Resolver helloField hello)
> , ("time", Field Nothing (Out.NamedScalarType string) mempty time) > , ("time", Out.Resolver timeField time)
> ] > ]
> >
> query3 :: Text > query3 :: Text

View File

@ -16,7 +16,7 @@ import Language.GraphQL.Type.Schema
import Text.Megaparsec (parse) import Text.Megaparsec (parse)
-- | If the text parses correctly as a @GraphQL@ query the query is -- | 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 graphql :: Monad m
=> Schema m -- ^ Resolvers. => Schema m -- ^ Resolvers.
-> Text -- ^ Text representing a @GraphQL@ request document. -> 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 -- | 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 -- applied to the query and the query is then executed using to the given
-- 'Schema.Resolver's. -- 'Schema'.
graphqlSubs :: (Monad m, VariableValue a) graphqlSubs :: (Monad m, VariableValue a)
=> Schema m -- ^ Resolvers. => Schema m -- ^ Resolvers.
-> HashMap Name a -- ^ Variable substitution function. -> HashMap Name a -- ^ Variable substitution function.

View File

@ -29,6 +29,7 @@ import Text.Megaparsec
, unPos , unPos
) )
-- | Executor context.
data Resolution m = Resolution data Resolution m = Resolution
{ errors :: [Aeson.Value] { errors :: [Aeson.Value]
, types :: HashMap Name (Type m) , types :: HashMap Name (Type m)

View File

@ -11,10 +11,10 @@ import Data.Sequence (Seq(..))
import Data.Text (Text) import Data.Text (Text)
import Language.GraphQL.AST.Document (Document, Name) import Language.GraphQL.AST.Document (Document, Name)
import Language.GraphQL.Execute.Coerce import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Execute.Execution
import qualified Language.GraphQL.Execute.Transform as Transform import qualified Language.GraphQL.Execute.Transform as Transform
import Language.GraphQL.Error import Language.GraphQL.Error
import Language.GraphQL.Type.Definition import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Schema as Schema
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema import Language.GraphQL.Type.Schema
@ -68,4 +68,4 @@ executeOperation :: Monad m
-> Seq (Transform.Selection m) -> Seq (Transform.Selection m)
-> m Aeson.Value -> m Aeson.Value
executeOperation types' objectType fields = executeOperation types' objectType fields =
runCollectErrs types' $ Schema.resolve Null objectType fields runCollectErrs types' $ executeSelectionSet Null objectType fields

View File

@ -1,20 +1,38 @@
{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Language.GraphQL.Execute.Execution module Language.GraphQL.Execute.Execution
( aliasOrName ( executeSelectionSet
, collectFields
) where ) 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.Map.Strict (Map)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe) 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 qualified Data.Sequence as Seq
import Language.GraphQL.AST.Document (Name) import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.Error
import Language.GraphQL.Execute.Transform import Language.GraphQL.Execute.Transform
import Language.GraphQL.Trans
import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema 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 collectFields :: Monad m
=> Out.ObjectType m => Out.ObjectType m
-> Seq (Selection m) -> Seq (Selection m)
@ -34,6 +52,21 @@ collectFields objectType = foldl forEach Map.empty
aliasOrName :: forall m. Field m -> Name aliasOrName :: forall m. Field m -> Name
aliasOrName (Field alias name _ _) = fromMaybe name alias 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 doesFragmentTypeApply :: forall m
. CompositeType m . CompositeType m
-> Out.ObjectType m -> Out.ObjectType m
@ -43,16 +76,88 @@ doesFragmentTypeApply (CompositeObjectType fragmentType) objectType =
Out.ObjectType objectName _ _ _ = objectType Out.ObjectType objectName _ _ _ = objectType
in fragmentName == objectName in fragmentName == objectName
doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType = doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType =
let Out.ObjectType _ _ interfaces _ = objectType instanceOf objectType $ AbstractInterfaceType fragmentType
in foldr instanceOf False interfaces
where
instanceOf (Out.InterfaceType that _ interfaces _) acc =
let Out.InterfaceType this _ _ _ = fragmentType
in acc || foldr instanceOf (this == that) interfaces
doesFragmentTypeApply (CompositeUnionType fragmentType) objectType = doesFragmentTypeApply (CompositeUnionType fragmentType) objectType =
let Out.UnionType _ _ members = fragmentType instanceOf objectType $ AbstractUnionType fragmentType
in foldr instanceOf False members
instanceOf :: forall m. Out.ObjectType m -> AbstractType m -> Bool
instanceOf objectType (AbstractInterfaceType interfaceType) =
let Out.ObjectType _ _ interfaces _ = objectType
in foldr go False interfaces
where 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 let Out.ObjectType this _ _ _ = objectType
in acc || this == that 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."]

View File

@ -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'-}

View File

@ -10,6 +10,7 @@ module Language.GraphQL.Type.Out
( Field(..) ( Field(..)
, InterfaceType(..) , InterfaceType(..)
, ObjectType(..) , ObjectType(..)
, Resolver(..)
, Type(..) , Type(..)
, UnionType(..) , UnionType(..)
, isNonNullType , isNonNullType
@ -27,13 +28,22 @@ import Language.GraphQL.AST.Core
import Language.GraphQL.Trans import Language.GraphQL.Trans
import Language.GraphQL.Type.Definition import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.In as In 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. -- | Object type definition.
-- --
-- Almost all of the GraphQL types you define will be object types. Object -- Almost all of the GraphQL types you define will be object types. Object
-- types have a name, but most importantly describe their fields. -- types have a name, but most importantly describe their fields.
data ObjectType m = ObjectType 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. -- | Interface Type Definition.
-- --
@ -54,7 +64,6 @@ data Field m = Field
(Maybe Text) -- ^ Description. (Maybe Text) -- ^ Description.
(Type m) -- ^ Field type. (Type m) -- ^ Field type.
(HashMap Name In.Argument) -- ^ Arguments. (HashMap Name In.Argument) -- ^ Arguments.
(ActionT m Value) -- ^ Resolver.
-- | These types may be used as output types as the result of fields. -- | These types may be used as output types as the result of fields.
-- --

View File

@ -1,8 +1,10 @@
{-# LANGUAGE ExplicitForAll #-} {-# 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 module Language.GraphQL.Type.Schema
( CompositeType(..) ( AbstractType(..)
, CompositeType(..)
, Schema(..) , Schema(..)
, Type(..) , Type(..)
, collectReferencedTypes , collectReferencedTypes
@ -30,6 +32,11 @@ data CompositeType m
| CompositeObjectType (Out.ObjectType m) | CompositeObjectType (Out.ObjectType m)
| CompositeInterfaceType (Out.InterfaceType 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, -- | 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 -- query and mutation (optional). A schema definition is then supplied to the
-- validator and executor. -- validator and executor.
@ -51,7 +58,7 @@ collectReferencedTypes schema =
collect traverser typeName element foundTypes collect traverser typeName element foundTypes
| HashMap.member typeName foundTypes = foundTypes | HashMap.member typeName foundTypes = foundTypes
| otherwise = traverser $ HashMap.insert typeName element foundTypes | otherwise = traverser $ HashMap.insert typeName element foundTypes
visitFields (Out.Field _ outputType arguments _) foundTypes visitFields (Out.Field _ outputType arguments) foundTypes
= traverseOutputType outputType = traverseOutputType outputType
$ foldr visitArguments foundTypes arguments $ foldr visitArguments foundTypes arguments
visitArguments (In.Argument _ inputType _) = traverseInputType inputType visitArguments (In.Argument _ inputType _) = traverseInputType inputType
@ -86,15 +93,17 @@ collectReferencedTypes schema =
let (Definition.EnumType typeName _ _) = enumType let (Definition.EnumType typeName _ _) = enumType
in collect Prelude.id typeName (EnumType enumType) in collect Prelude.id typeName (EnumType enumType)
traverseObjectType objectType foundTypes = traverseObjectType objectType foundTypes =
let (Out.ObjectType typeName _ interfaces fields) = objectType let (Out.ObjectType typeName _ interfaces resolvers) = objectType
element = ObjectType objectType element = ObjectType objectType
traverser = polymorphicTypeTraverser interfaces fields fields = extractObjectField <$> resolvers
traverser = polymorphicTraverser interfaces fields
in collect traverser typeName element foundTypes in collect traverser typeName element foundTypes
traverseInterfaceType interfaceType foundTypes = traverseInterfaceType interfaceType foundTypes =
let (Out.InterfaceType typeName _ interfaces fields) = interfaceType let (Out.InterfaceType typeName _ interfaces fields) = interfaceType
element = InterfaceType interfaceType element = InterfaceType interfaceType
traverser = polymorphicTypeTraverser interfaces fields traverser = polymorphicTraverser interfaces fields
in collect traverser typeName element foundTypes in collect traverser typeName element foundTypes
polymorphicTypeTraverser interfaces fields polymorphicTraverser interfaces fields
= flip (foldr visitFields) fields = flip (foldr visitFields) fields
. flip (foldr traverseInterfaceType) interfaces . flip (foldr traverseInterfaceType) interfaces
extractObjectField (Out.Resolver field _) = field

View File

@ -1,4 +1,4 @@
resolver: lts-15.14 resolver: lts-15.15
packages: packages:
- . - .

View File

@ -20,7 +20,7 @@ experimentalResolver = Schema { query = queryType, mutation = Nothing }
resolver = pure $ Int 5 resolver = pure $ Int 5
queryType = Out.ObjectType "Query" Nothing [] queryType = Out.ObjectType "Query" Nothing []
$ HashMap.singleton "experimentalField" $ 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 :: Aeson.Value
emptyObject = object emptyObject = object

View File

@ -54,32 +54,38 @@ hasErrors _ = True
shirtType :: Out.ObjectType IO shirtType :: Out.ObjectType IO
shirtType = Out.ObjectType "Shirt" Nothing [] shirtType = Out.ObjectType "Shirt" Nothing []
$ HashMap.fromList $ HashMap.fromList
[ ("size", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ snd size) [ ("size", Out.Resolver sizeFieldType $ pure $ snd size)
, ("circumference", Out.Field Nothing (Out.NamedScalarType int) mempty $ pure $ snd circumference) , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference)
, ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ String "Shirt")
] ]
hatType :: Out.ObjectType IO hatType :: Out.ObjectType IO
hatType = Out.ObjectType "Hat" Nothing [] hatType = Out.ObjectType "Hat" Nothing []
$ HashMap.fromList $ HashMap.fromList
[ ("size", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ snd size) [ ("size", Out.Resolver sizeFieldType $ pure $ snd size)
, ("circumference", Out.Field Nothing (Out.NamedScalarType int) mempty $ pure $ snd circumference) , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference)
, ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ String "Hat")
] ]
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 :: Text -> (Text, Value) -> Schema IO
toSchema t (_, resolve) = Schema toSchema t (_, resolve) = Schema
{ query = queryType, mutation = Nothing } { query = queryType, mutation = Nothing }
where where
unionMember = if t == "Hat" then hatType else shirtType 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 = queryType =
case t of case t of
"circumference" -> hatType "circumference" -> hatType
"size" -> shirtType "size" -> shirtType
_ -> Out.ObjectType "Query" Nothing [] _ -> Out.ObjectType "Query" Nothing []
$ HashMap.fromList $ HashMap.fromList
[ ("garment", Out.Field Nothing (Out.NamedObjectType unionMember) mempty $ pure resolve) [ ("garment", Out.Resolver garmentField $ pure resolve)
, ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ String "Shirt") , ("__typename", Out.Resolver typeNameField $ pure $ String "Shirt")
] ]
spec :: Spec spec :: Spec

View File

@ -16,7 +16,7 @@ import Language.GraphQL.Type.Schema
hatType :: Out.ObjectType IO hatType :: Out.ObjectType IO
hatType = Out.ObjectType "Hat" Nothing [] hatType = Out.ObjectType "Hat" Nothing []
$ HashMap.singleton "circumference" $ HashMap.singleton "circumference"
$ Out.Field Nothing (Out.NamedScalarType int) mempty $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
$ pure $ Int 60 $ pure $ Int 60
schema :: Schema IO schema :: Schema IO
@ -28,10 +28,10 @@ schema = Schema
[ ("circumference", Int 60) [ ("circumference", Int 60)
] ]
incrementField = HashMap.singleton "incrementCircumference" incrementField = HashMap.singleton "incrementCircumference"
$ Out.Field Nothing (Out.NamedScalarType int) mempty $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
$ pure $ Int 61 $ pure $ Int 61
hatField = HashMap.singleton "garment" 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 :: Spec
spec = spec =

View File

@ -24,32 +24,51 @@ schema :: Schema Identity
schema = Schema { query = queryType, mutation = Nothing } schema = Schema { query = queryType, mutation = Nothing }
where where
queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
[ ("hero", Out.Field Nothing (Out.NamedObjectType heroObject) mempty hero) [ ("hero", Out.Resolver (Out.Field Nothing (Out.NamedObjectType heroObject) mempty) hero)
, ("human", Out.Field Nothing (Out.NamedObjectType heroObject) mempty human) , ("human", Out.Resolver (Out.Field Nothing (Out.NamedObjectType heroObject) mempty) human)
, ("droid", Out.Field Nothing (Out.NamedObjectType droidObject) mempty droid) , ("droid", Out.Resolver (Out.Field Nothing (Out.NamedObjectType droidObject) mempty) droid)
] ]
heroObject :: Out.ObjectType Identity heroObject :: Out.ObjectType Identity
heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
[ ("id", Out.Field Nothing (Out.NamedScalarType id) mempty (idField "id")) [ ("id", Out.Resolver idFieldType (idField "id"))
, ("name", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "name")) , ("name", Out.Resolver nameFieldType (idField "name"))
, ("friends", Out.Field Nothing (Out.ListType $ Out.NamedObjectType heroObject) mempty (idField "friends")) , ("friends", Out.Resolver friendsFieldType (idField "friends"))
, ("appearsIn", Out.Field Nothing (Out.ListType $ Out.NamedScalarType int) mempty (idField "appearsIn")) , ("appearsIn", Out.Resolver appearsInFieldType (idField "appearsIn"))
, ("homePlanet", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "homePlanet")) , ("homePlanet", Out.Resolver homePlanetFieldType (idField "homePlanet"))
, ("secretBackstory", Out.Field Nothing (Out.NamedScalarType string) mempty (String <$> secretBackstory)) , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))
, ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "__typename")) , ("__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 Identity
droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
[ ("id", Out.Field Nothing (Out.NamedScalarType id) mempty (idField "id")) [ ("id", Out.Resolver idFieldType (idField "id"))
, ("name", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "name")) , ("name", Out.Resolver nameFieldType (idField "name"))
, ("friends", Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty (idField "friends")) , ("friends", Out.Resolver friendsFieldType (idField "friends"))
, ("appearsIn", Out.Field Nothing (Out.ListType $ Out.NamedScalarType int) mempty (idField "appearsIn")) , ("appearsIn", Out.Resolver appearsInFieldType (idField "appearsIn"))
, ("primaryFunction", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "primaryFunction")) , ("primaryFunction", Out.Resolver primaryFunctionFieldType (idField "primaryFunction"))
, ("secretBackstory", Out.Field Nothing (Out.NamedScalarType string) mempty (String <$> secretBackstory)) , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))
, ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "__typename")) , ("__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 :: Text -> ActionT Identity Value
idField f = do idField f = do