{-# 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,
    validateFragmentSelection,
  )
where

import Control.Monad.Except (throwError)
import Data.Mergeable
  ( toNonEmpty,
  )
import Data.Morpheus.Error.Selection
  ( hasNoSubfields,
    subfieldsNotSelected,
  )
import Data.Morpheus.Ext.Empty (Empty (..))
import Data.Morpheus.Internal.Utils
  ( keyOf,
    mergeConcat,
    singleton,
    startHistory,
    throwErrors,
  )
import Data.Morpheus.Types.Internal.AST
  ( Arguments,
    DirectiveLocation (..),
    Directives,
    FieldDefinition (..),
    FieldName,
    FieldsDefinition,
    Fragment (..),
    FragmentName,
    GQLError,
    IMPLEMENTABLE,
    OUT,
    Operation (..),
    OperationType (..),
    RAW,
    Ref (..),
    Selection (..),
    SelectionContent (..),
    SelectionSet,
    TRUE,
    TypeContent (..),
    TypeDefinition (..),
    UnionTag (..),
    VALID,
    at,
    isLeaf,
    mkTypeRef,
    msg,
    possibleTypes,
    toCategory,
    typed,
  )
import Data.Morpheus.Types.Internal.Validation
  ( FragmentValidator,
    SelectionValidator,
    askType,
    getOperationType,
    schema,
    selectKnown,
    setSelection,
    withScope,
  )
import Data.Morpheus.Validation.Internal.Arguments
  ( validateFieldArguments,
  )
import Data.Morpheus.Validation.Internal.Directive
  ( shouldIncludeSelection,
    validateDirectives,
  )
import Data.Morpheus.Validation.Query.Fragment
  ( ValidateFragmentSelection,
    selectFragmentType,
    validateFragment,
    validateSpread,
  )
import Data.Morpheus.Validation.Query.UnionSelection
  ( validateInterfaceSelection,
    validateUnionSelection,
  )
import Relude hiding (empty, join)

selectionsWithoutTypename :: SelectionSet VALID -> [Selection VALID]
selectionsWithoutTypename :: SelectionSet VALID -> [Selection VALID]
selectionsWithoutTypename = forall a. (a -> Bool) -> [a] -> [a]
filter ((FieldName
"__typename" forall a. Eq a => a -> a -> Bool
/=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. KeyOf k a => a -> k
keyOf) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

singleTopLevelSelection :: Operation RAW -> SelectionSet VALID -> SelectionValidator ()
singleTopLevelSelection :: Operation RAW -> SelectionSet VALID -> SelectionValidator ()
singleTopLevelSelection Operation {operationType :: forall (s :: Stage). Operation s -> OperationType
operationType = OperationType
OPERATION_SUBSCRIPTION, Maybe FieldName
operationName :: forall (s :: Stage). Operation s -> Maybe FieldName
operationName :: Maybe FieldName
operationName} SelectionSet VALID
selSet =
  case SelectionSet VALID -> [Selection VALID]
selectionsWithoutTypename SelectionSet VALID
selSet of
    (Selection VALID
_ : (Selection VALID
x : [Selection VALID]
xs)) -> forall e (m :: * -> *) b. MonadError e m => NonEmpty e -> m b
throwErrors forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe FieldName -> Selection VALID -> GQLError
singleTopLevelSelectionError Maybe FieldName
operationName) (Selection VALID
x forall a. a -> [a] -> NonEmpty a
:| [Selection VALID]
xs)
    [Selection VALID]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
singleTopLevelSelection Operation RAW
_ SelectionSet VALID
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

