OSS/graphql
1
1
Fork 1
Code Issues 5 Pull Requests Actions Releases 22 Wiki Activity

Pass root field names together with resolvers

Browse Source
This commit is contained in:
Eugen Wissner 2019-07-01 06:39:13 +02:00
parent f64e186c60
commit 1017b728d9
1 changed files with 56 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

79
src/Data/GraphQL/Schema.hs
View File

@ -31,14 +31,16 @@ import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State ( get import Control.Monad.Trans.State ( get
, put , put
) )
import Data.Foldable (fold) import Data.Foldable ( find
, fold
)
import Data.GraphQL.Error import Data.GraphQL.Error
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Monoid (Alt(..))
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.GraphQL.AST.Core import Data.GraphQL.AST.Core
@ -48,10 +50,10 @@ import Data.GraphQL.AST.Core
type Schema m = NonEmpty (Resolver m) type Schema m = NonEmpty (Resolver m)
-- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information -- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information
-- (or 'empty'). @f@ is usually expected to be an instance of 'Alternative'. -- (or 'empty'). @m@ is usually expected to be an instance of 'MonadPlus'.
type Resolver m = Field -> CollectErrsT m Aeson.Object data Resolver m = Resolver
Text -- ^ Name
type Resolvers m = [Resolver m] (Field -> CollectErrsT m Aeson.Object) -- ^ Resolver
type Fields = [Field] type Fields = [Field]
@ -61,7 +63,7 @@ type Arguments = [Argument]
type Subs = Name -> Maybe Value type Subs = Name -> Maybe Value
-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's. -- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
object :: MonadPlus m => Name -> Resolvers m -> Resolver m object :: MonadPlus m => Name -> [Resolver m] -> Resolver m
object name resolvers = objectA name $ \case object name resolvers = objectA name $ \case
[] -> resolvers [] -> resolvers
_ -> empty _ -> empty
@ -69,12 +71,14 @@ object name resolvers = objectA name $ \case
-- | Like 'object' but also taking 'Argument's. -- | Like 'object' but also taking 'Argument's.
objectA objectA
:: MonadPlus m :: MonadPlus m
=> Name -> (Arguments -> Resolvers m) -> Resolver m => Name -> (Arguments -> [Resolver m]) -> Resolver m
objectA name f fld@(Field _ _ args flds) = withField name (resolve (f args) flds) fld objectA name f = Resolver name go
where
go fld@(Field _ _ args flds) = withField name (resolve (f args) flds) fld
-- | Create a named 'Resolver' from a list of 'Resolver's. -- | Create a named 'Resolver' from a list of 'Resolver's.
object' :: MonadPlus m => Name -> m (Resolvers m) -> Resolver m object' :: MonadPlus m => Name -> m [Resolver m] -> Resolver m
object' name resolvs = objectA' name $ \case object' name resolvs = objectA' name $ \case
[] -> resolvs [] -> resolvs
_ -> empty _ -> empty
@ -82,8 +86,10 @@ object' name resolvs = objectA' name $ \case
-- | Like 'object'' but also taking 'Argument's. -- | Like 'object'' but also taking 'Argument's.
objectA' objectA'
:: MonadPlus m :: MonadPlus m
=> Name -> (Arguments -> m (Resolvers m)) -> Resolver m => Name -> (Arguments -> m [Resolver m]) -> Resolver m
objectA' name f fld@(Field _ _ args flds) = do objectA' name f = Resolver name go
where
go fld@(Field _ _ args flds) = do
resolvs <- lift $ f args resolvs <- lift $ f args
withField name (resolve resolvs flds) fld withField name (resolve resolvs flds) fld
@ -97,10 +103,12 @@ scalar name s = scalarA name $ \case
scalarA scalarA
:: (MonadPlus m, Aeson.ToJSON a) :: (MonadPlus m, Aeson.ToJSON a)
=> Name -> (Arguments -> m a) -> Resolver m => Name -> (Arguments -> m a) -> Resolver m
scalarA name f fld@(Field _ _ args []) = withField name (lift $ f args) fld scalarA name f = Resolver name go
scalarA _ _ _ = empty where
go fld@(Field _ _ args []) = withField name (lift $ f args) fld
go _ = empty
array :: MonadPlus m => Name -> [Resolvers m] -> Resolver m array :: MonadPlus m => Name -> [[Resolver m]] -> Resolver m
array name resolvers = arrayA name $ \case array name resolvers = arrayA name $ \case
[] -> resolvers [] -> resolvers
_ -> empty _ -> empty
@ -108,12 +116,13 @@ array name resolvers = arrayA name $ \case
-- | Like 'array' but also taking 'Argument's. -- | Like 'array' but also taking 'Argument's.
arrayA arrayA
:: MonadPlus m :: MonadPlus m
=> Name -> (Arguments -> [Resolvers m]) -> Resolver m => Name -> (Arguments -> [[Resolver m]]) -> Resolver m
arrayA name f fld@(Field _ _ args sels) = arrayA name f = Resolver name go
withField name (traverse (`resolve` sels) $ f args) fld where
go fld@(Field _ _ args sels) = withField name (traverse (`resolve` sels) $ f args) fld
-- | Like 'object'' but taking lists of 'Resolver's instead of a single list. -- | Like 'object'' but taking lists of 'Resolver's instead of a single list.
array' :: MonadPlus m => Name -> m [Resolvers m] -> Resolver m array' :: MonadPlus m => Name -> m [[Resolver m]] -> Resolver m
array' name resolvs = arrayA' name $ \case array' name resolvs = arrayA' name $ \case
[] -> resolvs [] -> resolvs
_ -> empty _ -> empty
@ -121,46 +130,50 @@ array' name resolvs = arrayA' name $ \case
-- | Like 'array'' but also taking 'Argument's. -- | Like 'array'' but also taking 'Argument's.
arrayA' arrayA'
:: MonadPlus m :: MonadPlus m
=> Name -> (Arguments -> m [Resolvers m]) -> Resolver m => Name -> (Arguments -> m [[Resolver m]]) -> Resolver m
arrayA' name f fld@(Field _ _ args sels) = do arrayA' name f = Resolver name go
where
go fld@(Field _ _ args sels) = do
resolvs <- lift $ f args resolvs <- lift $ f args
withField name (traverse (`resolve` sels) resolvs) fld withField name (traverse (`resolve` sels) resolvs) fld
-- | Represents one of a finite set of possible values. -- | Represents one of a finite set of possible values.
-- Used in place of a 'scalar' when the possible responses are easily enumerable. -- Used in place of a 'scalar' when the possible responses are easily enumerable.
enum :: MonadPlus m => Name -> m [T.Text] -> Resolver m enum :: MonadPlus m => Name -> m [Text] -> Resolver m
enum name enums = enumA name $ \case enum name enums = enumA name $ \case
[] -> enums [] -> enums
_ -> empty _ -> empty
-- | Like 'enum' but also taking 'Argument's. -- | Like 'enum' but also taking 'Argument's.
enumA :: MonadPlus m => Name -> (Arguments -> m [T.Text]) -> Resolver m enumA :: MonadPlus m => Name -> (Arguments -> m [Text]) -> Resolver m
enumA name f fld@(Field _ _ args []) = withField name (lift $ f args) fld enumA name f = Resolver name go
enumA _ _ _ = empty where
go fld@(Field _ _ args []) = withField name (lift $ f args) fld
go _ = empty
-- | Helper function to facilitate 'Argument' handling. -- | Helper function to facilitate 'Argument' handling.
withField :: (MonadPlus m, Aeson.ToJSON a) withField :: (MonadPlus m, Aeson.ToJSON a)
=> Name -> CollectErrsT m a -> Field -> CollectErrsT m (HashMap T.Text Aeson.Value) => Name -> CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value)
withField name v (Field alias name' _ _) withField name v (Field alias _ _ _) = do
| name == name' = do
collection <- HashMap.singleton aliasOrName . Aeson.toJSON <$> runAppendErrs v collection <- HashMap.singleton aliasOrName . Aeson.toJSON <$> runAppendErrs v
errors <- get errors <- get
if null errors if null errors
then return collection then return collection
-- TODO: Report error when Non-Nullable type for field argument. -- TODO: Report error when Non-Nullable type for field argument.
else put [] >> return (HashMap.singleton aliasOrName Aeson.Null) else put [] >> return (HashMap.singleton aliasOrName Aeson.Null)
| otherwise = empty
where where
aliasOrName = fromMaybe name alias aliasOrName = fromMaybe name alias
-- | Takes a list of 'Resolver's and a list of 'Field's and applies each -- | 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 -- 'Resolver' to each 'Field'. Resolves into a value containing the
-- resolved 'Field', or a null value and error information. -- resolved 'Field', or a null value and error information.
resolve :: MonadPlus m => Resolvers m -> Fields -> CollectErrsT m Aeson.Value resolve :: MonadPlus m
resolve resolvers = => [Resolver m] -> Fields -> CollectErrsT m Aeson.Value
fmap (Aeson.toJSON . fold) resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
. traverse (\fld -> getAlt (foldMap (Alt . ($ fld)) resolvers) <|> errmsg fld)
where where
tryResolvers fld = maybe empty (tryResolver fld) (find (compareResolvers fld) resolvers) <|> errmsg fld
compareResolvers (Field _ name _ _) (Resolver name' _) = name == name'
tryResolver fld (Resolver _ resolver) = resolver fld
errmsg (Field alias name _ _) = do errmsg (Field alias name _ _) = do
addErrMsg $ T.unwords ["field", name, "not resolved."] addErrMsg $ T.unwords ["field", name, "not resolved."]
return $ HashMap.singleton aliasOrName Aeson.Null return $ HashMap.singleton aliasOrName Aeson.Null