Allow resolvers to return arbitrary nested lists

This commit is contained in:
Eugen Wissner 2019-07-05 20:05:04 +02:00
parent 2fa50d4f62
commit d7b6fd0329
4 changed files with 113 additions and 61 deletions

View File

@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: 83313d55668f177f44fe72b0e590759e61e44093406bd0e7d41af66dd9199c92
-- hash: 2f09ae8e288ccdea02b6f59bec6625b3f8795841f7ccf7cb19d1de428f0f63cb
name: graphql
version: 0.3
@ -48,6 +48,7 @@ library
Data.GraphQL.Schema
Language.GraphQL.Lexer
Language.GraphQL.Trans
Language.GraphQL.Type
other-modules:
Paths_graphql
hs-source-dirs:

View File

@ -3,22 +3,22 @@
-- | This module provides a representation of a @GraphQL@ Schema in addition to
-- functions for defining and manipulating Schemas.
module Data.GraphQL.Schema
( Schema
, Resolver
( Resolver
, Schema
, Subs
, nullableArray
, nullableEnum
, nullableObject
, nullableScalar
, object
, objectA
, scalar
, scalarA
, array
, arrayA
, enum
, enumA
, resolve
, wrappedEnum
, wrappedEnumA
, wrappedObject
, wrappedObjectA
, wrappedScalar
, wrappedScalarA
-- * AST Reexports
, Field
, Argument(..)
@ -40,6 +40,7 @@ import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import qualified Data.Text as T
import Language.GraphQL.Trans
import Language.GraphQL.Type
import Data.GraphQL.AST.Core
-- | A GraphQL schema.
@ -70,14 +71,18 @@ objectA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld
-- | Like 'object' but can be null.
nullableObject :: MonadPlus m
=> Name -> (Arguments -> ActionT m (Maybe [Resolver m])) -> Resolver m
nullableObject name f = Resolver name $ resolveFieldValue f resolveRight
-- | Like 'object' but also taking 'Argument's and can be null or a list of objects.
wrappedObjectA :: MonadPlus m
=> Name -> (Arguments -> ActionT m (Wrapping [Resolver m])) -> Resolver m
wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld@(Field _ _ _ flds) (Just resolver) = withField (resolve resolver flds) fld
resolveRight fld Nothing
= return $ HashMap.singleton (aliasOrName fld) Aeson.Null
resolveRight fld@(Field _ _ _ sels) resolver
= withField (traverse (`resolve` sels) resolver) fld
-- | Like 'object' but can be null or a list of objects.
wrappedObject :: MonadPlus m
=> Name -> ActionT m (Wrapping [Resolver m]) -> Resolver m
wrappedObject name = wrappedObjectA name . const
-- | A scalar represents a primitive value, like a string or an integer.
scalar :: (MonadPlus m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
@ -88,40 +93,22 @@ scalarA :: (MonadPlus m, Aeson.ToJSON a)
=> Name -> (Arguments -> ActionT m a) -> Resolver m
scalarA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld@(Field _ _ _ []) result = withField (return result) fld
resolveRight _ _ = mzero
resolveRight fld result = withField (return result) fld
-- | Lika 'scalar' but can be null.
nullableScalar :: (MonadPlus m, Aeson.ToJSON a)
=> Name -> (Arguments -> ActionT m (Maybe a)) -> Resolver m
nullableScalar name f = Resolver name $ resolveFieldValue f resolveRight
-- | Lika 'scalar' but also taking 'Argument's and can be null or a list of scalars.
wrappedScalarA :: (MonadPlus m, Aeson.ToJSON a)
=> Name -> (Arguments -> ActionT m (Wrapping a)) -> Resolver m
wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld@(Field _ _ _ []) (Just result) = withField (return result) fld
resolveRight fld Nothing
resolveRight fld (Named result) = withField (return result) fld
resolveRight fld Null
= return $ HashMap.singleton (aliasOrName fld) Aeson.Null
resolveRight _ _ = mzero
resolveRight fld (List result) = withField (return result) fld
-- | Creates a list of 'Resolver's.
array :: MonadPlus m => Name -> ActionT m [[Resolver m]] -> Resolver m
array name = arrayA name . const
-- | Like 'array' but also taking 'Argument's.
arrayA :: MonadPlus m
=> Name -> (Arguments -> ActionT m [[Resolver m]]) -> Resolver m
arrayA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld@(Field _ _ _ sels) resolver
= withField (traverse (`resolve` sels) resolver) fld
-- | Like 'array' but can be null.
nullableArray :: MonadPlus m
=> Name -> (Arguments -> ActionT m (Maybe [[Resolver m]])) -> Resolver m
nullableArray name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld@(Field _ _ _ sels) (Just resolver)
= withField (traverse (`resolve` sels) resolver) fld
resolveRight fld Nothing
= return $ HashMap.singleton (aliasOrName fld) Aeson.Null
-- | Like 'scalar' but can be null or a list of scalars.
wrappedScalar :: (MonadPlus m, Aeson.ToJSON a)
=> Name -> ActionT m (Wrapping a) -> Resolver m
wrappedScalar name = wrappedScalarA name . const
-- | Represents one of a finite set of possible values.
-- Used in place of a 'scalar' when the possible responses are easily enumerable.
@ -134,14 +121,19 @@ enumA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld resolver = withField (return resolver) fld
-- | Like 'array'' but also taking 'Argument's.
nullableEnum :: MonadPlus m
=> Name -> (Arguments -> ActionT m (Maybe [Text])) -> Resolver m
nullableEnum name f = Resolver name $ resolveFieldValue f resolveRight
-- | Like 'enum' but also taking 'Argument's and can be null or a list of enums.
wrappedEnumA :: MonadPlus m
=> Name -> (Arguments -> ActionT m (Wrapping [Text])) -> Resolver m
wrappedEnumA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld (Just resolver) = withField (return resolver) fld
resolveRight fld Nothing
resolveRight fld (Named resolver) = withField (return resolver) fld
resolveRight fld Null
= return $ HashMap.singleton (aliasOrName fld) Aeson.Null
resolveRight fld (List resolver) = withField (return resolver) fld
-- | Like 'enum' but can be null or a list of enums.
wrappedEnum :: MonadPlus m => Name -> ActionT m (Wrapping [Text]) -> Resolver m
wrappedEnum name = wrappedEnumA name . const
resolveFieldValue :: MonadPlus m
=> ([Argument] -> ActionT m a)

View File

@ -0,0 +1,57 @@
-- | Definitions for @GraphQL@ type system.
module Language.GraphQL.Type
( Wrapping(..)
) where
import Data.Aeson as Aeson ( ToJSON
, toJSON
)
import qualified Data.Aeson as Aeson
-- | GraphQL distinguishes between "wrapping" and "named" types. Each wrapping
-- type can wrap other wrapping or named types. Wrapping types are lists and
-- Non-Null types (named types are nullable by default).
--
-- This 'Wrapping' type doesn\'t reflect this distinction exactly but it is
-- used in the resolvers to take into account that the returned value can be
-- nullable or an (arbitrary nested) list.
data Wrapping a
= List [Wrapping a] -- ^ Arbitrary nested list
| Named a -- ^ Named type without further wrapping
| Null -- ^ Null
deriving (Eq, Show)
instance Functor Wrapping where
fmap f (List list) = List $ fmap (fmap f) list
fmap f (Named named) = Named $ f named
fmap _ Null = Null
instance Foldable Wrapping where
foldr f acc (List list) = foldr (flip $ foldr f) acc list
foldr f acc (Named named) = f named acc
foldr _ acc Null = acc
instance Traversable Wrapping where
traverse f (List list) = List <$> traverse (traverse f) list
traverse f (Named named) = Named <$> f named
traverse _ Null = pure Null
instance Applicative Wrapping where
pure = Named
Null <*> _ = Null
_ <*> Null = Null
(Named f) <*> (Named x) = Named $ f x
(List fs) <*> (List xs) = List $ (<*>) <$> fs <*> xs
(Named f) <*> list = f <$> list
(List fs) <*> named = List $ (<*> named) <$> fs
instance Monad Wrapping where
return = pure
Null >>= _ = Null
(Named x) >>= f = f x
(List xs) >>= f = List $ fmap (>>= f) xs
instance ToJSON a => ToJSON (Wrapping a) where
toJSON (List list) = toJSON list
toJSON (Named named) = toJSON named
toJSON Null = Aeson.Null

View File

@ -13,6 +13,7 @@ import Data.GraphQL.Schema ( Schema
)
import qualified Data.GraphQL.Schema as Schema
import Language.GraphQL.Trans
import Language.GraphQL.Type
import Test.StarWars.Data
-- * Schema
@ -30,12 +31,12 @@ hero = Schema.objectA "hero" $ \case
_ -> ActionT $ throwE "Invalid arguments."
human :: MonadPlus m => Resolver m
human = Schema.nullableObject "human" $ \case
human = Schema.wrappedObjectA "human" $ \case
[Argument "id" (ValueString i)] -> do
humanCharacter <- lift $ return $ getHuman i >>= Just
case humanCharacter of
Nothing -> return Nothing
Just e -> Just <$> character e
Nothing -> return Null
Just e -> Named <$> character e
_ -> ActionT $ throwE "Invalid arguments."
droid :: MonadPlus m => Resolver m
@ -47,7 +48,8 @@ character :: MonadPlus m => Character -> ActionT m [Resolver m]
character char = return
[ Schema.scalar "id" $ return $ id_ char
, Schema.scalar "name" $ return $ name char
, Schema.array "friends" $ traverse character $ getFriends char
, Schema.wrappedObject "friends"
$ traverse character $ List $ Named <$> getFriends char
, Schema.enum "appearsIn" $ return $ foldMap getEpisode $ appearsIn char
, Schema.scalar "secretBackstory" $ secretBackstory char
, Schema.scalar "homePlanet" $ return $ either mempty homePlanet char