singleTopLevelSelectionError :: Maybe FieldName -> Selection VALID -> GQLError
singleTopLevelSelectionError :: Maybe FieldName -> Selection VALID -> GQLError
singleTopLevelSelectionError Maybe FieldName
name Selection {Position
selectionPosition :: forall (s :: Stage). Selection s -> Position
selectionPosition :: Position
selectionPosition} =
  ( forall b a. b -> (a -> b) -> Maybe a -> b
maybe GQLError
"Anonymous Subscription" ((GQLError
"Subscription " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Msg a => a -> GQLError
msg) Maybe FieldName
name
      forall a. Semigroup a => a -> a -> a
<> GQLError
" must select "
      forall a. Semigroup a => a -> a -> a
<> GQLError
"only one top level field."
  )
    GQLError -> Position -> GQLError
`at` Position
selectionPosition

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,
      VariableDefinitions RAW
Position
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 <- forall (a :: Stage).
Operation a -> SelectionValidator (TypeDefinition OBJECT VALID)
getOperationType Operation RAW
rawOperation
      MergeMap 'False FieldName (Selection VALID)
selection <- forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validateSelectionSet (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 MergeMap 'False FieldName (Selection VALID)
selection
      Directives VALID
directives <-
        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
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        Operation
          { Maybe FieldName
operationName :: Maybe FieldName
operationName :: Maybe FieldName
operationName,
            OperationType
operationType :: OperationType
operationType :: OperationType
operationType,
            operationArguments :: VariableDefinitions VALID
operationArguments = forall coll. Empty coll => coll
empty,
            operationSelection :: SelectionSet VALID
operationSelection = MergeMap 'False FieldName (Selection VALID)
selection,
            operationDirectives :: Directives VALID
operationDirectives = Directives VALID
directives,
            Position
operationPosition :: Position
operationPosition :: Position
..
          }

toDirectiveLocation :: OperationType -> DirectiveLocation
toDirectiveLocation :: OperationType -> DirectiveLocation
toDirectiveLocation OperationType
OPERATION_SUBSCRIPTION = DirectiveLocation
LOCATION_SUBSCRIPTION
toDirectiveLocation OperationType
OPERATION_MUTATION = DirectiveLocation
LOCATION_MUTATION
toDirectiveLocation OperationType
OPERATION_QUERY = DirectiveLocation
LOCATION_QUERY

processSelectionDirectives ::
  DirectiveLocation ->
  Directives RAW ->
  (Directives VALID -> FragmentValidator s (SelectionSet VALID)) ->
  FragmentValidator s (Maybe (SelectionSet VALID))
processSelectionDirectives :: forall (s :: Stage).
DirectiveLocation
-> Directives RAW
-> (Directives VALID -> FragmentValidator s (SelectionSet VALID))
-> FragmentValidator s (Maybe (SelectionSet VALID))
processSelectionDirectives DirectiveLocation
location Directives RAW
rawDirectives Directives VALID -> FragmentValidator s (SelectionSet VALID)
sel = do
  Directives VALID
directives <- 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 <- forall (schemaS :: Stage) ctx.
Directives VALID -> Validator schemaS ctx Bool
shouldIncludeSelection Directives VALID
directives
  MergeMap 'False FieldName (Selection VALID)
selection <- Directives VALID -> FragmentValidator s (SelectionSet VALID)
sel Directives VALID
directives
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    if Bool
include
      then forall a. a -> Maybe a
Just MergeMap 'False FieldName (Selection VALID)
selection
      else forall a. Maybe a
Nothing

validateFragmentSelection :: (ValidateFragmentSelection s) => Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragmentSelection :: forall (s :: Stage).
ValidateFragmentSelection s =>
Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragmentSelection f :: Fragment RAW
f@Fragment {SelectionSet RAW
fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection :: SelectionSet RAW
fragmentSelection} = do
  TypeDefinition IMPLEMENTABLE VALID
typeDef <- forall (s :: Stage).
Fragment RAW
-> FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID)
selectFragmentType Fragment RAW
f
  forall (s :: Stage).
ValidateFragmentSelection 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 :: forall (s :: Stage).
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 (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT 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 ::
  (ValidateFragmentSelection s) =>
  TypeDefinition IMPLEMENTABLE VALID ->
  SelectionSet RAW ->
  FragmentValidator s (SelectionSet VALID)
validateSelectionSet :: forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validateSelectionSet TypeDefinition IMPLEMENTABLE VALID
typeDef =
  forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> Selection RAW
-> FragmentValidator s (Maybe (SelectionSet VALID))
validateSelection TypeDefinition IMPLEMENTABLE VALID
typeDef) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall e (f :: * -> *) a.
(IsString e, MonadError e f) =>
[a] -> f (NonEmpty a)
toNonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *) a. HistoryT m a -> m a
startHistory forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a e.
(Monad m, Merge m a, MonadError e m) =>
NonEmpty a -> m a
mergeConcat

