{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Validation.Query.UnionSelection
  ( validateUnionSelection,
    validateInterfaceSelection,
  )
where

import Control.Monad.Except (MonadError (throwError))
import Data.Mergeable (IsMap (toAssoc), OrdMap)
import Data.Mergeable.OrdMap (ordMapDelete)
import Data.Morpheus.Internal.Utils
  ( empty,
    fromElems,
    mergeConcat,
    selectOr,
    startHistory,
    unsafeFromList,
  )
import Data.Morpheus.Types.Internal.AST.DirectiveLocation (DirectiveLocation (..))
import Data.Morpheus.Types.Internal.AST.Name (TypeName)
import Data.Morpheus.Types.Internal.AST.Selection
  ( Fragment (..),
    Selection (..),
    SelectionContent (..),
    SelectionSet,
    UnionTag (..),
  )
import Data.Morpheus.Types.Internal.AST.Stage (RAW, VALID)
import Data.Morpheus.Types.Internal.AST.TypeCategory
  ( IMPLEMENTABLE,
    OUT,
    toCategory,
  )
import Data.Morpheus.Types.Internal.AST.TypeSystem
  ( TypeContent (..),
    TypeDefinition (..),
    UnionTypeDefinition,
    mkType,
  )
import Data.Morpheus.Types.Internal.Validation
  ( FragmentValidator,
    Scope (..),
    askInterfaceTypes,
    askTypeMember,
    asksScope,
  )
import Data.Morpheus.Validation.Internal.Directive (validateDirectives)
import Data.Morpheus.Validation.Query.Fragment
  ( ValidateFragmentSelection,
    castFragmentType,
    validateSpread,
  )
import Relude hiding (empty, join)

-- returns all Fragments used for Possible Types
splitFragment ::
  (ValidateFragmentSelection s) =>
  ( Fragment RAW ->
    FragmentValidator s (SelectionSet VALID)
  ) ->
  [TypeDefinition IMPLEMENTABLE VALID] ->
  Selection RAW ->
  FragmentValidator s (Either UnionTag (Selection RAW))
splitFragment :: forall (s :: Stage).
ValidateFragmentSelection s =>
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeDefinition IMPLEMENTABLE VALID]
-> Selection RAW
-> FragmentValidator s (Either UnionTag (Selection RAW))
splitFragment Fragment RAW -> FragmentValidator s (SelectionSet VALID)
_ [TypeDefinition IMPLEMENTABLE VALID]
_ x :: Selection RAW
x@Selection {} = Either UnionTag (Selection RAW)
-> Validator
     VALID (OperationContext VALID s) (Either UnionTag (Selection RAW))
forall a. a -> Validator VALID (OperationContext VALID s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Selection RAW -> Either UnionTag (Selection RAW)
forall a b. b -> Either a b
Right Selection RAW
x)
splitFragment Fragment RAW -> FragmentValidator s (SelectionSet VALID)
f [TypeDefinition IMPLEMENTABLE VALID]
types (Spread Directives RAW
dirs Ref FragmentName
ref) = do
  Directives VALID
_ <- DirectiveLocation
-> Directives RAW
-> Validator VALID (OperationContext VALID s) (Directives VALID)
forall ctx (schemaS :: Stage) (s :: Stage).
ArgumentsConstraints ctx schemaS s =>
DirectiveLocation
-> Directives s -> Validator schemaS ctx (Directives VALID)
validateDirectives DirectiveLocation
LOCATION_FRAGMENT_SPREAD Directives RAW
dirs
  UnionTag -> Either UnionTag (Selection RAW)
forall a b. a -> Either a b
Left (UnionTag -> Either UnionTag (Selection RAW))
-> Validator VALID (OperationContext VALID s) UnionTag
-> Validator
     VALID (OperationContext VALID s) (Either UnionTag (Selection RAW))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeName]
-> Ref FragmentName
-> Validator VALID (OperationContext VALID s) UnionTag
forall (s :: Stage).
ValidateFragmentSelection s =>
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeName] -> Ref FragmentName -> FragmentValidator s UnionTag
validateSpread 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 FragmentName
ref
splitFragment Fragment RAW -> FragmentValidator s (SelectionSet VALID)
f [TypeDefinition IMPLEMENTABLE VALID]
types (InlineFragment fragment :: Fragment RAW
fragment@Fragment {SelectionSet RAW
Directives RAW
Position
TypeName
FragmentName
fragmentName :: FragmentName
fragmentType :: TypeName
fragmentPosition :: Position
fragmentSelection :: SelectionSet RAW
fragmentDirectives :: Directives RAW
fragmentName :: forall (stage :: Stage). Fragment stage -> FragmentName
fragmentType :: forall (stage :: Stage). Fragment stage -> TypeName
fragmentPosition :: forall (stage :: Stage). Fragment stage -> Position
fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentDirectives :: forall (stage :: Stage). Fragment stage -> Directives stage
..}) = do
  Directives VALID
