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

module Data.Morpheus.Validation.Query.Selection
  ( validateOperation,
    vaidateFragmentSelection,
  )
where

import Data.Morpheus.Error.Selection
  ( hasNoSubfields,
    subfieldsNotSelected,
  )
import Data.Morpheus.Ext.SemigroupM
  ( concatTraverse,
  )
import Data.Morpheus.Internal.Utils
  ( Failure (..),
    elems,
    empty,
    keyOf,
    singleton,
  )
import Data.Morpheus.Types.Internal.AST
  ( Arguments,
    DirectiveLocation (FIELD, FRAGMENT_SPREAD, INLINE_FRAGMENT, MUTATION, QUERY, SUBSCRIPTION),
    Directives,
    FieldDefinition (fieldType),
    FieldName,
    FieldsDefinition,
    Fragment (..),
    IMPLEMENTABLE,
    OUT,
    Operation (..),
    OperationType (..),
    RAW,
    Ref (..),
    Selection (..),
    SelectionContent (..),
    SelectionSet,
    TRUE,
    TypeContent (..),
    TypeDefinition (..),
    UnionTag (..),
    VALID,
    ValidationError (..),
    isEntNode,
    msgValidation,
    possibleTypes,
    toCategory,
    typed,
    withPosition,
  )
import Data.Morpheus.Types.Internal.Validation
  ( FragmentValidator,
    SelectionValidator,
    askSchema,
    askType,
    getOperationType,
    selectKnown,
    withScope,
  )
import Data.Morpheus.Validation.Internal.Arguments
  ( validateFieldArguments,
  )
import Data.Morpheus.Validation.Internal.Directive
  ( shouldIncludeSelection,
    validateDirectives,
  )
import Data.Morpheus.Validation.Query.Fragment
  ( ResolveFragment (..),
    resolveValidFragment,
    selectFragmentType,
    validateFragment,
  )
import Data.Morpheus.Validation.Query.UnionSelection
  ( validateInterfaceSelection,
    validateUnionSelection,
  )
import Relude hiding (empty)

selectionsWitoutTypename :: SelectionSet VALID -> [Selection VALID]
selectionsWitoutTypename :: SelectionSet VALID -> [Selection VALID]
selectionsWitoutTypename = (Selection VALID -> Bool) -> [Selection VALID] -> [Selection VALID]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FieldName
"__typename" FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
/=) (FieldName -> Bool)
-> (Selection VALID -> FieldName) -> Selection VALID -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Selection VALID -> FieldName
forall k a. KeyOf k a => a -> k
keyOf) ([Selection VALID] -> [Selection VALID])
-> (SelectionSet VALID -> [Selection VALID])
-> SelectionSet VALID
-> [Selection VALID]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SelectionSet VALID -> [Selection VALID]
forall a coll. Elems a coll => coll -> [a]
elems

singleTopLevelSelection :: Operation RAW -> SelectionSet VALID -> SelectionValidator ()
singleTopLevelSelection :: Operation RAW -> SelectionSet VALID -> SelectionValidator ()
singleTopLevelSelection Operation {operationType :: forall (s :: Stage). Operation s -> OperationType
operationType = OperationType
Subscription, Maybe FieldName
operationName :: forall (s :: Stage). Operation s -> Maybe FieldName
operationName :: Maybe FieldName
operationName} SelectionSet VALID
selSet =
  case SelectionSet VALID -> [Selection VALID]
selectionsWitoutTypename SelectionSet VALID
selSet of
    (Selection VALID
_ : [Selection VALID]
xs) | Bool -> Bool
not ([Selection VALID] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Selection VALID]
xs) -> [ValidationError] -> SelectionValidator ()
forall error (f :: * -> *) v. Failure error f => error -> f v
failure ([ValidationError] -> SelectionValidator ())
-> [ValidationError] -> SelectionValidator ()
forall a b. (a -> b) -> a -> b
$ (Selection VALID -> ValidationError)
-> [Selection VALID] -> [ValidationError]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe FieldName -> Selection VALID -> ValidationError
singleTopLevelSelectionError Maybe FieldName
operationName) [Selection VALID]
xs
    [Selection VALID]
_ -> () -> SelectionValidator ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
singleTopLevelSelection Operation RAW
_ SelectionSet VALID
_ = () -> SelectionValidator ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

singleTopLevelSelectionError :: Maybe FieldName -> Selection VALID -> ValidationError
singleTopLevelSelectionError :: Maybe FieldName -> Selection VALID -> ValidationError
singleTopLevelSelectionError Maybe FieldName
name Selection {Position
selectionPosition :: forall (s :: Stage). Selection s -> Position
selectionPosition :: Position
selectionPosition} =
  Maybe Position -> ValidationError -> ValidationError