-- validate single selection: InlineFragments and Spreads will Be resolved and included in SelectionSet
validateSelection :: ValidateFragmentSelection s => TypeDefinition IMPLEMENTABLE VALID -> Selection RAW -> FragmentValidator s (Maybe (SelectionSet VALID))
validateSelection :: forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> Selection RAW
-> FragmentValidator s (Maybe (SelectionSet VALID))
validateSelection TypeDefinition IMPLEMENTABLE VALID
typeDef Selection {Maybe FieldName
Maybe FragmentName
Directives RAW
Arguments RAW
Position
FieldName
SelectionContent RAW
selectionOrigin :: forall (s :: Stage). Selection s -> Maybe FragmentName
selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionDirectives :: forall (s :: Stage). Selection s -> Directives s
selectionArguments :: forall (s :: Stage). Selection s -> Arguments s
selectionName :: forall (s :: Stage). Selection s -> FieldName
selectionAlias :: forall (s :: Stage). Selection s -> Maybe FieldName
selectionOrigin :: Maybe FragmentName
selectionContent :: SelectionContent RAW
selectionDirectives :: Directives RAW
selectionArguments :: Arguments RAW
selectionName :: FieldName
selectionAlias :: Maybe FieldName
selectionPosition :: Position
selectionPosition :: forall (s :: Stage). Selection s -> Position
..} =
  forall (s :: Stage) c (m :: * -> *) b.
MonadReader (ValidatorContext s c) m =>
(Scope -> Scope) -> m b -> m b
withScope (forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Ref FieldName -> Scope -> Scope
setSelection TypeDefinition IMPLEMENTABLE VALID
typeDef Ref FieldName
selectionRef) forall a b. (a -> b) -> a -> b
$
    forall (s :: Stage).
