{-# 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)

-- returns all Fragments used for Possible Types
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

-- sorts Fragment by contitional Types
-- [
--   ( Type for Tag User , [ Fragment for User] )
--   ( Type for Tag Product , [ Fragment for Product] )
-- ]
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]

{-
    - all Variable and Fragment references will be: resolved and validated
    - unionTypes: will be clustered under type names
      ...A on T1 {<SelectionA>}
      ...B on T2 {<SelectionB>}
      ...C on T2 {<SelectionC>}
      will be become : [
          UnionTag "T1" {<SelectionA>},
          UnionTag "T2" {<SelectionB>,<SelectionC>}
      ]
 -}
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
  -- get union Types defined in GraphQL schema -> (union Tag, union Selection set)
  -- [("User", FieldsDefinition { ... }), ("Product", FieldsDefinition { ...
  [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
  -- find all Fragments used in Selection
  ([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)