withPosition (Position -> Maybe Position
forall a. a -> Maybe a
Just Position
selectionPosition) (ValidationError -> ValidationError)
-> ValidationError -> ValidationError
forall a b. (a -> b) -> a -> b
$
    ValidationError
subscriptionName
      ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
" must select "
      ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
"only one top level field."
  where
    subscriptionName :: ValidationError
subscriptionName = ValidationError
-> (FieldName -> ValidationError)
-> Maybe FieldName
-> ValidationError
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ValidationError
"Anonymous Subscription" ((ValidationError
"Subscription " ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<>) (ValidationError -> ValidationError)
-> (FieldName -> ValidationError) -> FieldName -> ValidationError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation) Maybe FieldName
name

validateOperation ::
  Operation RAW ->
  SelectionValidator (Operation VALID)
validateOperation :: Operation RAW -> SelectionValidator (Operation VALID)
validateOperation
  rawOperation :: Operation RAW
rawOperation@Operation
    { Maybe FieldName
operationName :: Maybe FieldName
operationName :: forall (s :: Stage). Operation s -> Maybe FieldName
operationName,
      OperationType
operationType :: OperationType
operationType :: forall (s :: Stage). Operation s -> OperationType
operationType,
      SelectionSet RAW
operationSelection :: forall (s :: Stage). Operation s -> SelectionSet s
operationSelection :: SelectionSet RAW
operationSelection,
      Directives RAW
operationDirectives :: forall (s :: Stage). Operation s -> Directives s
operationDirectives :: Directives RAW
operationDirectives,
      Position
VariableDefinitions RAW
operationArguments :: forall (s :: Stage). Operation s -> VariableDefinitions s
operationPosition :: forall (s :: Stage). Operation s -> Position
operationArguments :: VariableDefinitions RAW
operationPosition :: Position
..
    } =
    do
      TypeDefinition OBJECT VALID
typeDef <- Operation RAW -> SelectionValidator (TypeDefinition OBJECT VALID)
forall (a :: Stage).
Operation a -> SelectionValidator (TypeDefinition OBJECT VALID)
getOperationType Operation RAW
rawOperation
      SelectionSet VALID
selection <- TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator VALID (SelectionSet VALID)
forall (s :: Stage).
ResolveFragment s =>
TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validateSelectionSet (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 TypeDefinition OBJECT VALID
typeDef) SelectionSet RAW
operationSelection
      Operation RAW -> SelectionSet VALID -> SelectionValidator ()
singleTopLevelSelection Operation RAW
rawOperation SelectionSet VALID
selection
      Directives VALID
directives <-
        DirectiveLocation
-> Directives RAW
-> Validator
     VALID (OperationContext VALID VALID) (Directives VALID)
forall ctx (schemaS :: Stage) (s :: Stage).
ArgumentsConstraints ctx schemaS s =>
DirectiveLocation
-> Directives s -> Validator schemaS ctx (Directives VALID)
validateDirectives
          (OperationType -> DirectiveLocation
toDirectiveLocation OperationType
operationType)
          Directives RAW
operationDirectives
      Operation VALID -> SelectionValidator (Operation VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Operation VALID -> SelectionValidator (Operation VALID))
-> Operation VALID -> SelectionValidator (Operation VALID)
forall a b. (a -> b) -> a -> b
$
        Operation :: forall (s :: Stage).
Position
-> OperationType
-> Maybe FieldName
-> VariableDefinitions s
-> Directives s
-> SelectionSet s
-> Operation s
Operation
          { Maybe FieldName
operationName :: Maybe FieldName
operationName :: Maybe FieldName
operationName,
            OperationType
operationType :: OperationType
operationType :: OperationType
operationType,
            operationArguments :: VariableDefinitions VALID
operationArguments = VariableDefinitions VALID
forall a coll. Collection a coll => coll
empty,
            operationSelection :: SelectionSet VALID
operationSelection = SelectionSet VALID
selection,
            operationDirectives :: Directives VALID
operationDirectives = Directives VALID
directives,
            Position
operationPosition :: Position
operationPosition :: Position
..
          }

toDirectiveLocation :: OperationType -> DirectiveLocation
toDirectiveLocation :: OperationType -> DirectiveLocation
toDirectiveLocation OperationType
Subscription = DirectiveLocation
SUBSCRIPTION
toDirectiveLocation OperationType
Mutation = DirectiveLocation
MUTATION
toDirectiveLocation OperationType
Query = DirectiveLocation
QUERY

