{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Types.Internal.Validation.Error
( MissingRequired (..),
KindViolation (..),
Unknown (..),
Target (..),
Unused (..),
)
where
import Data.Morpheus.Error.Selection (unknownSelectionField)
import Data.Morpheus.Types.Internal.AST
( Argument (..),
Arguments,
CONST,
Directive (..),
DirectiveDefinition (..),
DirectiveDefinitions,
FieldDefinition (..),
FieldsDefinition,
Fragment (..),
Fragments,
IN,
OUT,
Object,
ObjectEntry (..),
Ref (..),
Schema,
TypeNameRef (..),
TypeRef (..),
ValidationError (..),
Variable (..),
VariableDefinitions,
getOperationName,
msg,
msgValidation,
withPosition,
)
import Data.Morpheus.Types.Internal.Validation.Validator
( CurrentSelection (..),
InputContext (..),
OperationContext (..),
Scope (..),
ScopeKind (..),
Target (..),
renderInputPrefix,
)
import Relude
class Unused ctx c where
unused :: ctx -> c -> ValidationError
instance Unused (OperationContext s1 s2) (Variable s) where
unused :: OperationContext s1 s2 -> Variable s -> ValidationError
unused
OperationContext {selection :: forall (s1 :: Stage) (s2 :: Stage).
OperationContext s1 s2 -> CurrentSelection
selection = CurrentSelection {Maybe FieldName
operationName :: CurrentSelection -> Maybe FieldName
operationName :: Maybe FieldName
operationName}}
Variable {FieldName
variableName :: forall (stage :: Stage). Variable stage -> FieldName
variableName :: FieldName
variableName, Position
variablePosition :: forall (stage :: Stage). Variable stage -> Position
variablePosition :: Position
variablePosition} =
ValidationError :: Message -> [Position] -> ValidationError
ValidationError
{ validationMessage :: Message
validationMessage =
Message
"Variable " Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> FieldName -> Message
forall a. Msg a => a -> Message
msg (FieldName
"$" FieldName -> FieldName -> FieldName
forall a. Semigroup a => a -> a -> a
<> FieldName
variableName)
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
" is never used in operation "
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> TypeName -> Message
forall a. Msg a => a -> Message
msg (Maybe FieldName -> TypeName
getOperationName Maybe FieldName
operationName)
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
".",
validationLocations :: [Position]
validationLocations = [Position
variablePosition]
}
instance Unused (OperationContext s1 s2) (Fragment s) where
unused :: OperationContext s1 s2 -> Fragment s -> ValidationError
unused
OperationContext s1 s2
_
Fragment {FieldName
fragmentName :: forall (stage :: Stage). Fragment stage -> FieldName
fragmentName :: FieldName
fragmentName, Position
fragmentPosition :: forall (stage :: Stage). Fragment stage -> Position
fragmentPosition :: Position
fragmentPosition} =
ValidationError :: Message -> [Position] -> ValidationError
ValidationError
{ validationMessage :: Message
validationMessage =
Message
"Fragment " Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> FieldName -> Message
forall a. Msg a => a -> Message
msg FieldName
fragmentName
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
" is never used.",
validationLocations :: [Position]
validationLocations = [Position
fragmentPosition]
}
class MissingRequired c ctx where
missingRequired :: Scope -> ctx -> Ref -> c -> ValidationError
instance MissingRequired (Arguments s) ctx where
missingRequired :: Scope -> ctx -> Ref -> Arguments s -> ValidationError
missingRequired
Scope {Maybe Position
position :: Scope -> Maybe Position
position :: Maybe Position
position, ScopeKind
kind :: Scope -> ScopeKind
kind :: ScopeKind
kind, FieldName
fieldname :: Scope -> FieldName
fieldname :: FieldName
fieldname}
ctx
_
Ref {FieldName
refName :: Ref -> FieldName
refName :: FieldName
refName}
Arguments s
_ =
ValidationError :: Message -> [Position] -> ValidationError
ValidationError
{ validationMessage :: Message
validationMessage =
ScopeKind -> Message
inScope ScopeKind
kind
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
" argument "
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> FieldName -> Message
forall a. Msg a => a -> Message
msg FieldName
refName
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
" is required but not provided.",
validationLocations :: [Position]
validationLocations = Maybe Position -> [Position]
forall a. Maybe a -> [a]
maybeToList Maybe Position
position
}
where
inScope :: ScopeKind -> Message
inScope ScopeKind
DIRECTIVE = Message
"Directive " Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> FieldName -> Message
forall a. Msg a => a -> Message
msg (FieldName
"@" FieldName -> FieldName -> FieldName
forall a. Semigroup a => a -> a -> a
<> FieldName
fieldname)
inScope ScopeKind
_ = Message
"Field " Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> FieldName -> Message
forall a. Msg a => a -> Message
msg FieldName
fieldname
instance MissingRequired (Object s) (InputContext ctx) where
missingRequired :: Scope -> InputContext ctx -> Ref -> Object s -> ValidationError
missingRequired
Scope {Maybe Position
position :: Maybe Position
position :: Scope -> Maybe Position
position}
InputContext ctx
ctx
Ref {FieldName
refName :: FieldName
refName :: Ref -> FieldName
refName}
Object s
_ =
Maybe Position -> ValidationError -> ValidationError
withPosition
Maybe Position
position
( InputContext ctx -> ValidationError
forall c. InputContext c -> ValidationError
renderInputPrefix
InputContext ctx
ctx
ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
"Undefined Field "
ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> FieldName -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation FieldName
refName
ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
"."
)
instance MissingRequired (VariableDefinitions s) (OperationContext s1 s2) where
missingRequired :: Scope
-> OperationContext s1 s2
-> Ref
-> VariableDefinitions s
-> ValidationError
missingRequired
Scope
_
OperationContext
{ selection :: forall (s1 :: Stage) (s2 :: Stage).
OperationContext s1 s2 -> CurrentSelection
selection = CurrentSelection {Maybe FieldName
operationName :: Maybe FieldName
operationName :: CurrentSelection -> Maybe FieldName
operationName}
}
Ref {FieldName
refName :: FieldName
refName :: Ref -> FieldName
refName, Position
refPosition :: Ref -> Position
refPosition :: Position
refPosition}
VariableDefinitions s
_ =
ValidationError :: Message -> [Position] -> ValidationError
ValidationError
{ validationMessage :: Message
validationMessage =
Message
"Variable "
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> FieldName -> Message
forall a. Msg a => a -> Message
msg FieldName
refName
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
" is not defined by operation "
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> TypeName -> Message
forall a. Msg a => a -> Message
msg (Maybe FieldName -> TypeName
getOperationName Maybe FieldName
operationName)
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
".",
validationLocations :: [Position]
validationLocations = [Position
refPosition]
}
class Unknown c ref ctx where
unknown :: Scope -> ctx -> c -> ref -> ValidationError
instance Unknown (Fragments s) Ref ctx where
unknown :: Scope -> ctx -> Fragments s -> Ref -> ValidationError
unknown Scope
_ ctx
_ Fragments s
_ (Ref FieldName
name Position
pos) =
ValidationError :: Message -> [Position] -> ValidationError
ValidationError
{ validationMessage :: Message
validationMessage = Message
"Unknown Fragment " Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> FieldName -> Message
forall a. Msg a => a -> Message
msg FieldName
name Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
".",
validationLocations :: [Position]
validationLocations = [Position
pos]
}
instance Unknown (Schema s) TypeNameRef ctx where
unknown :: Scope -> ctx -> Schema s -> TypeNameRef -> ValidationError
unknown Scope
_ ctx
_ Schema s
_ TypeNameRef {TypeName
typeNameRef :: TypeNameRef -> TypeName
typeNameRef :: TypeName
typeNameRef, Position
typeNamePosition :: TypeNameRef -> Position
typeNamePosition :: Position
typeNamePosition} =
ValidationError :: Message -> [Position] -> ValidationError
ValidationError
{ validationMessage :: Message
validationMessage = Message
"Unknown type " Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> TypeName -> Message
forall a. Msg a => a -> Message
msg TypeName
typeNameRef Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
".",
validationLocations :: [Position]
validationLocations = [Position
typeNamePosition]
}
instance Unknown (FieldDefinition OUT s) (Argument CONST) ctx where
unknown :: Scope
-> ctx
-> FieldDefinition OUT s
-> Argument CONST
-> ValidationError
unknown Scope
_ ctx
_ FieldDefinition {FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName} Argument {FieldName
argumentName :: forall (valid :: Stage). Argument valid -> FieldName
argumentName :: FieldName
argumentName, Position
argumentPosition :: forall (valid :: Stage). Argument valid -> Position
argumentPosition :: Position
argumentPosition} =
ValidationError :: Message -> [Position] -> ValidationError
ValidationError
{ validationMessage :: Message
validationMessage = Message
"Unknown Argument " Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> FieldName -> Message
forall a. Msg a => a -> Message
msg FieldName
argumentName Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
" on Field " Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> FieldName -> Message
forall a. Msg a => a -> Message
msg FieldName
fieldName Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
".",
validationLocations :: [Position]
validationLocations = [Position
argumentPosition]
}
instance Unknown (FieldsDefinition IN s) (ObjectEntry valueS) (InputContext ctx) where
unknown :: Scope
-> InputContext ctx
-> FieldsDefinition IN s
-> ObjectEntry valueS
-> ValidationError
unknown
Scope {Maybe Position
position :: Maybe Position
position :: Scope -> Maybe Position
position}
InputContext ctx
ctx
FieldsDefinition IN s
_
ObjectEntry {FieldName
entryName :: forall (s :: Stage). ObjectEntry s -> FieldName
entryName :: FieldName
entryName} =
Maybe Position -> ValidationError -> ValidationError
withPosition Maybe Position
position (ValidationError -> ValidationError)
-> ValidationError -> ValidationError
forall a b. (a -> b) -> a -> b
$
InputContext ctx -> ValidationError
forall c. InputContext c -> ValidationError
renderInputPrefix InputContext ctx
ctx ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
"Unknown Field " ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> FieldName -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation FieldName
entryName ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
"."
instance Unknown (DirectiveDefinition s) (Argument s') ctx where
unknown :: Scope
-> ctx -> DirectiveDefinition s -> Argument s' -> ValidationError
unknown Scope
_ ctx
_ DirectiveDefinition {FieldName
directiveDefinitionName :: forall (s :: Stage). DirectiveDefinition s -> FieldName
directiveDefinitionName :: FieldName
directiveDefinitionName} Argument {FieldName
argumentName :: FieldName
argumentName :: forall (valid :: Stage). Argument valid -> FieldName
argumentName, Position
argumentPosition :: Position
argumentPosition :: forall (valid :: Stage). Argument valid -> Position
argumentPosition} =
ValidationError :: Message -> [Position] -> ValidationError
ValidationError
{ validationMessage :: Message
validationMessage = Message
"Unknown Argument " Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> FieldName -> Message
forall a. Msg a => a -> Message
msg FieldName
argumentName Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
" on Directive " Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> FieldName -> Message
forall a. Msg a => a -> Message
msg FieldName
directiveDefinitionName Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
".",
validationLocations :: [Position]
validationLocations = [Position
argumentPosition]
}
instance Unknown (DirectiveDefinitions s) (Directive s') ctx where
unknown :: Scope
-> ctx -> DirectiveDefinitions s -> Directive s' -> ValidationError
unknown Scope
_ ctx
_ DirectiveDefinitions s
_ Directive {FieldName
directiveName :: forall (s :: Stage). Directive s -> FieldName
directiveName :: FieldName
directiveName, Position
directivePosition :: forall (s :: Stage). Directive s -> Position
directivePosition :: Position
directivePosition} =
ValidationError :: Message -> [Position] -> ValidationError
ValidationError
{ validationMessage :: Message
validationMessage = Message
"Unknown Directive " Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> FieldName -> Message
forall a. Msg a => a -> Message
msg FieldName
directiveName Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
".",
validationLocations :: [Position]
validationLocations = [Position
directivePosition]
}
instance Unknown (FieldsDefinition OUT s) Ref (OperationContext s1 s2) where
unknown :: Scope
-> OperationContext s1 s2
-> FieldsDefinition OUT s
-> Ref
-> ValidationError
unknown Scope {TypeName
currentTypeName :: Scope -> TypeName
currentTypeName :: TypeName
currentTypeName} OperationContext s1 s2
_ FieldsDefinition OUT s
_ = TypeName -> Ref -> ValidationError
unknownSelectionField TypeName
currentTypeName
class KindViolation (t :: Target) ctx where
kindViolation :: c t -> ctx -> ValidationError
instance KindViolation 'TARGET_IMPLEMENTABLE (Fragment s) where
kindViolation :: c 'TARGET_IMPLEMENTABLE -> Fragment s -> ValidationError
kindViolation c 'TARGET_IMPLEMENTABLE
_ Fragment {FieldName
fragmentName :: FieldName
fragmentName :: forall (stage :: Stage). Fragment stage -> FieldName
fragmentName, TypeName
fragmentType :: forall (stage :: Stage). Fragment stage -> TypeName
fragmentType :: TypeName
fragmentType, Position
fragmentPosition :: Position
fragmentPosition :: forall (stage :: Stage). Fragment stage -> Position
fragmentPosition} =
ValidationError :: Message -> [Position] -> ValidationError
ValidationError
{ validationMessage :: Message
validationMessage =
Message
"Fragment "
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> FieldName -> Message
forall a. Msg a => a -> Message
msg FieldName
fragmentName
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
" cannot condition on non composite type "
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> TypeName -> Message
forall a. Msg a => a -> Message
msg TypeName
fragmentType
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
".",
validationLocations :: [Position]
validationLocations = [Position
fragmentPosition]
}
instance KindViolation 'TARGET_INPUT (Variable s) where
kindViolation :: c 'TARGET_INPUT -> Variable s -> ValidationError
kindViolation
c 'TARGET_INPUT
_
Variable
{ FieldName
variableName :: FieldName
variableName :: forall (stage :: Stage). Variable stage -> FieldName
variableName,
Position
variablePosition :: Position
variablePosition :: forall (stage :: Stage). Variable stage -> Position
variablePosition,
variableType :: forall (stage :: Stage). Variable stage -> TypeRef
variableType = TypeRef {TypeName
typeConName :: TypeRef -> TypeName
typeConName :: TypeName
typeConName}
} =
ValidationError :: Message -> [Position] -> ValidationError
ValidationError
{ validationMessage :: Message
validationMessage =
Message
"Variable "
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> FieldName -> Message
forall a. Msg a => a -> Message
msg (FieldName
"$" FieldName -> FieldName -> FieldName
forall a. Semigroup a => a -> a -> a
<> FieldName
variableName)
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
" cannot be non-input type "
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> TypeName -> Message
forall a. Msg a => a -> Message
msg TypeName
typeConName
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
".",
validationLocations :: [Position]
validationLocations = [Position
variablePosition]
}