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

-- query M ( $v : String ) { a } -> "Variable \"$bla\" is never used in operation \"MyMutation\".",
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
  -- type UnknownSelector c
  unknown :: Scope -> ctx -> c -> ref -> ValidationError

-- {...H} -> "Unknown fragment \"H\"."
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]
        }