processSelectionDirectives ::
  DirectiveLocation ->
  Directives RAW ->
  (Directives VALID -> FragmentValidator s (SelectionSet VALID)) ->
  FragmentValidator s (SelectionSet VALID)
processSelectionDirectives :: DirectiveLocation
-> Directives RAW
-> (Directives VALID -> FragmentValidator s (SelectionSet VALID))
-> FragmentValidator s (SelectionSet VALID)
processSelectionDirectives DirectiveLocation
location Directives RAW
rawDirectives Directives VALID -> FragmentValidator s (SelectionSet VALID)
sel = do
  Directives VALID
directives <- 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 Directives RAW
rawDirectives
  Bool
include <- Directives VALID -> Validator VALID (OperationContext VALID s) Bool
forall (schemaS :: Stage) ctx.
Directives VALID -> Validator schemaS ctx Bool
shouldIncludeSelection Directives VALID
directives
  SelectionSet VALID
selection <- Directives VALID -> FragmentValidator s (SelectionSet VALID)
sel Directives VALID
directives
  SelectionSet VALID -> FragmentValidator s (SelectionSet VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SelectionSet VALID -> FragmentValidator s (SelectionSet VALID))
-> SelectionSet VALID -> FragmentValidator s (SelectionSet VALID)
forall a b. (a -> b) -> a -> b
$
    if Bool
include
      then SelectionSet VALID
selection
      else SelectionSet VALID
forall a coll. Collection a coll => coll
empty

vaidateFragmentSelection :: (ResolveFragment s) => Fragment RAW -> FragmentValidator s (SelectionSet VALID)
vaidateFragmentSelection :: Fragment RAW -> FragmentValidator s (SelectionSet VALID)
vaidateFragmentSelection f :: Fragment RAW
f@Fragment {SelectionSet RAW
fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection :: SelectionSet RAW
fragmentSelection} = do
  TypeDefinition IMPLEMENTABLE VALID
typeDef <- Fragment RAW
-> FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID)
forall (s :: Stage).
Fragment RAW
-> FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID)
selectFragmentType Fragment RAW
f
  TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
forall (s :: Stage).
ResolveFragment s =>
TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validateSelectionSet TypeDefinition IMPLEMENTABLE VALID
typeDef SelectionSet RAW
fragmentSelection

getFields :: TypeDefinition IMPLEMENTABLE s -> FieldsDefinition OUT s
getFields :: TypeDefinition IMPLEMENTABLE s -> FieldsDefinition OUT s
getFields TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataObject {FieldsDefinition OUT s
objectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectFields}} = FieldsDefinition OUT s
objectFields
getFields TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataInterface FieldsDefinition OUT s
fields} = FieldsDefinition OUT s
fields

validateSelectionSet ::
  forall s.
  ( ResolveFragment s
  ) =>
  TypeDefinition IMPLEMENTABLE VALID ->
  SelectionSet RAW ->
  FragmentValidator s (SelectionSet VALID)
validateSelectionSet :: TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validateSelectionSet TypeDefinition IMPLEMENTABLE VALID
typeDef =
  (Selection RAW -> FragmentValidator s (SelectionSet VALID))
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
forall (m :: * -> *) b cb a ca.
(Monad m, Failure [ValidationError] m, Collection b cb, Elems a ca,
 SemigroupM m cb) =>
(a -> m cb) -> ca -> m cb
concatTraverse Selection RAW -> FragmentValidator s (SelectionSet VALID)
validateSelection
  where
    -- validate single selection: InlineFragments and Spreads will Be resolved and included in SelectionSet
    validateSelection :: Selection RAW -> FragmentValidator s (SelectionSet VALID)
    validateSelection :: Selection RAW -> FragmentValidator s (SelectionSet VALID)
validateSelection
      sel :: Selection RAW
sel@Selection
        { FieldName
selectionName :: forall (s :: Stage). Selection s -> FieldName
selectionName :: FieldName
selectionName,
          Arguments RAW
selectionArguments :: forall (s :: Stage). Selection s -> Arguments s
selectionArguments :: Arguments RAW
selectionArguments,
          SelectionContent RAW
selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionContent :: SelectionContent RAW
selectionContent,
          Position
selectionPosition :: Position
selectionPosition :: forall (s :: Stage). Selection s -> Position
selectionPosition,
          Directives RAW
selectionDirectives :: forall (s :: Stage). Selection s -> Directives s
selectionDirectives :: Directives RAW
selectionDirectives
        } =
        TypeDefinition IMPLEMENTABLE VALID
