forked from OSS/graphql
parent
c075a41582
commit
2b5c719ab0
@ -14,8 +14,8 @@ import qualified Language.GraphQL.AST as Full
|
|||||||
import qualified Language.GraphQL.AST.Core as Core
|
import qualified Language.GraphQL.AST.Core as Core
|
||||||
import qualified Language.GraphQL.Schema as Schema
|
import qualified Language.GraphQL.Schema as Schema
|
||||||
|
|
||||||
-- | Replaces a fragment name by a list of 'Field'. If the name doesn't match an
|
-- | Replaces a fragment name by a list of 'Core.Field'. If the name doesn't
|
||||||
-- empty list is returned.
|
-- match an empty list is returned.
|
||||||
type Fragmenter = Core.Name -> [Core.Field]
|
type Fragmenter = Core.Name -> [Core.Field]
|
||||||
|
|
||||||
-- | Rewrites the original syntax tree into an intermediate representation used
|
-- | Rewrites the original syntax tree into an intermediate representation used
|
||||||
|
@ -1,5 +1,7 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
|
||||||
|
-- | Error handling.
|
||||||
module Language.GraphQL.Error
|
module Language.GraphQL.Error
|
||||||
( parseError
|
( parseError
|
||||||
, CollectErrsT
|
, CollectErrsT
|
||||||
|
@ -28,9 +28,7 @@ module Language.GraphQL.Schema
|
|||||||
import Control.Monad.IO.Class (MonadIO(..))
|
import Control.Monad.IO.Class (MonadIO(..))
|
||||||
import Control.Monad.Trans.Class (lift)
|
import Control.Monad.Trans.Class (lift)
|
||||||
import Control.Monad.Trans.Except (runExceptT)
|
import Control.Monad.Trans.Except (runExceptT)
|
||||||
import Data.Foldable ( find
|
import Data.Foldable (find, fold)
|
||||||
, fold
|
|
||||||
)
|
|
||||||
import Data.List.NonEmpty (NonEmpty)
|
import Data.List.NonEmpty (NonEmpty)
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import qualified Data.Aeson as Aeson
|
import qualified Data.Aeson as Aeson
|
||||||
@ -48,16 +46,13 @@ import Language.GraphQL.AST.Core
|
|||||||
-- @m@ is usually expected to be an instance of 'MonadIO'.
|
-- @m@ is usually expected to be an instance of 'MonadIO'.
|
||||||
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.@'Data.Aeson.Types.Object' with error
|
||||||
-- (or 'empty'). @m@ is usually expected to be an instance of 'MonadIO.
|
-- information (if an error has occurred). @m@ is usually expected to be an
|
||||||
|
-- instance of 'MonadIO'.
|
||||||
data Resolver m = Resolver
|
data Resolver m = Resolver
|
||||||
Text -- ^ Name
|
Text -- ^ Name
|
||||||
(Field -> CollectErrsT m Aeson.Object) -- ^ Resolver
|
(Field -> CollectErrsT m Aeson.Object) -- ^ Resolver
|
||||||
|
|
||||||
type Fields = [Field]
|
|
||||||
|
|
||||||
type Arguments = [Argument]
|
|
||||||
|
|
||||||
-- | Variable substitution function.
|
-- | Variable substitution function.
|
||||||
type Subs = Name -> Maybe Value
|
type Subs = Name -> Maybe Value
|
||||||
|
|
||||||
@ -67,14 +62,14 @@ object name = objectA name . const
|
|||||||
|
|
||||||
-- | Like 'object' but also taking 'Argument's.
|
-- | Like 'object' but also taking 'Argument's.
|
||||||
objectA :: MonadIO m
|
objectA :: MonadIO m
|
||||||
=> Name -> (Arguments -> ActionT m [Resolver m]) -> Resolver m
|
=> Name -> ([Argument] -> ActionT m [Resolver m]) -> Resolver m
|
||||||
objectA name f = Resolver name $ resolveFieldValue f resolveRight
|
objectA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||||
where
|
where
|
||||||
resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld
|
resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld
|
||||||
|
|
||||||
-- | Like 'object' but also taking 'Argument's and can be null or a list of objects.
|
-- | Like 'object' but also taking 'Argument's and can be null or a list of objects.
|
||||||
wrappedObjectA :: MonadIO m
|
wrappedObjectA :: MonadIO m
|
||||||
=> Name -> (Arguments -> ActionT m (Wrapping [Resolver m])) -> Resolver m
|
=> Name -> ([Argument] -> ActionT m (Wrapping [Resolver m])) -> Resolver m
|
||||||
wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight
|
wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||||
where
|
where
|
||||||
resolveRight fld@(Field _ _ _ sels) resolver
|
resolveRight fld@(Field _ _ _ sels) resolver
|
||||||
@ -91,14 +86,14 @@ scalar name = scalarA name . const
|
|||||||
|
|
||||||
-- | Like 'scalar' but also taking 'Argument's.
|
-- | Like 'scalar' but also taking 'Argument's.
|
||||||
scalarA :: (MonadIO m, Aeson.ToJSON a)
|
scalarA :: (MonadIO m, Aeson.ToJSON a)
|
||||||
=> Name -> (Arguments -> ActionT m a) -> Resolver m
|
=> Name -> ([Argument] -> ActionT m a) -> Resolver m
|
||||||
scalarA name f = Resolver name $ resolveFieldValue f resolveRight
|
scalarA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||||
where
|
where
|
||||||
resolveRight fld result = withField (return result) fld
|
resolveRight fld result = withField (return result) fld
|
||||||
|
|
||||||
-- | Lika 'scalar' but also taking 'Argument's and can be null or a list of scalars.
|
-- | Lika 'scalar' but also taking 'Argument's and can be null or a list of scalars.
|
||||||
wrappedScalarA :: (MonadIO m, Aeson.ToJSON a)
|
wrappedScalarA :: (MonadIO m, Aeson.ToJSON a)
|
||||||
=> Name -> (Arguments -> ActionT m (Wrapping a)) -> Resolver m
|
=> Name -> ([Argument] -> ActionT m (Wrapping a)) -> Resolver m
|
||||||
wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight
|
wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||||
where
|
where
|
||||||
resolveRight fld (Named result) = withField (return result) fld
|
resolveRight fld (Named result) = withField (return result) fld
|
||||||
@ -116,14 +111,14 @@ enum :: MonadIO m => Name -> ActionT m [Text] -> Resolver m
|
|||||||
enum name = enumA name . const
|
enum name = enumA name . const
|
||||||
|
|
||||||
{-# DEPRECATED enumA "Use scalarA instead" #-}
|
{-# DEPRECATED enumA "Use scalarA instead" #-}
|
||||||
enumA :: MonadIO m => Name -> (Arguments -> ActionT m [Text]) -> Resolver m
|
enumA :: MonadIO m => Name -> ([Argument] -> ActionT m [Text]) -> Resolver m
|
||||||
enumA name f = Resolver name $ resolveFieldValue f resolveRight
|
enumA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||||
where
|
where
|
||||||
resolveRight fld resolver = withField (return resolver) fld
|
resolveRight fld resolver = withField (return resolver) fld
|
||||||
|
|
||||||
{-# DEPRECATED wrappedEnumA "Use wrappedScalarA instead" #-}
|
{-# DEPRECATED wrappedEnumA "Use wrappedScalarA instead" #-}
|
||||||
wrappedEnumA :: MonadIO m
|
wrappedEnumA :: MonadIO m
|
||||||
=> Name -> (Arguments -> ActionT m (Wrapping [Text])) -> Resolver m
|
=> Name -> ([Argument] -> ActionT m (Wrapping [Text])) -> Resolver m
|
||||||
wrappedEnumA name f = Resolver name $ resolveFieldValue f resolveRight
|
wrappedEnumA name f = Resolver name $ resolveFieldValue f resolveRight
|
||||||
where
|
where
|
||||||
resolveRight fld (Named resolver) = withField (return resolver) fld
|
resolveRight fld (Named resolver) = withField (return resolver) fld
|
||||||
@ -158,7 +153,7 @@ withField v fld
|
|||||||
-- '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 :: MonadIO m
|
resolve :: MonadIO m
|
||||||
=> [Resolver m] -> Fields -> CollectErrsT m Aeson.Value
|
=> [Resolver m] -> [Field] -> CollectErrsT m Aeson.Value
|
||||||
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
|
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
|
||||||
where
|
where
|
||||||
tryResolvers fld = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers fld) resolvers
|
tryResolvers fld = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers fld) resolvers
|
||||||
|
@ -1,4 +1,4 @@
|
|||||||
resolver: lts-14.5
|
resolver: lts-14.6
|
||||||
packages:
|
packages:
|
||||||
- '.'
|
- '.'
|
||||||
extra-deps: []
|
extra-deps: []
|
||||||
|
Loading…
Reference in New Issue
Block a user