_ <- DirectiveLocation
-> Directives RAW
-> Validator VALID (OperationContext VALID s) (Directives VALID)
forall ctx (schemaS :: Stage) (s :: Stage).
ArgumentsConstraints ctx schemaS s =>
DirectiveLocation
-> Directives s -> Validator schemaS ctx (Directives VALID)
validateDirectives DirectiveLocation
LOCATION_INLINE_FRAGMENT Directives RAW
fragmentDirectives
  UnionTag -> Either UnionTag (Selection RAW)
forall a b. a -> Either a b
Left (UnionTag -> Either UnionTag (Selection RAW))
-> (MergeMap 'False FieldName (Selection VALID) -> UnionTag)
-> MergeMap 'False FieldName (Selection VALID)
-> Either UnionTag (Selection RAW)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> SelectionSet VALID -> UnionTag
UnionTag TypeName
fragmentType
    (MergeMap 'False FieldName (Selection VALID)
 -> Either UnionTag (Selection RAW))
-> Validator
     VALID
     (OperationContext VALID s)
     (MergeMap 'False FieldName (Selection VALID))
-> Validator
     VALID (OperationContext VALID s) (Either UnionTag (Selection RAW))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe FragmentName
-> Position
-> [TypeName]
-> Fragment RAW
-> FragmentValidator s (Fragment RAW)
forall (s :: Stage) (s1 :: Stage).
Maybe FragmentName
-> Position
-> [TypeName]
-> Fragment s
-> FragmentValidator s1 (Fragment s)
castFragmentType Maybe FragmentName
forall a. Maybe a
Nothing Position
fragmentPosition (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
    -> Validator
         VALID
         (OperationContext VALID s)
         (MergeMap 'False FieldName (Selection VALID)))
-> Validator
     VALID
     (OperationContext VALID s)
     (MergeMap 'False FieldName (Selection VALID))
forall a b.
Validator VALID (OperationContext VALID s) a
-> (a -> Validator VALID (OperationContext VALID s) b)
-> Validator VALID (OperationContext VALID s) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Fragment RAW
-> Validator
     VALID
     (OperationContext VALID s)
     (MergeMap 'False FieldName (Selection VALID))
Fragment RAW -> FragmentValidator s (SelectionSet VALID)
f)

exploreFragments ::
  (ValidateFragmentSelection s) =>
  (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) ->
  OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID) ->
  SelectionSet RAW ->
  FragmentValidator s ([UnionTag], Maybe (SelectionSet RAW))
exploreFragments :: forall (s :: Stage).
ValidateFragmentSelection s =>
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
-> SelectionSet RAW
-> FragmentValidator s ([UnionTag], Maybe (SelectionSet RAW))
exploreFragments Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragment OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
types SelectionSet RAW
selectionSet = do
  ([UnionTag]
tags, [Selection RAW]
selections) <- [Either UnionTag (Selection RAW)] -> ([UnionTag], [Selection RAW])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either UnionTag (Selection RAW)]
 -> ([UnionTag], [Selection RAW]))
-> Validator
     VALID (OperationContext VALID s) [Either UnionTag (Selection RAW)]
-> Validator
     VALID (OperationContext VALID s) ([UnionTag], [Selection RAW])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Selection RAW
 -> Validator
      VALID (OperationContext VALID s) (Either UnionTag (Selection RAW)))
-> [Selection RAW]
-> Validator
     VALID (OperationContext VALID s) [Either UnionTag (Selection RAW)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeDefinition IMPLEMENTABLE VALID]
-> Selection RAW
-> Validator
     VALID (OperationContext VALID s) (Either UnionTag (Selection RAW))
forall (s :: Stage).
ValidateFragmentSelection s =>
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeDefinition IMPLEMENTABLE VALID]
-> Selection RAW
-> FragmentValidator s (Either UnionTag (Selection RAW))
splitFragment Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragment (OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
-> [TypeDefinition IMPLEMENTABLE VALID]
forall a. OrdMap TypeName a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
types)) (MergeMap 'True FieldName (Selection RAW) -> [Selection RAW]
forall a. MergeMap 'True FieldName a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList MergeMap 'True FieldName (Selection RAW)
SelectionSet RAW
selectionSet)
  ([UnionTag]
tags,)
    (Maybe (MergeMap 'True FieldName (Selection RAW))
 -> ([UnionTag], Maybe (MergeMap 'True FieldName (Selection RAW))))
-> Validator
     VALID
     (OperationContext VALID s)
     (Maybe (MergeMap 'True FieldName (Selection RAW)))
-> Validator
     VALID
     (OperationContext VALID s)
     ([UnionTag], Maybe (MergeMap 'True FieldName (Selection RAW)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if [Selection RAW] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Selection RAW]
selections
      then Maybe (MergeMap 'True FieldName (Selection RAW))
-> Validator
     VALID
     (OperationContext VALID s)
     (Maybe (MergeMap 'True FieldName (Selection RAW)))
forall a. a -> Validator VALID (OperationContext VALID s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (MergeMap 'True FieldName (Selection RAW))
forall a. Maybe a
Nothing
      else MergeMap 'True FieldName (Selection RAW)
-> Maybe (MergeMap 'True FieldName (Selection RAW))
forall a. a -> Maybe a
Just (MergeMap 'True FieldName (Selection RAW)
 -> Maybe (MergeMap 'True FieldName (Selection RAW)))
-> Validator
     VALID
     (OperationContext VALID s)
     (MergeMap 'True FieldName (Selection RAW))
-> Validator
     VALID
     (OperationContext VALID s)
     (Maybe (MergeMap 'True FieldName (Selection RAW)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Selection RAW]
-> Validator
     VALID
     (OperationContext VALID s)
     (MergeMap 'True FieldName (Selection RAW))
forall (m :: * -> *) k a (map :: * -> * -> *).
(Monad m, KeyOf k a, FromList m map k a) =>
[a] -> m (map k a)
fromElems [Selection RAW]
selections

-- sorts Fragment by conditional Types
-- [
--   ( Type for Tag User , [ Fragment for User] )
--   ( Type for Tag Product , [ Fragment for Product] )
-- ]
tagUnionFragments ::
  [UnionTag] ->
  OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID) ->
  OrdMap TypeName [SelectionSet VALID]
tagUnionFragments :: [UnionTag]
-> OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
-> OrdMap TypeName [SelectionSet VALID]
tagUnionFragments [UnionTag]
fragments OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
types = ([TypeName] -> [MergeMap 'False FieldName (Selection VALID)])
-> OrdMap TypeName [TypeName]
-> OrdMap TypeName [MergeMap 'False FieldName (Selection VALID)]
forall a b. (a -> b) -> OrdMap TypeName a -> OrdMap TypeName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TypeName] -> [MergeMap 'False FieldName (Selection VALID)]
[TypeName] -> [SelectionSet VALID]
categorizeType OrdMap TypeName [TypeName]
getSelectedTypes
  where
    getSelectedTypes :: OrdMap TypeName [TypeName]
    getSelectedTypes :: OrdMap TypeName [TypeName]
getSelectedTypes = [(TypeName, [TypeName])] -> OrdMap TypeName [TypeName]
forall a. [(TypeName, a)] -> OrdMap TypeName a
forall k (m :: * -> *) a. IsMap k m => [(k, a)] -> m a
unsafeFromList ((UnionTag -> (TypeName, [TypeName]))
-> [UnionTag] -> [(TypeName, [TypeName])]
forall a b. (a -> b) -> [a] -> [b]
map UnionTag -> (TypeName, [TypeName])
select [UnionTag]
fragments)
      where
        select :: UnionTag -> (TypeName, [TypeName])
select UnionTag {TypeName
unionTagName :: TypeName
unionTagName :: UnionTag -> TypeName
unionTagName} =
          ( TypeName
unionTagName,
            [TypeName]
-> (TypeDefinition IMPLEMENTABLE VALID -> [TypeName])
-> TypeName
-> OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
-> [TypeName]
forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr
              [TypeName
unionTagName]
              TypeDefinition IMPLEMENTABLE VALID -> [TypeName]
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> [TypeName]
getCompatibleTypes
              TypeName
unionTagName
              OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
types
          )
    categorizeType ::
      [TypeName] -> [SelectionSet VALID]
    categorizeType :: [TypeName] -> [SelectionSet VALID]
categorizeType [TypeName]
compatibleTypes =
      UnionTag -> MergeMap 'False FieldName (Selection VALID)
UnionTag -> SelectionSet VALID
unionTagSelection
        (UnionTag -> MergeMap 'False FieldName (Selection VALID))
-> [UnionTag] -> [MergeMap 'False FieldName (Selection VALID)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnionTag -> Bool) -> [UnionTag] -> [UnionTag]
forall a. (a -> Bool) -> [a] -> [a]
filter
          ((TypeName -> [TypeName] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TypeName]
compatibleTypes) (TypeName -> Bool) -> (UnionTag -> TypeName) -> UnionTag -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnionTag -> TypeName
unionTagName)
          [UnionTag]
fragments

getCompatibleTypes :: TypeDefinition a s -> [TypeName]
getCompatibleTypes :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> [TypeName]
getCompatibleTypes TypeDefinition {TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName :: TypeName
typeName, typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent 'True a s
typeContent = DataObject {[TypeName]
objectImplements :: [TypeName]
objectImplements :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> [TypeName]
objectImplements}} = TypeName
typeName TypeName -> [TypeName] -> [TypeName]
forall a. a -> [a] -> [a]
: [TypeName]
objectImplements
getCompatibleTypes TypeDefinition {TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName :: TypeName
typeName} = [TypeName
typeName]

maybeMerge :: [SelectionSet VALID] -> FragmentValidator s (Maybe (SelectionSet VALID))
maybeMerge :: forall (s :: Stage).
[SelectionSet VALID]
-> FragmentValidator s (Maybe (SelectionSet VALID))
maybeMerge [] = Maybe (MergeMap 'False FieldName (Selection VALID))
-> Validator
     VALID
     (OperationContext VALID s)
     (Maybe (MergeMap 'False FieldName (Selection VALID)))
forall a. a -> Validator VALID (OperationContext VALID s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (MergeMap 'False FieldName (Selection VALID))
forall a. Maybe a
Nothing
maybeMerge (SelectionSet VALID
x : [SelectionSet VALID]
xs) = MergeMap 'False FieldName (Selection VALID)
-> Maybe (MergeMap 'False FieldName (Selection VALID))
forall a. a -> Maybe a
Just (MergeMap 'False FieldName (Selection VALID)
 -> Maybe (MergeMap 'False FieldName (Selection VALID)))
-> Validator
     VALID
     (OperationContext VALID s)
     (MergeMap 'False FieldName (Selection VALID))
-> Validator
     VALID
     (OperationContext VALID s)
     (Maybe (MergeMap 'False FieldName (Selection VALID)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HistoryT
  (Validator VALID (OperationContext VALID s))
  (MergeMap 'False FieldName (Selection VALID))
-> Validator
     VALID
     (OperationContext VALID s)
     (MergeMap 'False FieldName (Selection VALID))
forall (m :: * -> *) a. HistoryT m a -> m a
startHistory (NonEmpty (MergeMap 'False FieldName (Selection VALID))
-> HistoryT
     (Validator VALID (OperationContext VALID s))
     (MergeMap 'False FieldName (Selection VALID))
forall (m :: * -> *) a e.
(Monad m, Merge m a, MonadError e m) =>
NonEmpty a -> m a
mergeConcat (MergeMap 'False FieldName (Selection VALID)
SelectionSet VALID
x MergeMap 'False FieldName (Selection VALID)
-> [MergeMap 'False FieldName (Selection VALID)]
-> NonEmpty (MergeMap 'False FieldName (Selection VALID))
forall a. a -> [a] -> NonEmpty a
:| [MergeMap 'False FieldName (Selection VALID)]
[SelectionSet VALID]
xs))

noEmptySelection :: FragmentValidator s a
noEmptySelection :: forall (s :: Stage) a. FragmentValidator s a
noEmptySelection = GQLError -> Validator VALID (OperationContext VALID s) a
forall a. GQLError -> Validator VALID (OperationContext VALID s) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GQLError
"empty selection sets are not supported."

joinClusters ::
  Maybe (SelectionSet VALID) ->
  OrdMap TypeName [SelectionSet VALID] ->
  FragmentValidator s (SelectionContent VALID)
joinClusters :: forall (s :: Stage).
Maybe (SelectionSet VALID)
-> OrdMap TypeName [SelectionSet VALID]
-> FragmentValidator s (SelectionContent VALID)
joinClusters Maybe (SelectionSet VALID)
maybeSelSet OrdMap TypeName [SelectionSet VALID]
typedSelections
  | OrdMap TypeName [MergeMap 'False FieldName (Selection VALID)]
-> Bool
forall a. OrdMap TypeName a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null OrdMap TypeName [MergeMap 'False FieldName (Selection VALID)]
OrdMap TypeName [SelectionSet VALID]
typedSelections = FragmentValidator s (SelectionContent VALID)
-> (MergeMap 'False FieldName (Selection VALID)
    -> FragmentValidator s (SelectionContent VALID))
-> Maybe (MergeMap 'False FieldName (Selection VALID))
-> FragmentValidator s (SelectionContent VALID)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FragmentValidator s (SelectionContent VALID)
forall (s :: Stage) a. FragmentValidator s a
noEmptySelection (SelectionContent VALID
-> FragmentValidator s (SelectionContent VALID)
forall a. a -> Validator VALID (OperationContext VALID s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SelectionContent VALID
 -> FragmentValidator s (SelectionContent VALID))
-> (MergeMap 'False FieldName (Selection VALID)
    -> SelectionContent VALID)
-> MergeMap 'False FieldName (Selection VALID)
-> FragmentValidator s (SelectionContent VALID)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MergeMap 'False FieldName (Selection VALID)
-> SelectionContent VALID
SelectionSet VALID -> SelectionContent VALID
forall (s :: Stage). SelectionSet s -> SelectionContent s
SelectionSet) Maybe (MergeMap 'False FieldName (Selection VALID))
Maybe (SelectionSet VALID)
maybeSelSet
  | Bool
otherwise =
      ((TypeName, [MergeMap 'False FieldName (Selection VALID)])
 -> Validator VALID (OperationContext VALID s) UnionTag)
-> [(TypeName, [MergeMap 'False FieldName (Selection VALID)])]
-> Validator VALID (OperationContext VALID s) [UnionTag]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (TypeName, [MergeMap 'False FieldName (Selection VALID)])
-> Validator VALID (OperationContext VALID s) UnionTag
(TypeName, [SelectionSet VALID])
-> Validator VALID (OperationContext VALID s) UnionTag
forall (s :: Stage).
(TypeName, [SelectionSet VALID]) -> FragmentValidator s UnionTag
mkUnionTag (OrdMap TypeName [MergeMap 'False FieldName (Selection VALID)]
-> [(TypeName, [MergeMap 'False FieldName (Selection VALID)])]
forall a. OrdMap TypeName a -> [(TypeName, a)]
forall k (m :: * -> *) a. IsMap k m => m a -> [(k, a)]
toAssoc OrdMap TypeName [MergeMap 'False FieldName (Selection VALID)]
OrdMap TypeName [SelectionSet VALID]
typedSelections)
        Validator VALID (OperationContext VALID s) [UnionTag]
-> ([UnionTag] -> FragmentValidator s (SelectionContent VALID))
-> FragmentValidator s (SelectionContent VALID)
forall a b.
Validator VALID (OperationContext VALID s) a
-> (a -> Validator VALID (OperationContext VALID s) b)
-> Validator VALID (OperationContext VALID s) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (MergeMap 'False TypeName UnionTag -> SelectionContent VALID)
-> Validator
     VALID
     (OperationContext VALID s)
     (MergeMap 'False TypeName UnionTag)
-> FragmentValidator s (SelectionContent VALID)
forall a b.
(a -> b)
-> Validator VALID (OperationContext VALID s) a
-> Validator VALID (OperationContext VALID s) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe (SelectionSet VALID)
-> UnionSelection VALID -> SelectionContent VALID
UnionSelection Maybe (SelectionSet VALID)
maybeSelSet) (Validator
   VALID
   (OperationContext VALID s)
   (MergeMap 'False TypeName UnionTag)
 -> FragmentValidator s (SelectionContent VALID))
-> ([UnionTag]
    -> Validator
         VALID
         (OperationContext VALID s)
         (MergeMap 'False TypeName UnionTag))
-> [UnionTag]
-> FragmentValidator s (SelectionContent VALID)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HistoryT
  (Validator VALID (OperationContext VALID s))
  (MergeMap 'False TypeName UnionTag)
-> Validator
     VALID
     (OperationContext VALID s)
     (MergeMap 'False TypeName UnionTag)
forall (m :: * -> *) a. HistoryT m a -> m a
startHistory (HistoryT
   (Validator VALID (OperationContext VALID s))
   (MergeMap 'False TypeName UnionTag)
 -> Validator
      VALID
      (OperationContext VALID s)
      (MergeMap 'False TypeName UnionTag))
-> ([UnionTag]
    -> HistoryT
         (Validator VALID (OperationContext VALID s))
         (MergeMap 'False TypeName UnionTag))
-> [UnionTag]
-> Validator
     VALID
     (OperationContext VALID s)
     (MergeMap 'False TypeName UnionTag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnionTag]
-> HistoryT
     (Validator VALID (OperationContext VALID s))
     (MergeMap 'False TypeName UnionTag)
forall (m :: * -> *) k a (map :: * -> * -> *).
(Monad m, KeyOf k a, FromList m map k a) =>
[a] -> m (map k a)
fromElems
  where
    mkUnionTag :: (TypeName, [SelectionSet VALID]) -> FragmentValidator s UnionTag
    mkUnionTag :: forall (s :: Stage).
(TypeName, [SelectionSet VALID]) -> FragmentValidator s UnionTag
mkUnionTag (TypeName
typeName, [SelectionSet VALID]
fragments) = TypeName -> SelectionSet VALID -> UnionTag
UnionTag TypeName
typeName (MergeMap 'False FieldName (Selection VALID) -> UnionTag)
-> Validator
     VALID
     (OperationContext VALID s)
     (MergeMap 'False FieldName (Selection VALID))
-> Validator VALID (OperationContext VALID s) UnionTag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([SelectionSet VALID]
-> FragmentValidator s (Maybe (SelectionSet VALID))
forall (s :: Stage).
[SelectionSet VALID]
-> FragmentValidator s (Maybe (SelectionSet VALID))
maybeMerge (Maybe (MergeMap 'False FieldName (Selection VALID))
-> [MergeMap 'False FieldName (Selection VALID)]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe (MergeMap 'False FieldName (Selection VALID))
Maybe (SelectionSet VALID)
maybeSelSet [MergeMap 'False FieldName (Selection VALID)]
-> [MergeMap 'False FieldName (Selection VALID)]
-> [MergeMap 'False FieldName (Selection VALID)]
forall a. Semigroup a => a -> a -> a
<> [MergeMap 'False FieldName (Selection VALID)]
[SelectionSet VALID]
fragments) Validator
  VALID
  (OperationContext VALID s)
  (Maybe (MergeMap 'False FieldName (Selection VALID)))
-> (Maybe (MergeMap 'False FieldName (Selection VALID))
    -> Validator
         VALID
         (OperationContext VALID s)
         (MergeMap 'False FieldName (Selection VALID)))
-> Validator
     VALID
     (OperationContext VALID s)
     (MergeMap 'False FieldName (Selection VALID))
forall a b.
Validator VALID (OperationContext VALID s) a
-> (a -> Validator VALID (OperationContext VALID s) b)
-> Validator VALID (OperationContext VALID s) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Validator
  VALID
  (OperationContext VALID s)
  (MergeMap 'False FieldName (Selection VALID))
-> (MergeMap 'False FieldName (Selection VALID)
    -> Validator
         VALID
         (OperationContext VALID s)
         (MergeMap 'False FieldName (Selection VALID)))
-> Maybe (MergeMap 'False FieldName (Selection VALID))
-> Validator
     VALID
     (OperationContext VALID s)
     (MergeMap 'False FieldName (Selection VALID))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Validator
  VALID
  (OperationContext VALID s)
  (MergeMap 'False FieldName (Selection VALID))
forall (s :: Stage) a. FragmentValidator s a
noEmptySelection MergeMap 'False FieldName (Selection VALID)
-> Validator
     VALID
     (OperationContext VALID s)
     (MergeMap 'False FieldName (Selection VALID))
forall a. a -> Validator VALID (OperationContext VALID s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)

validateInterfaceSelection ::
  (ValidateFragmentSelection 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 :: forall (s :: Stage).
ValidateFragmentSelection 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)
validateFragment
  TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validate
  typeDef :: TypeDefinition IMPLEMENTABLE VALID
typeDef@TypeDefinition {TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName :: TypeName
typeName}
  SelectionSet RAW
inputSelectionSet = do
    OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
possibleTypes <- TypeDefinition IMPLEMENTABLE VALID
-> Validator
     VALID
     (OperationContext VALID s)
     (OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID))
forall (m :: * -> *) (s :: Stage) ctx.
(MonadError GQLError m, MonadReader (ValidatorContext s ctx) m,
 FromCategory (TypeContent 'True) ANY IMPLEMENTABLE) =>
TypeDefinition IMPLEMENTABLE s
-> m (OrdMap TypeName (TypeDefinition IMPLEMENTABLE s))
askInterfaceTypes TypeDefinition IMPLEMENTABLE VALID
typeDef
    ([UnionTag]
spreads, Maybe (MergeMap 'True FieldName (Selection RAW))
selectionSet) <- (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
-> SelectionSet RAW
-> FragmentValidator s ([UnionTag], Maybe (SelectionSet RAW))
forall (s :: Stage).
ValidateFragmentSelection s =>
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
-> SelectionSet RAW
-> FragmentValidator s ([UnionTag], Maybe (SelectionSet RAW))
exploreFragments Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragment OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
possibleTypes SelectionSet RAW
inputSelectionSet
    Maybe (MergeMap 'False FieldName (Selection VALID))
validSelectionSet <- (MergeMap 'True FieldName (Selection RAW)
 -> Validator
      VALID
      (OperationContext VALID s)
      (MergeMap 'False FieldName (Selection VALID)))
-> Maybe (MergeMap 'True FieldName (Selection RAW))
-> Validator
     VALID
     (OperationContext VALID s)
     (Maybe (MergeMap 'False FieldName (Selection VALID)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validate TypeDefinition IMPLEMENTABLE VALID
typeDef) Maybe (MergeMap 'True FieldName (Selection RAW))
selectionSet
    let tags :: OrdMap TypeName [SelectionSet VALID]
tags = [UnionTag]
-> OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
-> OrdMap TypeName [SelectionSet VALID]
tagUnionFragments [UnionTag]
spreads OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
possibleTypes
    Maybe (MergeMap 'False FieldName (Selection VALID))
defaultSelection <- [SelectionSet VALID]
-> FragmentValidator s (Maybe (SelectionSet VALID))
forall (s :: Stage).
[SelectionSet VALID]
-> FragmentValidator s (Maybe (SelectionSet VALID))
maybeMerge (Maybe (MergeMap 'False FieldName (Selection VALID))
-> [MergeMap 'False FieldName (Selection VALID)]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe (MergeMap 'False FieldName (Selection VALID))
validSelectionSet [MergeMap 'False FieldName (Selection VALID)]
-> [MergeMap 'False FieldName (Selection VALID)]
-> [MergeMap 'False FieldName (Selection VALID)]
forall a. Semigroup a => a -> a -> a
<> [MergeMap 'False FieldName (Selection VALID)]
-> ([MergeMap 'False FieldName (Selection VALID)]
    -> [MergeMap 'False FieldName (Selection VALID)])
-> TypeName
-> OrdMap TypeName [MergeMap 'False FieldName (Selection VALID)]
-> [MergeMap 'False FieldName (Selection VALID)]
forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr [] [MergeMap 'False FieldName (Selection VALID)]
-> [MergeMap 'False FieldName (Selection VALID)]
forall a. a -> a
id TypeName
typeName OrdMap TypeName [MergeMap 'False FieldName (Selection VALID)]
OrdMap TypeName [SelectionSet VALID]
tags)
    Maybe (SelectionSet VALID)
-> OrdMap TypeName [SelectionSet VALID]
-> FragmentValidator s (SelectionContent VALID)
forall (s :: Stage).
Maybe (SelectionSet VALID)
-> OrdMap TypeName [SelectionSet VALID]
-> FragmentValidator s (SelectionContent VALID)
joinClusters Maybe (MergeMap 'False FieldName (Selection VALID))
Maybe (SelectionSet VALID)
defaultSelection (TypeName
-> OrdMap TypeName [MergeMap 'False FieldName (Selection VALID)]
-> OrdMap TypeName [MergeMap 'False FieldName (Selection VALID)]
forall k a. (Eq k, Hashable k) => k -> OrdMap k a -> OrdMap k a
ordMapDelete TypeName
typeName OrdMap TypeName [MergeMap 'False FieldName (Selection VALID)]
OrdMap TypeName [SelectionSet VALID]
tags)

mkUnionRootType :: FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID)
mkUnionRootType :: forall (s :: Stage).
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 (OBJECT <=? IMPLEMENTABLE) IMPLEMENTABLE VALID
forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (OBJECT <=? a) a s
DataObject [] FieldsDefinition OUT VALID
forall coll. Empty coll => coll
empty) (TypeName -> TypeDefinition IMPLEMENTABLE VALID)
-> Validator VALID (OperationContext VALID s) TypeName
-> Validator
     VALID
     (OperationContext VALID 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 (s :: Stage) ctx (m :: * -> *) a.
MonadReader (ValidatorContext s ctx) m =>
(Scope -> a) -> m a
asksScope Scope -> TypeName
currentTypeName

validateUnionSelection ::
  (ValidateFragmentSelection s) =>
  (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) ->
  (TypeDefinition IMPLEMENTABLE VALID -> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)) ->
  UnionTypeDefinition OUT VALID ->
  SelectionSet RAW ->
  FragmentValidator s (SelectionContent VALID)
validateUnionSelection :: forall (s :: Stage).
ValidateFragmentSelection s =>
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> (TypeDefinition IMPLEMENTABLE VALID
    -> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID))
-> UnionTypeDefinition OUT 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 UnionTypeDefinition OUT VALID
members SelectionSet RAW
inputSelectionSet = do
  TypeDefinition IMPLEMENTABLE VALID
typeDef <- FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID)
forall (s :: Stage).
FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID)
mkUnionRootType
  OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
possibleTypes <- (UnionMember OUT VALID
 -> FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID))
-> UnionTypeDefinition OUT VALID
-> Validator
     VALID
     (OperationContext VALID s)
     (OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> OrdMap TypeName a -> f (OrdMap TypeName b)
traverse ((TypeDefinition OBJECT VALID -> TypeDefinition IMPLEMENTABLE VALID)
-> Validator
     VALID (OperationContext VALID s) (TypeDefinition OBJECT VALID)
-> FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID)
forall a b.
(a -> b)
-> Validator VALID (OperationContext VALID s) a
-> Validator VALID (OperationContext VALID s) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeDefinition OBJECT VALID -> TypeDefinition IMPLEMENTABLE VALID
forall (s :: Stage).
TypeDefinition OBJECT s -> TypeDefinition IMPLEMENTABLE s
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)
 -> FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID))
-> (UnionMember OUT VALID
    -> Validator
         VALID (OperationContext VALID s) (TypeDefinition OBJECT VALID))
-> UnionMember OUT VALID
-> FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnionMember OUT VALID
-> Validator
     VALID
     (OperationContext VALID s)
     (TypeDefinition (ToOBJECT OUT) VALID)
UnionMember OUT VALID
-> Validator
     VALID (OperationContext VALID s) (TypeDefinition OBJECT VALID)
forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx.
Constraints m c cat s ctx =>
UnionMember cat s -> m (TypeDefinition (ToOBJECT cat) s)
askTypeMember) UnionTypeDefinition OUT VALID
members
  ([UnionTag]
spreads, Maybe (MergeMap 'True FieldName (Selection RAW))
selectionSet) <- (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
-> SelectionSet RAW
-> FragmentValidator s ([UnionTag], Maybe (SelectionSet RAW))
forall (s :: Stage).
ValidateFragmentSelection s =>
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
-> SelectionSet RAW
-> FragmentValidator s ([UnionTag], Maybe (SelectionSet RAW))
exploreFragments Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragment OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
possibleTypes SelectionSet RAW
inputSelectionSet
  Maybe (MergeMap 'False FieldName (Selection VALID))
validSelectionSet <- (MergeMap 'True FieldName (Selection RAW)
 -> Validator
      VALID
      (OperationContext VALID s)
      (MergeMap 'False FieldName (Selection VALID)))
-> Maybe (MergeMap 'True FieldName (Selection RAW))
-> Validator
     VALID
     (OperationContext VALID s)
     (Maybe (MergeMap 'False FieldName (Selection VALID)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validate TypeDefinition IMPLEMENTABLE VALID
typeDef) Maybe (MergeMap 'True FieldName (Selection RAW))
selectionSet
  let tags :: OrdMap TypeName [SelectionSet VALID]
tags = [UnionTag]
-> OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
-> OrdMap TypeName [SelectionSet VALID]
tagUnionFragments [UnionTag]
spreads OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID)
possibleTypes
  Maybe (SelectionSet VALID)
-> OrdMap TypeName [SelectionSet VALID]
-> FragmentValidator s (SelectionContent VALID)
forall (s :: Stage).
Maybe (SelectionSet VALID)
-> OrdMap TypeName [SelectionSet VALID]
-> FragmentValidator s (SelectionContent VALID)
joinClusters Maybe (MergeMap 'False FieldName (Selection VALID))
Maybe (SelectionSet VALID)
validSelectionSet OrdMap TypeName [SelectionSet VALID]
tags