-> Ref
-> FragmentValidator s (SelectionSet VALID)
-> FragmentValidator s (SelectionSet VALID)
forall (m :: * -> * -> *) (s :: Stage) c (cat :: TypeCategory) a.
MonadContext m s c =>
TypeDefinition cat s -> Ref -> m c a -> m c a
withScope
          TypeDefinition IMPLEMENTABLE VALID
typeDef
          Ref
currentSelectionRef
          (FragmentValidator s (SelectionSet VALID)
 -> FragmentValidator s (SelectionSet VALID))
-> FragmentValidator s (SelectionSet VALID)
-> FragmentValidator s (SelectionSet VALID)
forall a b. (a -> b) -> a -> b
$ DirectiveLocation
-> Directives RAW
-> (Directives VALID -> FragmentValidator s (SelectionSet VALID))
-> FragmentValidator s (SelectionSet VALID)
forall (s :: Stage).
DirectiveLocation
-> Directives RAW
-> (Directives VALID -> FragmentValidator s (SelectionSet VALID))
-> FragmentValidator s (SelectionSet VALID)
processSelectionDirectives
            DirectiveLocation
FIELD
            Directives RAW
selectionDirectives
            (Directives VALID
-> SelectionContent RAW -> FragmentValidator s (SelectionSet VALID)
`validateSelectionContent` SelectionContent RAW
selectionContent)
        where
          currentSelectionRef :: Ref
currentSelectionRef = FieldName -> Position -> Ref
Ref FieldName
selectionName Position
selectionPosition
          commonValidation :: FragmentValidator s (TypeDefinition OUT VALID, Arguments VALID)
          commonValidation :: FragmentValidator s (TypeDefinition OUT VALID, Arguments VALID)
commonValidation = do
            FieldDefinition OUT VALID
fieldDef <- Ref
-> FieldsDefinition OUT VALID
-> Validator
     VALID (OperationContext VALID s) (FieldDefinition OUT VALID)
forall k a c sel ctx (s :: Stage).
(Selectable k a c, Unknown c sel ctx, KeyOf k sel) =>
sel -> c -> Validator s ctx a
selectKnown (FieldName -> Position -> Ref
Ref FieldName
selectionName Position
selectionPosition) (TypeDefinition IMPLEMENTABLE VALID -> FieldsDefinition OUT VALID
forall (s :: Stage).
TypeDefinition IMPLEMENTABLE s -> FieldsDefinition OUT s
getFields TypeDefinition IMPLEMENTABLE VALID
typeDef)
            (,)
              (TypeDefinition OUT VALID
 -> Arguments VALID -> (TypeDefinition OUT VALID, Arguments VALID))
-> Validator
     VALID (OperationContext VALID s) (TypeDefinition OUT VALID)
-> Validator
     VALID
     (OperationContext VALID s)
     (Arguments VALID -> (TypeDefinition OUT VALID, Arguments VALID))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typed OUT VALID TypeRef
-> Validator
     VALID (OperationContext VALID s) (TypeDefinition OUT VALID)
forall (m :: * -> * -> *) c (cat :: TypeCategory) (s :: Stage).
Constraints m c cat s =>
Typed cat s TypeRef -> m c (TypeDefinition cat s)
askType ((FieldDefinition OUT VALID -> TypeRef)
-> FieldDefinition OUT VALID -> Typed OUT VALID TypeRef
forall (a :: TypeCategory -> Stage -> *) (c :: TypeCategory)
       (s :: Stage) b.
(a c s -> b) -> a c s -> Typed c s b
typed FieldDefinition OUT VALID -> TypeRef
forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType FieldDefinition OUT VALID
fieldDef)
              Validator
  VALID
  (OperationContext VALID s)
  (Arguments VALID -> (TypeDefinition OUT VALID, Arguments VALID))
-> Validator VALID (OperationContext VALID s) (Arguments VALID)
-> FragmentValidator s (TypeDefinition OUT VALID, Arguments VALID)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDefinition OUT VALID
-> Arguments RAW
-> Validator VALID (OperationContext VALID s) (Arguments VALID)
forall (s :: Stage).
FieldDefinition OUT VALID
-> Arguments RAW -> FragmentValidator s (Arguments VALID)
validateFieldArguments FieldDefinition OUT VALID
fieldDef Arguments RAW
selectionArguments
          -----------------------------------------------------------------------------------
          validateSelectionContent :: Directives VALID -> SelectionContent RAW -> FragmentValidator s (SelectionSet VALID)
          validateSelectionContent :: Directives VALID
