{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Validation.Query.UnionSelection
( validateUnionSelection,
validateInterfaceSelection,
)
where
import Data.List (lookup)
import Data.Morpheus.Ext.SemigroupM
( (<:>),
join,
)
import Data.Morpheus.Internal.Utils
( elems,
empty,
fromElems,
singleton,
)
import Data.Morpheus.Types.Internal.AST
( DataUnion,
Fragment (..),
IMPLEMENTABLE,
Position (..),
RAW,
Selection (..),
SelectionContent (..),
SelectionSet,
SelectionSet,
TypeContent (..),
TypeDefinition (..),
TypeName,
UnionTag (..),
VALID,
mkType,
toCategory,
)
import Data.Morpheus.Types.Internal.Validation
( FragmentValidator,
Scope (..),
askInterfaceTypes,
askTypeMember,
asksScope,
)
import Data.Morpheus.Validation.Query.Fragment
( ResolveFragment (resolveValidFragment),
castFragmentType,
)
import Relude hiding (empty, join)
splitFragment ::
(ResolveFragment s) =>
( Fragment RAW ->
FragmentValidator s (SelectionSet VALID)
) ->
[TypeDefinition IMPLEMENTABLE VALID] ->
Selection RAW ->
FragmentValidator s ([UnionTag], [Selection RAW])
splitFragment :: (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeDefinition IMPLEMENTABLE VALID]
-> Selection RAW
-> FragmentValidator s ([UnionTag], [Selection RAW])
splitFragment Fragment RAW -> FragmentValidator s (SelectionSet VALID)
_ [TypeDefinition IMPLEMENTABLE VALID]
_ x :: Selection RAW
x@Selection {} = ([UnionTag], [Selection RAW])
-> FragmentValidator s ([UnionTag], [Selection RAW])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [Selection RAW
x])
splitFragment Fragment RAW -> FragmentValidator s (SelectionSet VALID)
f [TypeDefinition IMPLEMENTABLE VALID]
types (Spread Directives RAW
_ Ref
ref) = UnionTag -> ([UnionTag], [Selection RAW])
forall a1 a2. a1 -> ([a1], [a2])
pureFirst (UnionTag -> ([UnionTag], [Selection RAW]))
-> Validator VALID (OperationContext VALID s) UnionTag
-> FragmentValidator s ([UnionTag], [Selection RAW])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeName]
-> Ref
-> Validator VALID (OperationContext VALID s) UnionTag
forall (s :: Stage).
ResolveFragment s =>
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeName] -> Ref -> FragmentValidator s UnionTag
resolveValidFragment Fragment RAW -> FragmentValidator s (SelectionSet VALID)
f (TypeDefinition IMPLEMENTABLE VALID -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName (TypeDefinition IMPLEMENTABLE VALID -> TypeName)
-> [TypeDefinition IMPLEMENTABLE VALID] -> [TypeName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeDefinition IMPLEMENTABLE VALID]
types) Ref
ref
splitFragment Fragment RAW -> FragmentValidator s (SelectionSet VALID)
f [TypeDefinition IMPLEMENTABLE VALID]
types (InlineFragment fragment :: Fragment RAW
fragment@Fragment {TypeName
fragmentType :: forall (stage :: Stage). Fragment stage -> TypeName
fragmentType :: TypeName
fragmentType}) =
UnionTag -> ([UnionTag], [Selection RAW])
forall a1 a2. a1 -> ([a1], [a2])
pureFirst (UnionTag -> ([UnionTag], [Selection RAW]))
-> (SelectionSet VALID -> UnionTag)
-> SelectionSet VALID
-> ([UnionTag], [Selection RAW])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> SelectionSet VALID -> UnionTag
UnionTag TypeName
fragmentType
(SelectionSet VALID -> ([UnionTag], [Selection RAW]))
-> FragmentValidator s (SelectionSet VALID)
-> FragmentValidator s ([UnionTag], [Selection RAW])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( Maybe FieldName
-> Position
-> [TypeName]
-> Fragment RAW
-> FragmentValidator s (Fragment RAW)
forall (s :: Stage) (s1 :: Stage).
Maybe FieldName
-> Position
-> [TypeName]
-> Fragment s
-> FragmentValidator s1 (Fragment s)
castFragmentType Maybe FieldName
forall a. Maybe a
Nothing (Fragment RAW -> Position
forall (stage :: Stage). Fragment stage -> Position
fragmentPosition Fragment RAW
fragment) (TypeDefinition IMPLEMENTABLE VALID -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName (TypeDefinition IMPLEMENTABLE VALID -> TypeName)
-> [TypeDefinition IMPLEMENTABLE VALID] -> [TypeName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeDefinition IMPLEMENTABLE VALID]
types) Fragment RAW
fragment
FragmentValidator s (Fragment RAW)
-> (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> FragmentValidator s (SelectionSet VALID)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Fragment RAW -> FragmentValidator s (SelectionSet VALID)
f
)
pureFirst :: a1 -> ([a1], [a2])
pureFirst :: a1 -> ([a1], [a2])
pureFirst a1
x = ([a1
x], [])
joinExploredSelection :: [([UnionTag], [Selection RAW])] -> FragmentValidator s ([UnionTag], SelectionSet RAW)
joinExploredSelection :: [([UnionTag], [Selection RAW])]
-> FragmentValidator s ([UnionTag], SelectionSet RAW)
joinExploredSelection [([UnionTag], [Selection RAW])]
i = do
let ([[UnionTag]]
x, [[Selection RAW]]
y) = [([UnionTag], [Selection RAW])]
-> ([[UnionTag]], [[Selection RAW]])
forall a b. [(a, b)] -> ([a], [b])
unzip [([UnionTag], [Selection RAW])]
i
let x' :: [UnionTag]
x' = [[UnionTag]] -> [UnionTag]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[UnionTag]]
x
let y' :: [Selection RAW]
y' = [[Selection RAW]] -> [Selection RAW]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Selection RAW]]
y
([UnionTag]
x',) (SelectionSet RAW -> ([UnionTag], SelectionSet RAW))
-> Validator VALID (OperationContext VALID s) (SelectionSet RAW)
-> FragmentValidator s ([UnionTag], SelectionSet RAW)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Selection RAW]
-> Validator VALID (OperationContext VALID s) (SelectionSet RAW)
forall k (m :: k -> *) a (coll :: k).
FromElems m a coll =>
[a] -> m coll
fromElems [Selection RAW]
y'
exploreFragments ::
(ResolveFragment s) =>
( Fragment RAW ->
FragmentValidator s (SelectionSet VALID)
) ->
[TypeDefinition IMPLEMENTABLE VALID] ->
SelectionSet RAW ->
FragmentValidator s ([UnionTag], SelectionSet RAW)
exploreFragments :: (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeDefinition IMPLEMENTABLE VALID]
-> SelectionSet RAW
-> FragmentValidator s ([UnionTag], SelectionSet RAW)
exploreFragments Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragment [TypeDefinition IMPLEMENTABLE VALID]
types SelectionSet RAW
selectionSet =
(Selection RAW
-> Validator
VALID (OperationContext VALID s) ([UnionTag], [Selection RAW]))
-> [Selection RAW]
-> Validator
VALID (OperationContext VALID s) [([UnionTag], [Selection RAW])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeDefinition IMPLEMENTABLE VALID]
-> Selection RAW
-> Validator
VALID (OperationContext VALID s) ([UnionTag], [Selection RAW])
forall (s :: Stage).
ResolveFragment s =>
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeDefinition IMPLEMENTABLE VALID]
-> Selection RAW
-> FragmentValidator s ([UnionTag], [Selection RAW])
splitFragment Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragment [TypeDefinition IMPLEMENTABLE VALID]
types) (SelectionSet RAW -> [Selection RAW]
forall a coll. Elems a coll => coll -> [a]
elems SelectionSet RAW
selectionSet)
Validator
VALID (OperationContext VALID s) [([UnionTag], [Selection RAW])]
-> ([([UnionTag], [Selection RAW])]
-> FragmentValidator s ([UnionTag], SelectionSet RAW))
-> FragmentValidator s ([UnionTag], SelectionSet RAW)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [([UnionTag], [Selection RAW])]
-> FragmentValidator s ([UnionTag], SelectionSet RAW)
forall (s :: Stage).
[([UnionTag], [Selection RAW])]
-> FragmentValidator s ([UnionTag], SelectionSet RAW)
joinExploredSelection
tagUnionFragments ::
[TypeDefinition IMPLEMENTABLE VALID] ->
[UnionTag] ->
[(TypeName, [SelectionSet VALID])]
tagUnionFragments :: [TypeDefinition IMPLEMENTABLE VALID]
-> [UnionTag] -> [(TypeName, [SelectionSet VALID])]
tagUnionFragments [TypeDefinition IMPLEMENTABLE VALID]
types [UnionTag]
fragments = ((TypeName, [SelectionSet VALID]) -> Bool)
-> [(TypeName, [SelectionSet VALID])]
-> [(TypeName, [SelectionSet VALID])]
forall a. (a -> Bool) -> [a] -> [a]
filter (TypeName, [SelectionSet VALID]) -> Bool
forall a a. (a, [a]) -> Bool
notEmpty (TypeDefinition IMPLEMENTABLE VALID
-> (TypeName, [SelectionSet VALID])
categorizeType (TypeDefinition IMPLEMENTABLE VALID
-> (TypeName, [SelectionSet VALID]))
-> [TypeDefinition IMPLEMENTABLE VALID]
-> [(TypeName, [SelectionSet VALID])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeDefinition IMPLEMENTABLE VALID]
types)
where
notEmpty :: (a, [a]) -> Bool
notEmpty = Bool -> Bool
not (Bool -> Bool) -> ((a, [a]) -> Bool) -> (a, [a]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> ((a, [a]) -> [a]) -> (a, [a]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, [a]) -> [a]
forall a b. (a, b) -> b
snd
categorizeType ::
TypeDefinition IMPLEMENTABLE VALID ->
(TypeName, [SelectionSet VALID])
categorizeType :: TypeDefinition IMPLEMENTABLE VALID
-> (TypeName, [SelectionSet VALID])
categorizeType TypeDefinition IMPLEMENTABLE VALID
datatype = (TypeDefinition IMPLEMENTABLE VALID -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeDefinition IMPLEMENTABLE VALID
datatype, UnionTag -> SelectionSet VALID
unionTagSelection (UnionTag -> SelectionSet VALID)
-> [UnionTag] -> [SelectionSet VALID]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnionTag -> Bool) -> [UnionTag] -> [UnionTag]
forall a. (a -> Bool) -> [a] -> [a]
filter UnionTag -> Bool
matches [UnionTag]
fragments)
where
matches :: UnionTag -> Bool
matches = (TypeName -> [TypeName] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` TypeDefinition IMPLEMENTABLE VALID -> [TypeName]
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> [TypeName]
subTypes TypeDefinition IMPLEMENTABLE VALID
datatype) (TypeName -> Bool) -> (UnionTag -> TypeName) -> UnionTag -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnionTag -> TypeName
unionTagName
subTypes :: TypeDefinition a s -> [TypeName]
subTypes :: TypeDefinition a s -> [TypeName]
subTypes TypeDefinition {TypeName
typeName :: TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName, typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataObject {[TypeName]
objectImplements :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> [TypeName]
objectImplements :: [TypeName]
objectImplements}} =
TypeName
typeName TypeName -> [TypeName] -> [TypeName]
forall a. a -> [a] -> [a]
: [TypeName]
objectImplements
subTypes TypeDefinition {TypeName
typeName :: TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName} = [TypeName
typeName]
joinClusters ::
forall s.
SelectionSet VALID ->
[(TypeName, [SelectionSet VALID])] ->
FragmentValidator s (SelectionContent VALID)
joinClusters :: SelectionSet VALID
-> [(TypeName, [SelectionSet VALID])]
-> FragmentValidator s (SelectionContent VALID)
joinClusters SelectionSet VALID
selSet =
((TypeName, [SelectionSet VALID])
-> Validator VALID (OperationContext VALID s) UnionTag)
-> [(TypeName, [SelectionSet VALID])]
-> Validator VALID (OperationContext VALID s) [UnionTag]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (TypeName, [SelectionSet VALID])
-> Validator VALID (OperationContext VALID s) UnionTag
joinCluster
([(TypeName, [SelectionSet VALID])]
-> Validator VALID (OperationContext VALID s) [UnionTag])
-> ([UnionTag] -> FragmentValidator s (SelectionContent VALID))
-> [(TypeName, [SelectionSet VALID])]
-> FragmentValidator s (SelectionContent VALID)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (UnionSelection VALID -> SelectionContent VALID)
-> Validator
VALID (OperationContext VALID s) (UnionSelection VALID)
-> FragmentValidator s (SelectionContent VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnionSelection VALID -> SelectionContent VALID
UnionSelection (Validator VALID (OperationContext VALID s) (UnionSelection VALID)
-> FragmentValidator s (SelectionContent VALID))
-> ([UnionTag]
-> Validator
VALID (OperationContext VALID s) (UnionSelection VALID))
-> [UnionTag]
-> FragmentValidator s (SelectionContent VALID)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnionTag]
-> Validator
VALID (OperationContext VALID s) (UnionSelection VALID)
forall k (m :: k -> *) a (coll :: k).
FromElems m a coll =>
[a] -> m coll
fromElems
where
joinCluster :: (TypeName, [SelectionSet VALID])
-> Validator VALID (OperationContext VALID s) UnionTag
joinCluster (TypeName
typeName, [SelectionSet VALID]
fragmets) = TypeName -> SelectionSet VALID -> UnionTag
UnionTag TypeName
typeName (SelectionSet VALID -> UnionTag)
-> Validator VALID (OperationContext VALID s) (SelectionSet VALID)
-> Validator VALID (OperationContext VALID s) UnionTag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SelectionSet VALID]
-> Validator VALID (OperationContext VALID s) (SelectionSet VALID)
forall e a (m :: * -> *).
(Collection e a, Monad m, Failure ValidationErrors m,
SemigroupM m a) =>
[a] -> m a
join (SelectionSet VALID
selSet SelectionSet VALID -> [SelectionSet VALID] -> [SelectionSet VALID]
forall a. a -> [a] -> [a]
: [SelectionSet VALID]
fragmets)
withTypename ::
SelectionSet VALID ->
FragmentValidator s (SelectionSet VALID)
withTypename :: SelectionSet VALID -> FragmentValidator s (SelectionSet VALID)
withTypename SelectionSet VALID
sel = do
Position
selectionPosition <- Position -> Maybe Position -> Position
forall a. a -> Maybe a -> a
fromMaybe (Int -> Int -> Position
Position Int
0 Int
0) (Maybe Position -> Position)
-> Validator VALID (OperationContext VALID s) (Maybe Position)
-> Validator VALID (OperationContext VALID s) Position
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Scope -> Maybe Position)
-> Validator VALID (OperationContext VALID s) (Maybe Position)
forall (m :: * -> * -> *) (s :: Stage) c a.
MonadContext m s c =>
(Scope -> a) -> m c a
asksScope Scope -> Maybe Position
position
SelectionSet VALID
sel
SelectionSet VALID
-> SelectionSet VALID -> FragmentValidator s (SelectionSet VALID)
forall (m :: * -> *) a. SemigroupM m a => a -> a -> m a
<:> Selection VALID -> SelectionSet VALID
forall a coll. Collection a coll => a -> coll
singleton
( Selection :: forall (s :: Stage).
Position
-> Maybe FieldName
-> FieldName
-> Arguments s
-> Directives s
-> SelectionContent s
-> Selection s
Selection
{ selectionName :: FieldName
selectionName = FieldName
"__typename",
selectionAlias :: Maybe FieldName
selectionAlias = Maybe FieldName
forall a. Maybe a
Nothing,
Position
selectionPosition :: Position
selectionPosition :: Position
selectionPosition,
selectionArguments :: Arguments VALID
selectionArguments = Arguments VALID
forall a coll. Collection a coll => coll
empty,
selectionContent :: SelectionContent VALID
selectionContent = SelectionContent VALID
forall (s :: Stage). SelectionContent s
SelectionField,
selectionDirectives :: Directives VALID
selectionDirectives = Directives VALID
forall a coll. Collection a coll => coll
empty
}
)
validateInterfaceSelection ::
ResolveFragment s =>
(Fragment RAW -> FragmentValidator s (SelectionSet VALID)) ->
(TypeDefinition IMPLEMENTABLE VALID -> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)) ->
TypeDefinition IMPLEMENTABLE VALID ->
SelectionSet RAW ->
FragmentValidator s (SelectionContent VALID)
validateInterfaceSelection :: (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> (TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID))
-> TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW
-> FragmentValidator s (SelectionContent VALID)
validateInterfaceSelection
Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragment
TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validate
TypeDefinition IMPLEMENTABLE VALID
typeDef
SelectionSet RAW
inputSelectionSet = do
[TypeDefinition IMPLEMENTABLE VALID]
possibleTypes <- TypeDefinition IMPLEMENTABLE VALID
-> Validator
VALID
(OperationContext VALID s)
[TypeDefinition IMPLEMENTABLE VALID]
forall (m :: * -> * -> *) c (s :: Stage).
(Failure InternalError (m c), Monad (m c), MonadContext m s c,
FromCategory (TypeContent TRUE) ANY IMPLEMENTABLE) =>
TypeDefinition IMPLEMENTABLE s
-> m c [TypeDefinition IMPLEMENTABLE s]
askInterfaceTypes TypeDefinition IMPLEMENTABLE VALID
typeDef
([UnionTag]
spreads, SelectionSet RAW
selectionSet) <- (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeDefinition IMPLEMENTABLE VALID]
-> SelectionSet RAW
-> FragmentValidator s ([UnionTag], SelectionSet RAW)
forall (s :: Stage).
ResolveFragment s =>
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeDefinition IMPLEMENTABLE VALID]
-> SelectionSet RAW
-> FragmentValidator s ([UnionTag], SelectionSet RAW)
exploreFragments Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragment [TypeDefinition IMPLEMENTABLE VALID]
possibleTypes SelectionSet RAW
inputSelectionSet
SelectionSet VALID
validSelectionSet <- TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validate TypeDefinition IMPLEMENTABLE VALID
typeDef SelectionSet RAW
selectionSet
let categories :: [(TypeName, [SelectionSet VALID])]
categories = [TypeDefinition IMPLEMENTABLE VALID]
-> [UnionTag] -> [(TypeName, [SelectionSet VALID])]
tagUnionFragments [TypeDefinition IMPLEMENTABLE VALID]
possibleTypes [UnionTag]
spreads
if [(TypeName, [SelectionSet VALID])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(TypeName, [SelectionSet VALID])]
categories
then SelectionContent VALID
-> FragmentValidator s (SelectionContent VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SelectionSet VALID -> SelectionContent VALID
forall (s :: Stage). SelectionSet s -> SelectionContent s
SelectionSet SelectionSet VALID
validSelectionSet)
else do
SelectionSet VALID
validSelectionSetWithTypename <- SelectionSet VALID -> FragmentValidator s (SelectionSet VALID)
forall (s :: Stage).
SelectionSet VALID -> FragmentValidator s (SelectionSet VALID)
withTypename SelectionSet VALID
validSelectionSet
SelectionSet VALID
-> [(TypeName, [SelectionSet VALID])]
-> FragmentValidator s (SelectionContent VALID)
forall (s :: Stage).
SelectionSet VALID
-> [(TypeName, [SelectionSet VALID])]
-> FragmentValidator s (SelectionContent VALID)
joinClusters SelectionSet VALID
validSelectionSetWithTypename (TypeName
-> [(TypeName, [SelectionSet VALID])]
-> [(TypeName, [SelectionSet VALID])]
forall a. TypeName -> [(TypeName, [a])] -> [(TypeName, [a])]
insertDefault (TypeDefinition IMPLEMENTABLE VALID -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeDefinition IMPLEMENTABLE VALID
typeDef) [(TypeName, [SelectionSet VALID])]
categories)
insertDefault :: TypeName -> [(TypeName, [a])] -> [(TypeName, [a])]
insertDefault :: TypeName -> [(TypeName, [a])] -> [(TypeName, [a])]
insertDefault TypeName
interfaceName [(TypeName, [a])]
categories
| Maybe [a] -> Bool
forall a. Maybe a -> Bool
isJust (TypeName -> [(TypeName, [a])] -> Maybe [a]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TypeName
interfaceName [(TypeName, [a])]
categories) = [(TypeName, [a])]
categories
| Bool
otherwise = (TypeName
interfaceName, []) (TypeName, [a]) -> [(TypeName, [a])] -> [(TypeName, [a])]
forall a. a -> [a] -> [a]
: [(TypeName, [a])]
categories
mkUnionRootType :: FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID)
mkUnionRootType :: FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID)
mkUnionRootType = (TypeName
-> TypeContent TRUE IMPLEMENTABLE VALID
-> TypeDefinition IMPLEMENTABLE VALID
forall (a :: TypeCategory) (s :: Stage).
TypeName -> TypeContent TRUE a s -> TypeDefinition a s
`mkType` [TypeName]
-> FieldsDefinition OUT VALID
-> TypeContent (ELEM OBJECT IMPLEMENTABLE) IMPLEMENTABLE VALID
forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (ELEM OBJECT a) a s
DataObject [] FieldsDefinition OUT VALID
forall a coll. Collection a coll => coll
empty) (TypeName -> TypeDefinition IMPLEMENTABLE VALID)
-> Validator VALID (OperationContext VALID s) TypeName
-> FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Scope -> TypeName)
-> Validator VALID (OperationContext VALID s) TypeName
forall (m :: * -> * -> *) (s :: Stage) c a.
MonadContext m s c =>
(Scope -> a) -> m c a
asksScope Scope -> TypeName
currentTypeName
validateUnionSelection ::
ResolveFragment s =>
(Fragment RAW -> FragmentValidator s (SelectionSet VALID)) ->
(TypeDefinition IMPLEMENTABLE VALID -> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)) ->
DataUnion VALID ->
SelectionSet RAW ->
FragmentValidator s (SelectionContent VALID)
validateUnionSelection :: (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> (TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID))
-> DataUnion VALID
-> SelectionSet RAW
-> FragmentValidator s (SelectionContent VALID)
validateUnionSelection Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragment TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validate DataUnion VALID
members SelectionSet RAW
selectionSet = do
[TypeDefinition IMPLEMENTABLE VALID]
unionTypes <- (UnionMember OUT VALID
-> Validator
VALID
(OperationContext VALID s)
(TypeDefinition IMPLEMENTABLE VALID))
-> DataUnion VALID
-> Validator
VALID
(OperationContext VALID s)
[TypeDefinition IMPLEMENTABLE VALID]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((TypeDefinition OBJECT VALID -> TypeDefinition IMPLEMENTABLE VALID)
-> Validator
VALID (OperationContext VALID s) (TypeDefinition OBJECT VALID)
-> Validator
VALID
(OperationContext VALID s)
(TypeDefinition IMPLEMENTABLE VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeDefinition OBJECT VALID -> TypeDefinition IMPLEMENTABLE VALID
forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
(k' :: TypeCategory) (s :: Stage).
ToCategory a k k' =>
a k s -> a k' s
toCategory (Validator
VALID (OperationContext VALID s) (TypeDefinition OBJECT VALID)
-> Validator
VALID
(OperationContext VALID s)
(TypeDefinition IMPLEMENTABLE VALID))
-> (UnionMember OUT VALID
-> Validator
VALID (OperationContext VALID s) (TypeDefinition OBJECT VALID))
-> UnionMember OUT VALID
-> Validator
VALID
(OperationContext VALID s)
(TypeDefinition IMPLEMENTABLE VALID)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnionMember OUT VALID
-> Validator
VALID (OperationContext VALID s) (TypeDefinition OBJECT VALID)
forall (m :: * -> * -> *) c (cat :: TypeCategory) (s :: Stage).
Constraints m c cat s =>
UnionMember cat s -> m c (TypeMemberResponse cat s)
askTypeMember) DataUnion VALID
members
([UnionTag]
spreads, SelectionSet RAW
selSet) <- (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeDefinition IMPLEMENTABLE VALID]
-> SelectionSet RAW
-> FragmentValidator s ([UnionTag], SelectionSet RAW)
forall (s :: Stage).
ResolveFragment s =>
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeDefinition IMPLEMENTABLE VALID]
-> SelectionSet RAW
-> FragmentValidator s ([UnionTag], SelectionSet RAW)
exploreFragments Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragment [TypeDefinition IMPLEMENTABLE VALID]
unionTypes SelectionSet RAW
selectionSet
TypeDefinition IMPLEMENTABLE VALID
typeDef <- Validator
VALID
(OperationContext VALID s)
(TypeDefinition IMPLEMENTABLE VALID)
forall (s :: Stage).
FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID)
mkUnionRootType
SelectionSet VALID
validSelection <- TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validate TypeDefinition IMPLEMENTABLE VALID
typeDef SelectionSet RAW
selSet
SelectionSet VALID
-> [(TypeName, [SelectionSet VALID])]
-> FragmentValidator s (SelectionContent VALID)
forall (s :: Stage).
SelectionSet VALID
-> [(TypeName, [SelectionSet VALID])]
-> FragmentValidator s (SelectionContent VALID)
joinClusters SelectionSet VALID
validSelection ([TypeDefinition IMPLEMENTABLE VALID]
-> [UnionTag] -> [(TypeName, [SelectionSet VALID])]
tagUnionFragments [TypeDefinition IMPLEMENTABLE VALID]
unionTypes [UnionTag]
spreads)