forked from OSS/graphql
Define resolvers on type fields
Returning resolvers from other resolvers isn't supported anymore. Since we have a type system now, we define the resolvers in the object type fields and pass an object with the previous result to them.
This commit is contained in:
@ -16,7 +16,6 @@ import qualified Data.Text.Lazy.Builder.Int as Text.Builder
|
||||
import Data.Scientific (toBoundedInteger, toRealFloat)
|
||||
import Language.GraphQL.AST.Document (Name)
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import Language.GraphQL.Schema
|
||||
import Language.GraphQL.Type.Definition
|
||||
|
||||
-- | Since variables are passed separately from the query, in an independent
|
||||
@ -46,26 +45,26 @@ class VariableValue a where
|
||||
coerceVariableValue
|
||||
:: In.Type -- ^ Expected type (variable type given in the query).
|
||||
-> a -- ^ Variable value being coerced.
|
||||
-> Maybe In.Value -- ^ Coerced value on success, 'Nothing' otherwise.
|
||||
-> Maybe Value -- ^ Coerced value on success, 'Nothing' otherwise.
|
||||
|
||||
instance VariableValue Aeson.Value where
|
||||
coerceVariableValue _ Aeson.Null = Just In.Null
|
||||
coerceVariableValue _ Aeson.Null = Just Null
|
||||
coerceVariableValue (In.ScalarBaseType scalarType) value
|
||||
| (Aeson.String stringValue) <- value = Just $ In.String stringValue
|
||||
| (Aeson.Bool booleanValue) <- value = Just $ In.Boolean booleanValue
|
||||
| (Aeson.String stringValue) <- value = Just $ String stringValue
|
||||
| (Aeson.Bool booleanValue) <- value = Just $ Boolean booleanValue
|
||||
| (Aeson.Number numberValue) <- value
|
||||
, (ScalarType "Float" _) <- scalarType =
|
||||
Just $ In.Float $ toRealFloat numberValue
|
||||
Just $ Float $ toRealFloat numberValue
|
||||
| (Aeson.Number numberValue) <- value = -- ID or Int
|
||||
In.Int <$> toBoundedInteger numberValue
|
||||
Int <$> toBoundedInteger numberValue
|
||||
coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) =
|
||||
Just $ In.Enum stringValue
|
||||
Just $ Enum stringValue
|
||||
coerceVariableValue (In.InputObjectBaseType objectType) value
|
||||
| (Aeson.Object objectValue) <- value = do
|
||||
let (In.InputObjectType _ _ inputFields) = objectType
|
||||
(newObjectValue, resultMap) <- foldWithKey objectValue inputFields
|
||||
if HashMap.null newObjectValue
|
||||
then Just $ In.Object resultMap
|
||||
then Just $ Object resultMap
|
||||
else Nothing
|
||||
where
|
||||
foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues
|
||||
@ -81,7 +80,7 @@ instance VariableValue Aeson.Value where
|
||||
pure (newObjectValue, insert coerced)
|
||||
Nothing -> Just (objectValue, resultMap)
|
||||
coerceVariableValue (In.ListBaseType listType) value
|
||||
| (Aeson.Array arrayValue) <- value = In.List
|
||||
| (Aeson.Array arrayValue) <- value = List
|
||||
<$> foldr foldVector (Just []) arrayValue
|
||||
| otherwise = coerceVariableValue listType value
|
||||
where
|
||||
@ -95,7 +94,7 @@ instance VariableValue Aeson.Value where
|
||||
-- corresponding types.
|
||||
coerceInputLiterals
|
||||
:: HashMap Name In.Type
|
||||
-> HashMap Name In.Value
|
||||
-> HashMap Name Value
|
||||
-> Maybe Subs
|
||||
coerceInputLiterals variableTypes variableValues =
|
||||
foldWithKey operator variableTypes
|
||||
@ -105,34 +104,34 @@ coerceInputLiterals variableTypes variableValues =
|
||||
<$> (lookupVariable variableName >>= coerceInputLiteral variableType)
|
||||
<*> resultMap
|
||||
coerceInputLiteral (In.NamedScalarType type') value
|
||||
| (In.String stringValue) <- value
|
||||
, (ScalarType "String" _) <- type' = Just $ In.String stringValue
|
||||
| (In.Boolean booleanValue) <- value
|
||||
, (ScalarType "Boolean" _) <- type' = Just $ In.Boolean booleanValue
|
||||
| (In.Int intValue) <- value
|
||||
, (ScalarType "Int" _) <- type' = Just $ In.Int intValue
|
||||
| (In.Float floatValue) <- value
|
||||
, (ScalarType "Float" _) <- type' = Just $ In.Float floatValue
|
||||
| (In.Int intValue) <- value
|
||||
| (String stringValue) <- value
|
||||
, (ScalarType "String" _) <- type' = Just $ String stringValue
|
||||
| (Boolean booleanValue) <- value
|
||||
, (ScalarType "Boolean" _) <- type' = Just $ Boolean booleanValue
|
||||
| (Int intValue) <- value
|
||||
, (ScalarType "Int" _) <- type' = Just $ Int intValue
|
||||
| (Float floatValue) <- value
|
||||
, (ScalarType "Float" _) <- type' = Just $ Float floatValue
|
||||
| (Int intValue) <- value
|
||||
, (ScalarType "Float" _) <- type' =
|
||||
Just $ In.Float $ fromIntegral intValue
|
||||
| (In.String stringValue) <- value
|
||||
, (ScalarType "ID" _) <- type' = Just $ In.String stringValue
|
||||
| (In.Int intValue) <- value
|
||||
Just $ Float $ fromIntegral intValue
|
||||
| (String stringValue) <- value
|
||||
, (ScalarType "ID" _) <- type' = Just $ String stringValue
|
||||
| (Int intValue) <- value
|
||||
, (ScalarType "ID" _) <- type' = Just $ decimal intValue
|
||||
coerceInputLiteral (In.NamedEnumType type') (In.Enum enumValue)
|
||||
| member enumValue type' = Just $ In.Enum enumValue
|
||||
coerceInputLiteral (In.NamedInputObjectType type') (In.Object _) =
|
||||
coerceInputLiteral (In.NamedEnumType type') (Enum enumValue)
|
||||
| member enumValue type' = Just $ Enum enumValue
|
||||
coerceInputLiteral (In.NamedInputObjectType type') (Object _) =
|
||||
let (In.InputObjectType _ _ inputFields) = type'
|
||||
in In.Object <$> foldWithKey matchFieldValues inputFields
|
||||
in Object <$> foldWithKey matchFieldValues inputFields
|
||||
coerceInputLiteral _ _ = Nothing
|
||||
member value (EnumType _ _ members) = Set.member value members
|
||||
matchFieldValues fieldName (In.InputField _ type' defaultValue) resultMap =
|
||||
case lookupVariable fieldName of
|
||||
Just In.Null
|
||||
Just Null
|
||||
| In.isNonNullType type' -> Nothing
|
||||
| otherwise ->
|
||||
HashMap.insert fieldName In.Null <$> resultMap
|
||||
HashMap.insert fieldName Null <$> resultMap
|
||||
Just variableValue -> HashMap.insert fieldName
|
||||
<$> coerceInputLiteral type' variableValue
|
||||
<*> resultMap
|
||||
@ -144,7 +143,7 @@ coerceInputLiterals variableTypes variableValues =
|
||||
| otherwise -> resultMap
|
||||
lookupVariable = flip HashMap.lookup variableValues
|
||||
foldWithKey f = HashMap.foldrWithKey f (Just HashMap.empty)
|
||||
decimal = In.String
|
||||
decimal = String
|
||||
. Text.Lazy.toStrict
|
||||
. Text.Builder.toLazyText
|
||||
. Text.Builder.decimal
|
||||
|
||||
58
src/Language/GraphQL/Execute/Execution.hs
Normal file
58
src/Language/GraphQL/Execute/Execution.hs
Normal file
@ -0,0 +1,58 @@
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Language.GraphQL.Execute.Execution
|
||||
( aliasOrName
|
||||
, collectFields
|
||||
) where
|
||||
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Sequence (Seq)
|
||||
import qualified Data.Sequence as Seq
|
||||
import Language.GraphQL.AST.Document (Name)
|
||||
import Language.GraphQL.Execute.Transform
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Language.GraphQL.Type.Schema
|
||||
|
||||
collectFields :: Monad m
|
||||
=> Out.ObjectType m
|
||||
-> Seq (Selection m)
|
||||
-> Map Name (Seq (Field m))
|
||||
collectFields objectType = foldl forEach Map.empty
|
||||
where
|
||||
forEach groupedFields (SelectionField field) =
|
||||
let responseKey = aliasOrName field
|
||||
in Map.insertWith (<>) responseKey (Seq.singleton field) groupedFields
|
||||
forEach groupedFields (SelectionFragment selectionFragment)
|
||||
| Fragment fragmentType fragmentSelectionSet <- selectionFragment
|
||||
, doesFragmentTypeApply fragmentType objectType =
|
||||
let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet
|
||||
in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet
|
||||
| otherwise = groupedFields
|
||||
|
||||
aliasOrName :: forall m. Field m -> Name
|
||||
aliasOrName (Field alias name _ _) = fromMaybe name alias
|
||||
|
||||
doesFragmentTypeApply :: forall m
|
||||
. CompositeType m
|
||||
-> Out.ObjectType m
|
||||
-> Bool
|
||||
doesFragmentTypeApply (CompositeObjectType fragmentType) objectType =
|
||||
let Out.ObjectType fragmentName _ _ _ = fragmentType
|
||||
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
|
||||
doesFragmentTypeApply (CompositeUnionType fragmentType) objectType =
|
||||
let Out.UnionType _ _ members = fragmentType
|
||||
in foldr instanceOf False members
|
||||
where
|
||||
instanceOf (Out.ObjectType that _ _ _) acc =
|
||||
let Out.ObjectType this _ _ _ = objectType
|
||||
in acc || this == that
|
||||
@ -12,12 +12,17 @@
|
||||
-- replaced by the selection set they represent. Invalid (recursive and
|
||||
-- non-existing) fragments are skipped. The most fragments are inlined, so the
|
||||
-- executor doesn't have to perform additional lookups later.
|
||||
-- * Evaluating directives (@\@include@ and @\@skip@).
|
||||
--
|
||||
-- This module is also responsible for smaller rewrites that touch only parts of
|
||||
-- the original AST.
|
||||
module Language.GraphQL.Execute.Transform
|
||||
( Document(..)
|
||||
, Fragment(..)
|
||||
, QueryError(..)
|
||||
, Operation(..)
|
||||
, Selection(..)
|
||||
, Field(..)
|
||||
, document
|
||||
, queryError
|
||||
) where
|
||||
@ -36,26 +41,48 @@ import Data.Sequence (Seq, (<|), (><))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Language.GraphQL.AST as Full
|
||||
import qualified Language.GraphQL.AST.Core as Core
|
||||
import Language.GraphQL.AST.Core
|
||||
import Language.GraphQL.Execute.Coerce
|
||||
import qualified Language.GraphQL.Schema as Schema
|
||||
import qualified Language.GraphQL.Type.Directive as Directive
|
||||
import Language.GraphQL.Type.Definition (Subs, Value(..))
|
||||
import qualified Language.GraphQL.AST.Core as Core
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import qualified Language.GraphQL.Type.Directive as Core
|
||||
import Language.GraphQL.Type.Schema
|
||||
|
||||
-- | Associates a fragment name with a list of 'Core.Field's.
|
||||
data Replacement m = Replacement
|
||||
{ fragments :: HashMap Core.Name Core.Fragment
|
||||
{ fragments :: HashMap Full.Name (Fragment m)
|
||||
, fragmentDefinitions :: FragmentDefinitions
|
||||
, variableValues :: Schema.Subs
|
||||
, variableValues :: Subs
|
||||
, types :: HashMap Full.Name (Type m)
|
||||
}
|
||||
|
||||
type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition
|
||||
|
||||
-- | Represents fragments and inline fragments.
|
||||
data Fragment m
|
||||
= Fragment (CompositeType m) (Seq (Selection m))
|
||||
|
||||
-- | Single selection element.
|
||||
data Selection m
|
||||
= SelectionFragment (Fragment m)
|
||||
| SelectionField (Field m)
|
||||
|
||||
-- | GraphQL has 3 operation types: queries, mutations and subscribtions.
|
||||
--
|
||||
-- Currently only queries and mutations are supported.
|
||||
data Operation m
|
||||
= Query (Maybe Text) (Seq (Selection m))
|
||||
| Mutation (Maybe Text) (Seq (Selection m))
|
||||
|
||||
-- | Single GraphQL field.
|
||||
data Field m = Field (Maybe Full.Name) Full.Name Arguments (Seq (Selection m))
|
||||
|
||||
-- | Contains the operation to be executed along with its root type.
|
||||
data Document m = Document (Out.ObjectType m) Core.Operation
|
||||
data Document m = Document
|
||||
(HashMap Full.Name (Type m)) (Out.ObjectType m) (Operation m)
|
||||
|
||||
data OperationDefinition = OperationDefinition
|
||||
Full.OperationType
|
||||
@ -131,7 +158,7 @@ coerceVariableValues :: VariableValue a
|
||||
. HashMap Full.Name (Type m)
|
||||
-> OperationDefinition
|
||||
-> HashMap.HashMap Full.Name a
|
||||
-> Either QueryError Schema.Subs
|
||||
-> Either QueryError Subs
|
||||
coerceVariableValues types operationDefinition variableValues' =
|
||||
let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
|
||||
in maybe (Left CoercionError) Right
|
||||
@ -149,23 +176,23 @@ coerceVariableValues types operationDefinition variableValues' =
|
||||
<*> coercedValues
|
||||
choose Nothing defaultValue variableType
|
||||
| Just _ <- defaultValue = defaultValue
|
||||
| not (In.isNonNullType variableType) = Just In.Null
|
||||
| not (In.isNonNullType variableType) = Just Null
|
||||
choose (Just value') _ variableType
|
||||
| Just coercedValue <- coerceVariableValue variableType value'
|
||||
, not (In.isNonNullType variableType) || coercedValue /= In.Null =
|
||||
, not (In.isNonNullType variableType) || coercedValue /= Null =
|
||||
Just coercedValue
|
||||
choose _ _ _ = Nothing
|
||||
|
||||
constValue :: Full.ConstValue -> In.Value
|
||||
constValue (Full.ConstInt i) = In.Int i
|
||||
constValue (Full.ConstFloat f) = In.Float f
|
||||
constValue (Full.ConstString x) = In.String x
|
||||
constValue (Full.ConstBoolean b) = In.Boolean b
|
||||
constValue Full.ConstNull = In.Null
|
||||
constValue (Full.ConstEnum e) = In.Enum e
|
||||
constValue (Full.ConstList l) = In.List $ constValue <$> l
|
||||
constValue :: Full.ConstValue -> Value
|
||||
constValue (Full.ConstInt i) = Int i
|
||||
constValue (Full.ConstFloat f) = Float f
|
||||
constValue (Full.ConstString x) = String x
|
||||
constValue (Full.ConstBoolean b) = Boolean b
|
||||
constValue Full.ConstNull = Null
|
||||
constValue (Full.ConstEnum e) = Enum e
|
||||
constValue (Full.ConstList l) = List $ constValue <$> l
|
||||
constValue (Full.ConstObject o) =
|
||||
In.Object $ HashMap.fromList $ constObjectField <$> o
|
||||
Object $ HashMap.fromList $ constObjectField <$> o
|
||||
where
|
||||
constObjectField (Full.ObjectField key value') = (key, constValue value')
|
||||
|
||||
@ -193,12 +220,12 @@ document schema operationName subs ast = do
|
||||
}
|
||||
case chosenOperation of
|
||||
OperationDefinition Full.Query _ _ _ _ ->
|
||||
pure $ Document (query schema)
|
||||
$ operation (query schema) chosenOperation replacement
|
||||
pure $ Document referencedTypes (query schema)
|
||||
$ operation chosenOperation replacement
|
||||
OperationDefinition Full.Mutation _ _ _ _
|
||||
| Just mutationType <- mutation schema ->
|
||||
pure $ Document mutationType
|
||||
$ operation mutationType chosenOperation replacement
|
||||
pure $ Document referencedTypes mutationType
|
||||
$ operation chosenOperation replacement
|
||||
_ -> Left UnsupportedRootOperation
|
||||
|
||||
defragment
|
||||
@ -227,72 +254,73 @@ defragment ast =
|
||||
|
||||
-- * Operation
|
||||
|
||||
operation :: forall m
|
||||
. Out.ObjectType m
|
||||
-> OperationDefinition
|
||||
-> Replacement m
|
||||
-> Core.Operation
|
||||
operation rootType operationDefinition replacement
|
||||
operation :: OperationDefinition -> Replacement m -> Operation m
|
||||
operation operationDefinition replacement
|
||||
= runIdentity
|
||||
$ evalStateT (collectFragments rootType >> transform operationDefinition) replacement
|
||||
$ evalStateT (collectFragments >> transform operationDefinition) replacement
|
||||
where
|
||||
transform (OperationDefinition Full.Query name _ _ sels) =
|
||||
Core.Query name <$> appendSelection sels rootType
|
||||
Query name <$> appendSelection sels
|
||||
transform (OperationDefinition Full.Mutation name _ _ sels) =
|
||||
Core.Mutation name <$> appendSelection sels rootType
|
||||
Mutation name <$> appendSelection sels
|
||||
|
||||
-- * Selection
|
||||
|
||||
selection :: forall m
|
||||
. Full.Selection
|
||||
-> Out.ObjectType m
|
||||
-> State (Replacement m) (Either (Seq Core.Selection) Core.Selection)
|
||||
selection (Full.Field alias name arguments' directives' selections) objectType =
|
||||
maybe (Left mempty) (Right . Core.SelectionField) <$> do
|
||||
selection
|
||||
:: Full.Selection
|
||||
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
|
||||
selection (Full.Field alias name arguments' directives' selections) =
|
||||
maybe (Left mempty) (Right . SelectionField) <$> do
|
||||
fieldArguments <- arguments arguments'
|
||||
fieldSelections <- appendSelection selections objectType
|
||||
fieldSelections <- appendSelection selections
|
||||
fieldDirectives <- Directive.selection <$> directives directives'
|
||||
let field' = Core.Field alias name fieldArguments fieldSelections
|
||||
let field' = Field alias name fieldArguments fieldSelections
|
||||
pure $ field' <$ fieldDirectives
|
||||
selection (Full.FragmentSpread name directives') objectType =
|
||||
maybe (Left mempty) (Right . Core.SelectionFragment) <$> do
|
||||
selection (Full.FragmentSpread name directives') =
|
||||
maybe (Left mempty) (Right . SelectionFragment) <$> do
|
||||
spreadDirectives <- Directive.selection <$> directives directives'
|
||||
fragments' <- gets fragments
|
||||
|
||||
fragmentDefinitions' <- gets fragmentDefinitions
|
||||
case HashMap.lookup name fragments' of
|
||||
Just definition -> lift $ pure $ definition <$ spreadDirectives
|
||||
Nothing -> case HashMap.lookup name fragmentDefinitions' of
|
||||
Just definition -> do
|
||||
fragment <- fragmentDefinition definition objectType
|
||||
lift $ pure $ fragment <$ spreadDirectives
|
||||
Nothing -> lift $ pure Nothing
|
||||
selection (Full.InlineFragment type' directives' selections) objectType = do
|
||||
Nothing
|
||||
| Just definition <- HashMap.lookup name fragmentDefinitions' -> do
|
||||
fragDef <- fragmentDefinition definition
|
||||
case fragDef of
|
||||
Just fragment -> lift $ pure $ fragment <$ spreadDirectives
|
||||
_ -> lift $ pure Nothing
|
||||
| otherwise -> lift $ pure Nothing
|
||||
selection (Full.InlineFragment type' directives' selections) = do
|
||||
fragmentDirectives <- Directive.selection <$> directives directives'
|
||||
case fragmentDirectives of
|
||||
Nothing -> pure $ Left mempty
|
||||
_ -> do
|
||||
fragmentSelectionSet <- appendSelection selections objectType
|
||||
pure $ maybe Left selectionFragment type' fragmentSelectionSet
|
||||
fragmentSelectionSet <- appendSelection selections
|
||||
|
||||
case type' of
|
||||
Nothing -> pure $ Left fragmentSelectionSet
|
||||
Just typeName -> do
|
||||
typeCondition' <- lookupTypeCondition typeName
|
||||
case typeCondition' of
|
||||
Just typeCondition -> pure $
|
||||
selectionFragment typeCondition fragmentSelectionSet
|
||||
Nothing -> pure $ Left mempty
|
||||
where
|
||||
selectionFragment typeName = Right
|
||||
. Core.SelectionFragment
|
||||
. Core.Fragment typeName
|
||||
. SelectionFragment
|
||||
. Fragment typeName
|
||||
|
||||
appendSelection :: Traversable t
|
||||
=> forall m
|
||||
. t Full.Selection
|
||||
-> Out.ObjectType m
|
||||
-> State (Replacement m) (Seq Core.Selection)
|
||||
appendSelection selectionSet objectType = foldM go mempty selectionSet
|
||||
=> t Full.Selection
|
||||
-> State (Replacement m) (Seq (Selection m))
|
||||
appendSelection = foldM go mempty
|
||||
where
|
||||
go acc sel = append acc <$> selection sel objectType
|
||||
go acc sel = append acc <$> selection sel
|
||||
append acc (Left list) = list >< acc
|
||||
append acc (Right one) = one <| acc
|
||||
|
||||
directives :: forall m
|
||||
. [Full.Directive]
|
||||
-> State (Replacement m) [Core.Directive]
|
||||
directives :: [Full.Directive] -> State (Replacement m) [Core.Directive]
|
||||
directives = traverse directive
|
||||
where
|
||||
directive (Full.Directive directiveName directiveArguments) =
|
||||
@ -301,24 +329,40 @@ directives = traverse directive
|
||||
-- * Fragment replacement
|
||||
|
||||
-- | Extract fragment definitions into a single 'HashMap'.
|
||||
collectFragments :: forall m. Out.ObjectType m -> State (Replacement m) ()
|
||||
collectFragments objectType = do
|
||||
collectFragments :: State (Replacement m) ()
|
||||
collectFragments = do
|
||||
fragDefs <- gets fragmentDefinitions
|
||||
let nextValue = head $ HashMap.elems fragDefs
|
||||
unless (HashMap.null fragDefs) $ do
|
||||
_ <- fragmentDefinition nextValue objectType
|
||||
collectFragments objectType
|
||||
_ <- fragmentDefinition nextValue
|
||||
collectFragments
|
||||
|
||||
fragmentDefinition :: forall m
|
||||
. Full.FragmentDefinition
|
||||
-> Out.ObjectType m
|
||||
-> State (Replacement m) Core.Fragment
|
||||
fragmentDefinition (Full.FragmentDefinition name type' _ selections) objectType = do
|
||||
lookupTypeCondition :: Full.Name -> State (Replacement m) (Maybe (CompositeType m))
|
||||
lookupTypeCondition type' = do
|
||||
types' <- gets types
|
||||
case HashMap.lookup type' types' of
|
||||
Just (ObjectType objectType) ->
|
||||
lift $ pure $ Just $ CompositeObjectType objectType
|
||||
Just (UnionType unionType) ->
|
||||
lift $ pure $ Just $ CompositeUnionType unionType
|
||||
Just (InterfaceType interfaceType) ->
|
||||
lift $ pure $ Just $ CompositeInterfaceType interfaceType
|
||||
_ -> lift $ pure Nothing
|
||||
|
||||
fragmentDefinition
|
||||
:: Full.FragmentDefinition
|
||||
-> State (Replacement m) (Maybe (Fragment m))
|
||||
fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
|
||||
modify deleteFragmentDefinition
|
||||
fragmentSelection <- appendSelection selections objectType
|
||||
let newValue = Core.Fragment type' fragmentSelection
|
||||
modify $ insertFragment newValue
|
||||
lift $ pure newValue
|
||||
fragmentSelection <- appendSelection selections
|
||||
compositeType <- lookupTypeCondition type'
|
||||
|
||||
case compositeType of
|
||||
Just compositeType' -> do
|
||||
let newValue = Fragment compositeType' fragmentSelection
|
||||
modify $ insertFragment newValue
|
||||
lift $ pure $ Just newValue
|
||||
_ -> lift $ pure Nothing
|
||||
where
|
||||
deleteFragmentDefinition replacement@Replacement{..} =
|
||||
let newDefinitions = HashMap.delete name fragmentDefinitions
|
||||
@ -327,27 +371,27 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections) objectType
|
||||
let newFragments = HashMap.insert name newValue fragments
|
||||
in replacement{ fragments = newFragments }
|
||||
|
||||
arguments :: forall m. [Full.Argument] -> State (Replacement m) Core.Arguments
|
||||
arguments :: [Full.Argument] -> State (Replacement m) Core.Arguments
|
||||
arguments = fmap Core.Arguments . foldM go HashMap.empty
|
||||
where
|
||||
go arguments' (Full.Argument name value') = do
|
||||
substitutedValue <- value value'
|
||||
return $ HashMap.insert name substitutedValue arguments'
|
||||
|
||||
value :: forall m. Full.Value -> State (Replacement m) In.Value
|
||||
value :: Full.Value -> State (Replacement m) Value
|
||||
value (Full.Variable name) =
|
||||
gets $ fromMaybe In.Null . HashMap.lookup name . variableValues
|
||||
value (Full.Int i) = pure $ In.Int i
|
||||
value (Full.Float f) = pure $ In.Float f
|
||||
value (Full.String x) = pure $ In.String x
|
||||
value (Full.Boolean b) = pure $ In.Boolean b
|
||||
value Full.Null = pure In.Null
|
||||
value (Full.Enum e) = pure $ In.Enum e
|
||||
value (Full.List l) = In.List <$> traverse value l
|
||||
gets $ fromMaybe Null . HashMap.lookup name . variableValues
|
||||
value (Full.Int i) = pure $ Int i
|
||||
value (Full.Float f) = pure $ Float f
|
||||
value (Full.String x) = pure $ String x
|
||||
value (Full.Boolean b) = pure $ Boolean b
|
||||
value Full.Null = pure Null
|
||||
value (Full.Enum e) = pure $ Enum e
|
||||
value (Full.List l) = List <$> traverse value l
|
||||
value (Full.Object o) =
|
||||
In.Object . HashMap.fromList <$> traverse objectField o
|
||||
Object . HashMap.fromList <$> traverse objectField o
|
||||
|
||||
objectField :: forall m
|
||||
. Full.ObjectField Full.Value
|
||||
-> State (Replacement m) (Core.Name, In.Value)
|
||||
objectField
|
||||
:: Full.ObjectField Full.Value
|
||||
-> State (Replacement m) (Full.Name, Value)
|
||||
objectField (Full.ObjectField name value') = (name,) <$> value value'
|
||||
|
||||
Reference in New Issue
Block a user