-> SelectionContent RAW -> FragmentValidator s (SelectionSet VALID)
validateSelectionContent Directives VALID
directives SelectionContent RAW
SelectionField
            | Arguments RAW -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Arguments RAW
selectionArguments Bool -> Bool -> Bool
&& FieldName
selectionName FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
== FieldName
"__typename" =
              SelectionSet VALID -> FragmentValidator s (SelectionSet VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SelectionSet VALID -> FragmentValidator s (SelectionSet VALID))
-> SelectionSet VALID -> FragmentValidator s (SelectionSet VALID)
forall a b. (a -> b) -> a -> b
$ Selection VALID -> SelectionSet VALID
forall a coll. Collection a coll => a -> coll
singleton (Selection VALID -> SelectionSet VALID)
-> Selection VALID -> SelectionSet VALID
forall a b. (a -> b) -> a -> b
$
                Selection RAW
sel
                  { selectionArguments :: Arguments VALID
selectionArguments = Arguments VALID
forall a coll. Collection a coll => coll
empty,
                    selectionDirectives :: Directives VALID
selectionDirectives = Directives VALID
directives,
                    selectionContent :: SelectionContent VALID
selectionContent = SelectionContent VALID
forall (s :: Stage). SelectionContent s
SelectionField
                  }
            | Bool
otherwise = do
              (TypeDefinition OUT VALID
datatype, Arguments VALID
validArgs) <- FragmentValidator s (TypeDefinition OUT VALID, Arguments VALID)
commonValidation
              SelectionContent VALID
selContent <-
                Ref