DirectiveLocation
-> Directives RAW
-> (Directives VALID -> FragmentValidator s (SelectionSet VALID))
-> FragmentValidator s (Maybe (SelectionSet VALID))
processSelectionDirectives DirectiveLocation
LOCATION_FIELD Directives RAW
selectionDirectives Directives VALID
-> Validator
     VALID
     (OperationContext VALID s)
     (MergeMap 'False FieldName (Selection VALID))
validateContent
  where
    selectionRef :: Ref FieldName
selectionRef = forall name. name -> Position -> Ref name
Ref FieldName
selectionName Position
selectionPosition
    validateContent :: Directives VALID
-> Validator
     VALID
     (OperationContext VALID s)
     (MergeMap 'False FieldName (Selection VALID))
validateContent Directives VALID
directives = do
      (Arguments VALID
validArgs, SelectionContent VALID
content) <- forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> Ref FieldName
-> Arguments RAW
-> SelectionContent RAW
-> FragmentValidator s (Arguments VALID, SelectionContent VALID)
validateSelectionContent TypeDefinition IMPLEMENTABLE VALID
typeDef Ref FieldName
selectionRef Arguments RAW
selectionArguments SelectionContent RAW
selectionContent
      let selection :: Selection VALID
selection =
            Selection
              { selectionArguments :: Arguments VALID
selectionArguments = Arguments VALID
validArgs,
                selectionDirectives :: Directives VALID
selectionDirectives = Directives VALID
directives,
                selectionContent :: SelectionContent VALID
selectionContent = SelectionContent VALID
content,
                Maybe FieldName
Maybe FragmentName
Position
FieldName
selectionOrigin :: Maybe FragmentName
selectionName :: FieldName
selectionAlias :: Maybe FieldName
selectionOrigin :: Maybe FragmentName
selectionName :: FieldName
selectionAlias :: Maybe FieldName
selectionPosition :: Position
selectionPosition :: Position
..
              }
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k (m :: * -> *) a. IsMap k m => k -> a -> m a
singleton (forall k a. KeyOf k a => a -> k
keyOf Selection VALID
selection) Selection VALID
selection
validateSelection TypeDefinition IMPLEMENTABLE VALID
typeDef (Spread Directives RAW
dirs Ref FragmentName
ref) =
  forall (s :: Stage).
DirectiveLocation
-> Directives RAW
-> (Directives VALID -> FragmentValidator s (SelectionSet VALID))
-> FragmentValidator s (Maybe (SelectionSet VALID))
processSelectionDirectives DirectiveLocation
LOCATION_FRAGMENT_SPREAD Directives RAW
dirs forall a b. (a -> b) -> a -> b
$
    forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
      forall (s :: Stage) (a :: TypeCategory).
ValidateFragmentSelection s =>
TypeDefinition a VALID
-> Ref FragmentName -> FragmentValidator s (SelectionSet VALID)
validateSpreadSelection TypeDefinition IMPLEMENTABLE VALID
typeDef Ref FragmentName
ref
validateSelection TypeDefinition IMPLEMENTABLE VALID
typeDef (InlineFragment fragment :: Fragment RAW
fragment@Fragment {Directives RAW
fragmentDirectives :: forall (stage :: Stage). Fragment stage -> Directives stage
fragmentDirectives :: Directives RAW
fragmentDirectives}) =
  forall (s :: Stage).
DirectiveLocation
-> Directives RAW
-> (Directives VALID -> FragmentValidator s (SelectionSet VALID))
-> FragmentValidator s (Maybe (SelectionSet VALID))
processSelectionDirectives DirectiveLocation
LOCATION_INLINE_FRAGMENT Directives RAW
fragmentDirectives forall a b. (a -> b) -> a -> b
$
    forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
      forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateInlineFragmentSelection TypeDefinition IMPLEMENTABLE VALID
typeDef Fragment RAW
fragment

validateSpreadSelection ::
  ValidateFragmentSelection s =>
  TypeDefinition a VALID ->
  Ref FragmentName ->
  FragmentValidator s (SelectionSet VALID)
validateSpreadSelection :: forall (s :: Stage) (a :: TypeCategory).
ValidateFragmentSelection s =>
TypeDefinition a VALID
-> Ref FragmentName -> FragmentValidator s (SelectionSet VALID)
validateSpreadSelection TypeDefinition a VALID
typeDef Ref FragmentName
ref = do
  [TypeName]
types <- forall (a :: TypeCategory) (s :: Stage) (s' :: Stage).
TypeDefinition a s -> Schema s' -> [TypeName]
possibleTypes TypeDefinition a VALID
typeDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
schema
  UnionTag -> SelectionSet VALID
unionTagSelection forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (s :: Stage).
ValidateFragmentSelection s =>
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeName] -> Ref FragmentName -> FragmentValidator s UnionTag
validateSpread forall (s :: Stage).
ValidateFragmentSelection s =>
Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragmentSelection [TypeName]
types Ref FragmentName
ref

validateInlineFragmentSelection ::
  ValidateFragmentSelection s =>
  TypeDefinition IMPLEMENTABLE VALID ->
  Fragment RAW ->
  FragmentValidator s (SelectionSet VALID)
validateInlineFragmentSelection :: forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateInlineFragmentSelection TypeDefinition IMPLEMENTABLE VALID
typeDef Fragment RAW
x = do
  [TypeName]
types <- forall (a :: TypeCategory) (s :: Stage) (s' :: Stage).
TypeDefinition a s -> Schema s' -> [TypeName]
possibleTypes TypeDefinition IMPLEMENTABLE VALID
typeDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
schema
  forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (s :: Stage).
DirectiveLocation
-> (Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeName]
-> Fragment RAW
-> FragmentValidator s (Fragment VALID)
validateFragment DirectiveLocation
LOCATION_INLINE_FRAGMENT forall (s :: Stage).
ValidateFragmentSelection s =>
Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragmentSelection [TypeName]
types Fragment RAW
x

selectSelectionField ::
  Ref FieldName ->
  TypeDefinition IMPLEMENTABLE s ->
  FragmentValidator s' (FieldDefinition OUT s)
selectSelectionField :: forall (s :: Stage) (s' :: Stage).
Ref FieldName
-> TypeDefinition IMPLEMENTABLE s
-> FragmentValidator s' (FieldDefinition OUT s)
selectSelectionField Ref FieldName
ref TypeDefinition IMPLEMENTABLE s
typeDef
  | forall name. Ref name -> name
refName Ref FieldName
ref forall a. Eq a => a -> a -> Bool
== FieldName
"__typename" =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure
        FieldDefinition
          { fieldDescription :: Maybe Description
fieldDescription = forall a. Maybe a
Nothing,
            fieldName :: FieldName
fieldName = FieldName
"__typename",
            fieldType :: TypeRef
fieldType = TypeName -> TypeRef
mkTypeRef TypeName
"String",
            fieldContent :: Maybe (FieldContent TRUE OUT s)
fieldContent = forall a. Maybe a
Nothing,
            fieldDirectives :: Directives s
fieldDirectives = forall coll. Empty coll => coll
empty
          }
  | Bool
otherwise = forall k (c :: * -> *) sel ctx a (s :: Stage).
(IsMap k c, Unknown sel ctx, KeyOf k sel) =>
sel -> c a -> Validator s ctx a
selectKnown Ref FieldName
ref (forall (s :: Stage).
TypeDefinition IMPLEMENTABLE s -> FieldsDefinition OUT s
getFields TypeDefinition IMPLEMENTABLE s
typeDef)

validateSelectionContent ::
  forall s.
  ValidateFragmentSelection s =>
  TypeDefinition IMPLEMENTABLE VALID ->
  Ref FieldName ->
  Arguments RAW ->
  SelectionContent RAW ->
  FragmentValidator s (Arguments VALID, SelectionContent VALID)
validateSelectionContent :: forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> Ref FieldName
-> Arguments RAW
-> SelectionContent RAW
-> FragmentValidator s (Arguments VALID, SelectionContent VALID)
validateSelectionContent TypeDefinition IMPLEMENTABLE VALID
typeDef Ref FieldName
ref Arguments RAW
selectionArguments SelectionContent RAW
content = do
  FieldDefinition OUT VALID
fieldDef <- forall (s :: Stage) (s' :: Stage).
Ref FieldName
-> TypeDefinition IMPLEMENTABLE s
-> FragmentValidator s' (FieldDefinition OUT s)
selectSelectionField Ref FieldName
ref TypeDefinition IMPLEMENTABLE VALID
typeDef
  TypeDefinition OUT VALID
fieldTypeDef <- forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx.
Constraints m c cat s ctx =>
Typed cat s TypeRef -> m (TypeDefinition cat s)
askType (forall (a :: TypeCategory -> Stage -> *) (c :: TypeCategory)
       (s :: Stage) b.
(a c s -> b) -> a c s -> Typed c s b
typed forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType FieldDefinition OUT VALID
fieldDef)
  Arguments VALID
validArgs <- forall (s :: Stage).
FieldDefinition OUT VALID
-> Arguments RAW -> FragmentValidator s (Arguments VALID)
validateFieldArguments FieldDefinition OUT VALID
fieldDef Arguments RAW
selectionArguments
  SelectionContent VALID
validContent <- TypeDefinition OUT VALID
-> SelectionContent RAW
-> FragmentValidator s (SelectionContent VALID)
validateContent TypeDefinition OUT VALID
fieldTypeDef SelectionContent RAW
content
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Arguments VALID
validArgs, SelectionContent VALID
validContent)
  where
    validateContent :: TypeDefinition OUT VALID
-> SelectionContent RAW
-> FragmentValidator s (SelectionContent VALID)
validateContent TypeDefinition OUT VALID
fieldTypeDef SelectionContent RAW
SelectionField = forall (s' :: Stage) (s :: Stage).
Ref FieldName
-> TypeDefinition OUT VALID
-> FragmentValidator s' (SelectionContent s)
validateContentLeaf Ref FieldName
ref TypeDefinition OUT VALID
fieldTypeDef
    validateContent TypeDefinition OUT VALID
fieldTypeDef (SelectionSet SelectionSet RAW
rawSelectionSet) = forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition OUT VALID
-> Ref FieldName
-> SelectionSet RAW
-> FragmentValidator s (SelectionContent VALID)
validateByTypeContent TypeDefinition OUT VALID
fieldTypeDef Ref FieldName
ref SelectionSet RAW
rawSelectionSet

validateContentLeaf ::
  Ref FieldName ->
  TypeDefinition OUT VALID ->
  FragmentValidator s' (SelectionContent s)
validateContentLeaf :: forall (s' :: Stage) (s :: Stage).
Ref FieldName
-> 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}
    | forall (a :: TypeCategory) (s :: Stage).
TypeContent TRUE a s -> Bool
isLeaf TypeContent TRUE OUT VALID
typeContent = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (s :: Stage). SelectionContent s
SelectionField
    | Bool
otherwise =
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ FieldName -> TypeName -> Position -> GQLError
subfieldsNotSelected FieldName
selectionName TypeName
typeName Position
selectionPosition

validateByTypeContent ::
  forall s.
  (ValidateFragmentSelection s) =>
  TypeDefinition OUT VALID ->
  Ref FieldName ->
  SelectionSet RAW ->
  FragmentValidator s (SelectionContent VALID)
validateByTypeContent :: forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition OUT VALID
-> Ref FieldName
-> 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, Maybe Description
Directives VALID
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 FieldName
currentSelectionRef =
    forall (s :: Stage) c (m :: * -> *) b.
MonadReader (ValidatorContext s c) m =>
(Scope -> Scope) -> m b -> m b
withScope (forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Ref FieldName -> Scope -> Scope
setSelection TypeDefinition OUT VALID
typeDef Ref FieldName
currentSelectionRef)
      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 {UnionTypeDefinition OUT VALID
unionMembers :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OUT a s -> UnionTypeDefinition OUT s
unionMembers :: UnionTypeDefinition OUT VALID
unionMembers} =
        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
          forall (s :: Stage).
ValidateFragmentSelection s =>
Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragmentSelection
          forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validateSelectionSet
          UnionTypeDefinition OUT VALID
unionMembers
      -- Validate Regular selection set
      __validate DataObject {[TypeName]
FieldsDefinition OUT VALID
objectImplements :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> [TypeName]
objectFields :: FieldsDefinition OUT VALID
objectImplements :: [TypeName]
objectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
..} =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (s :: Stage). SelectionSet s -> SelectionContent s
SelectionSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validateSelectionSet (TypeDefinition {typeContent :: TypeContent TRUE IMPLEMENTABLE VALID
typeContent = DataObject {[TypeName]
FieldsDefinition OUT VALID
objectImplements :: [TypeName]
objectFields :: FieldsDefinition OUT VALID
objectImplements :: [TypeName]
objectFields :: FieldsDefinition OUT VALID
..}, Maybe Description
Directives VALID
TypeName
typeDirectives :: Directives VALID
typeDescription :: Maybe Description
typeDirectives :: Directives VALID
typeName :: TypeName
typeDescription :: Maybe Description
typeName :: TypeName
..})
      __validate DataInterface {FieldsDefinition OUT VALID
interfaceFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent IMPLEMENTABLE a s -> FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT VALID
..} =
        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
          forall (s :: Stage).
ValidateFragmentSelection s =>
Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragmentSelection
          forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validateSelectionSet
          (TypeDefinition {typeContent :: TypeContent TRUE IMPLEMENTABLE VALID
typeContent = DataInterface {FieldsDefinition OUT VALID
interfaceFields :: FieldsDefinition OUT VALID
interfaceFields :: FieldsDefinition OUT VALID
..}, Maybe Description
Directives VALID
TypeName
typeDirectives :: Directives VALID
typeDescription :: Maybe Description
typeDirectives :: Directives VALID
typeName :: TypeName
typeDescription :: Maybe Description
typeName :: TypeName
..})
      __validate TypeContent TRUE OUT VALID
_ =
        forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
          forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
            forall (s :: TypeCategory).
Ref FieldName -> TypeDefinition s VALID -> GQLError
hasNoSubfields
              Ref FieldName
currentSelectionRef
              TypeDefinition OUT VALID
typeDef