-> TypeDefinition OUT VALID
-> FragmentValidator s (SelectionContent VALID)
forall (s' :: Stage) (s :: Stage).
Ref
-> TypeDefinition OUT VALID
-> FragmentValidator s' (SelectionContent s)
validateContentLeaf Ref
currentSelectionRef TypeDefinition OUT VALID
datatype
              SelectionSet VALID -> FragmentValidator s (SelectionSet VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SelectionSet VALID -> FragmentValidator s (SelectionSet VALID))
-> SelectionSet VALID -> FragmentValidator s (SelectionSet VALID)
forall a b. (a -> b) -> a -> b
$
                Selection VALID -> SelectionSet VALID
forall a coll. Collection a coll => a -> coll
singleton
                  ( Selection RAW
sel
                      { selectionArguments :: Arguments VALID
selectionArguments = Arguments VALID
validArgs,
                        selectionDirectives :: Directives VALID
selectionDirectives = Directives VALID
directives,
                        selectionContent :: SelectionContent VALID
selectionContent = SelectionContent VALID
selContent
                      }
                  )
          ----- SelectionSet
          validateSelectionContent Directives VALID
directives (SelectionSet SelectionSet RAW
rawSelectionSet) =
            do
              (TypeDefinition OUT VALID
tyDef, Arguments VALID
validArgs) <- FragmentValidator s (TypeDefinition OUT VALID, Arguments VALID)
commonValidation
              SelectionContent VALID
selContent <- TypeDefinition OUT VALID
-> Ref
-> SelectionSet RAW
-> FragmentValidator s (SelectionContent VALID)
forall (s :: Stage).
ResolveFragment s =>
TypeDefinition OUT VALID
-> Ref
-> SelectionSet RAW
-> FragmentValidator s (SelectionContent VALID)
validateByTypeContent TypeDefinition OUT VALID
tyDef Ref
currentSelectionRef SelectionSet RAW
rawSelectionSet
              SelectionSet VALID -> FragmentValidator s (SelectionSet VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SelectionSet VALID -> FragmentValidator s (SelectionSet VALID))
-> SelectionSet VALID -> FragmentValidator s (SelectionSet VALID)
forall a b. (a -> b) -> a -> b
$ Selection VALID -> SelectionSet VALID
forall a coll. Collection a coll => a -> coll
singleton (Selection VALID -> SelectionSet VALID)
-> Selection VALID -> SelectionSet VALID
forall a b. (a -> b) -> a -> b
$
                Selection RAW
sel
                  { selectionArguments :: Arguments VALID
selectionArguments = Arguments VALID
validArgs,
                    selectionDirectives :: Directives VALID
selectionDirectives = Directives VALID
directives,
                    selectionContent :: SelectionContent VALID
selectionContent = SelectionContent VALID
selContent
                  }
    validateSelection (Spread Directives RAW
dirs Ref
ref) = do
      [TypeName]
types <- TypeDefinition IMPLEMENTABLE VALID -> Schema VALID -> [TypeName]
forall (a :: TypeCategory) (s :: Stage) (s' :: Stage).
TypeDefinition a s -> Schema s' -> [TypeName]
possibleTypes TypeDefinition IMPLEMENTABLE VALID
typeDef (Schema VALID -> [TypeName])
-> Validator VALID (OperationContext VALID s) (Schema VALID)
-> Validator VALID (OperationContext VALID s) [TypeName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Validator VALID (OperationContext VALID s) (Schema VALID)
forall (m :: * -> * -> *) (s :: Stage) c.
MonadContext m s c =>
m c (Schema s)
askSchema
      DirectiveLocation
-> Directives RAW
-> (Directives VALID -> FragmentValidator s (SelectionSet VALID))
-> FragmentValidator s (SelectionSet VALID)
forall (s :: Stage).
DirectiveLocation
-> Directives RAW
-> (Directives VALID -> FragmentValidator s (SelectionSet VALID))
-> FragmentValidator s (SelectionSet VALID)
processSelectionDirectives
        DirectiveLocation
FRAGMENT_SPREAD
        Directives RAW
dirs
        (FragmentValidator s (SelectionSet VALID)
-> Directives VALID -> FragmentValidator s (SelectionSet VALID)
forall a b. a -> b -> a
const (FragmentValidator s (SelectionSet VALID)
 -> Directives VALID -> FragmentValidator s (SelectionSet VALID))
-> FragmentValidator s (SelectionSet VALID)
-> Directives VALID
-> FragmentValidator s (SelectionSet VALID)
forall a b. (a -> b) -> a -> b
$ UnionTag -> SelectionSet VALID
unionTagSelection (UnionTag -> SelectionSet VALID)
-> Validator VALID (OperationContext VALID s) UnionTag
-> FragmentValidator s (SelectionSet VALID)
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)
forall (s :: Stage).
ResolveFragment s =>
Fragment RAW -> FragmentValidator s (SelectionSet VALID)
vaidateFragmentSelection [TypeName]
types Ref
ref)
    validateSelection
      ( InlineFragment
          fragment :: Fragment RAW
fragment@Fragment
            { Directives RAW
fragmentDirectives :: forall (stage :: Stage). Fragment stage -> Directives stage
fragmentDirectives :: Directives RAW
fragmentDirectives
            }
        ) = do
        [TypeName]
types <- TypeDefinition IMPLEMENTABLE VALID -> Schema VALID -> [TypeName]
forall (a :: TypeCategory) (s :: Stage) (s' :: Stage).
TypeDefinition a s -> Schema s' -> [TypeName]
possibleTypes TypeDefinition IMPLEMENTABLE VALID
typeDef (Schema VALID -> [TypeName])
-> Validator VALID (OperationContext VALID s) (Schema VALID)
-> Validator VALID (OperationContext VALID s) [TypeName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Validator VALID (OperationContext VALID s) (Schema VALID)
forall (m :: * -> * -> *) (s :: Stage) c.
MonadContext m s c =>
m c (Schema s)
askSchema
        DirectiveLocation
-> Directives RAW
-> (Directives VALID -> FragmentValidator s (SelectionSet VALID))
-> FragmentValidator s (SelectionSet VALID)
forall (s :: Stage).
DirectiveLocation
-> Directives RAW
-> (Directives VALID -> FragmentValidator s (SelectionSet VALID))
-> FragmentValidator s (SelectionSet VALID)
processSelectionDirectives DirectiveLocation
INLINE_FRAGMENT Directives RAW
fragmentDirectives ((Directives VALID -> FragmentValidator s (SelectionSet VALID))
 -> FragmentValidator s (SelectionSet VALID))
-> (Directives VALID -> FragmentValidator s (SelectionSet VALID))
-> FragmentValidator s (SelectionSet VALID)
forall a b. (a -> b) -> a -> b
$
          FragmentValidator s (SelectionSet VALID)
-> Directives VALID -> FragmentValidator s (SelectionSet VALID)
forall a b. a -> b -> a
const ([TypeName]
-> Fragment RAW -> FragmentValidator s (SelectionSet VALID)
forall (s :: Stage).
ResolveFragment s =>
[TypeName]
-> Fragment RAW
-> Validator VALID (OperationContext VALID s) (SelectionSet VALID)
validate [TypeName]
types Fragment RAW
fragment)
    validate :: [TypeName]
-> Fragment RAW
-> Validator VALID (OperationContext VALID s) (SelectionSet VALID)
validate [TypeName]
types = (Fragment VALID -> SelectionSet VALID)
-> Validator VALID (OperationContext VALID s) (Fragment VALID)
-> Validator VALID (OperationContext VALID s) (SelectionSet VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Fragment VALID -> SelectionSet VALID
forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection (Validator VALID (OperationContext VALID s) (Fragment VALID)
 -> Validator VALID (OperationContext VALID s) (SelectionSet VALID))
-> (Fragment RAW
    -> Validator VALID (OperationContext VALID s) (Fragment VALID))
-> Fragment RAW
-> Validator VALID (OperationContext VALID s) (SelectionSet VALID)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fragment RAW
 -> Validator VALID (OperationContext VALID s) (SelectionSet VALID))
-> [TypeName]
-> Fragment RAW
-> Validator VALID (OperationContext VALID s) (Fragment VALID)
forall (s :: Stage).
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeName]
-> Fragment RAW
-> FragmentValidator s (Fragment VALID)
validateFragment Fragment RAW
-> Validator VALID (OperationContext VALID s) (SelectionSet VALID)
forall (s :: Stage).
ResolveFragment s =>
Fragment RAW -> FragmentValidator s (SelectionSet VALID)
vaidateFragmentSelection [TypeName]
types

validateContentLeaf ::
  Ref ->
  TypeDefinition OUT VALID ->
  FragmentValidator s' (SelectionContent s)
validateContentLeaf :: Ref
-> TypeDefinition OUT VALID
-> FragmentValidator s' (SelectionContent s)
validateContentLeaf
  (Ref FieldName
selectionName Position
selectionPosition)
  TypeDefinition {TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName :: TypeName
typeName, TypeContent TRUE OUT VALID
typeContent :: TypeContent TRUE OUT VALID
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent}
    | TypeContent TRUE OUT VALID -> Bool
forall (a :: TypeCategory) (s :: Stage).
TypeContent TRUE a s -> Bool
isEntNode TypeContent TRUE OUT VALID
typeContent = SelectionContent s -> FragmentValidator s' (SelectionContent s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure SelectionContent s
forall (s :: Stage). SelectionContent s
SelectionField
    | Bool
otherwise =
      ValidationError -> FragmentValidator s' (SelectionContent s)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (ValidationError -> FragmentValidator s' (SelectionContent s))
-> ValidationError -> FragmentValidator s' (SelectionContent s)
forall a b. (a -> b) -> a -> b
$ FieldName -> TypeName -> Position -> ValidationError
subfieldsNotSelected FieldName
selectionName TypeName
typeName Position
selectionPosition

validateByTypeContent ::
  forall s.
  (ResolveFragment s) =>
  TypeDefinition OUT VALID ->
  Ref ->
  SelectionSet RAW ->
  FragmentValidator s (SelectionContent VALID)
validateByTypeContent :: TypeDefinition OUT VALID
-> Ref
-> SelectionSet RAW
-> FragmentValidator s (SelectionContent VALID)
validateByTypeContent
  typeDef :: TypeDefinition OUT VALID
typeDef@TypeDefinition {TypeContent TRUE OUT VALID
typeContent :: TypeContent TRUE OUT VALID
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent, Directives VALID
Maybe Description
TypeName
typeDirectives :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Description
typeDirectives :: Directives VALID
typeName :: TypeName
typeDescription :: Maybe Description
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
..}
  Ref
currentSelectionRef =
    TypeDefinition OUT VALID
-> Ref
-> FragmentValidator s (SelectionContent VALID)
-> FragmentValidator s (SelectionContent VALID)
forall (m :: * -> * -> *) (s :: Stage) c (cat :: TypeCategory) a.
MonadContext m s c =>
TypeDefinition cat s -> Ref -> m c a -> m c a
withScope TypeDefinition OUT VALID
typeDef Ref
currentSelectionRef
      (FragmentValidator s (SelectionContent VALID)
 -> FragmentValidator s (SelectionContent VALID))
-> (SelectionSet RAW
    -> FragmentValidator s (SelectionContent VALID))
-> SelectionSet RAW
-> FragmentValidator s (SelectionContent VALID)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeContent TRUE OUT VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionContent VALID)
__validate TypeContent TRUE OUT VALID
typeContent
    where
      __validate ::
        TypeContent TRUE OUT VALID ->
        SelectionSet RAW ->
        FragmentValidator s (SelectionContent VALID)
      -- Validate UnionSelection
      __validate :: TypeContent TRUE OUT VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionContent VALID)
__validate DataUnion {DataUnion VALID
unionMembers :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OUT a) a s -> DataUnion s
unionMembers :: DataUnion VALID
unionMembers} =
        (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> (TypeDefinition IMPLEMENTABLE VALID
    -> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID))
-> DataUnion VALID
-> SelectionSet RAW
-> FragmentValidator s (SelectionContent VALID)
forall (s :: Stage).
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)
forall (s :: Stage).
ResolveFragment s =>
Fragment RAW -> FragmentValidator s (SelectionSet VALID)
vaidateFragmentSelection
          TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
forall (s :: Stage).
ResolveFragment s =>
TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validateSelectionSet
          DataUnion VALID
unionMembers
      -- Validate Regular selection set
      __validate DataObject {[TypeName]
FieldsDefinition OUT VALID
objectImplements :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> [TypeName]
objectFields :: FieldsDefinition OUT VALID
objectImplements :: [TypeName]
objectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> FieldsDefinition OUT s
..} =
        (SelectionSet VALID -> SelectionContent VALID)
-> FragmentValidator s (SelectionSet VALID)
-> FragmentValidator s (SelectionContent VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SelectionSet VALID -> SelectionContent VALID
forall (s :: Stage). SelectionSet s -> SelectionContent s
SelectionSet (FragmentValidator s (SelectionSet VALID)
 -> FragmentValidator s (SelectionContent VALID))
-> (SelectionSet RAW -> FragmentValidator s (SelectionSet VALID))
-> SelectionSet RAW
-> FragmentValidator s (SelectionContent VALID)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
forall (s :: Stage).
ResolveFragment s =>
TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validateSelectionSet (TypeDefinition :: forall (a :: TypeCategory) (s :: Stage).
Maybe Description
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition {typeContent :: TypeContent TRUE IMPLEMENTABLE VALID
typeContent = DataObject :: forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (ELEM OBJECT a) a s
DataObject {[TypeName]
FieldsDefinition OUT VALID
objectImplements :: [TypeName]
objectFields :: FieldsDefinition OUT VALID
objectImplements :: [TypeName]
objectFields :: FieldsDefinition OUT VALID
..}, Directives VALID
Maybe Description
TypeName
typeDirectives :: Directives VALID
typeDescription :: Maybe Description
typeDirectives :: Directives VALID
typeName :: TypeName
typeDescription :: Maybe Description
typeName :: TypeName
..})
      -- TODO: Union Like Validation
      __validate DataInterface {FieldsDefinition OUT VALID
interfaceFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM IMPLEMENTABLE a) a s -> FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT VALID
..} =
        (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> (TypeDefinition IMPLEMENTABLE VALID
    -> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID))
-> TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW
-> FragmentValidator s (SelectionContent VALID)
forall (s :: Stage).
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)
forall (s :: Stage).
ResolveFragment s =>
Fragment RAW -> FragmentValidator s (SelectionSet VALID)
vaidateFragmentSelection
          TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
forall (s :: Stage).
ResolveFragment s =>
TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validateSelectionSet
          (TypeDefinition :: forall (a :: TypeCategory) (s :: Stage).
Maybe Description
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition {typeContent :: TypeContent TRUE IMPLEMENTABLE VALID
typeContent = DataInterface :: forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition OUT s -> TypeContent (ELEM IMPLEMENTABLE a) a s
DataInterface {FieldsDefinition OUT VALID
interfaceFields :: FieldsDefinition OUT VALID
interfaceFields :: FieldsDefinition OUT VALID
..}, Directives VALID
Maybe Description
TypeName
typeDirectives :: Directives VALID
typeDescription :: Maybe Description
typeDirectives :: Directives VALID
typeName :: TypeName
typeDescription :: Maybe Description
typeName :: TypeName
..})
      __validate TypeContent TRUE OUT VALID
_ =
        FragmentValidator s (SelectionContent VALID)
-> SelectionSet RAW -> FragmentValidator s (SelectionContent VALID)
forall a b. a -> b -> a
const
          (FragmentValidator s (SelectionContent VALID)
 -> SelectionSet RAW
 -> FragmentValidator s (SelectionContent VALID))
-> FragmentValidator s (SelectionContent VALID)
-> SelectionSet RAW
-> FragmentValidator s (SelectionContent VALID)
forall a b. (a -> b) -> a -> b
$ ValidationError -> FragmentValidator s (SelectionContent VALID)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure
          (ValidationError -> FragmentValidator s (SelectionContent VALID))
-> ValidationError -> FragmentValidator s (SelectionContent VALID)
forall a b. (a -> b) -> a -> b
$ Ref -> TypeDefinition OUT VALID -> ValidationError
forall (s :: TypeCategory).
Ref -> TypeDefinition s VALID -> ValidationError
hasNoSubfields
            Ref
currentSelectionRef
            TypeDefinition OUT VALID
typeDef