{-# 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 (..),
    Unused (..),
  )
where

import Data.Morpheus.Error.Selection (unknownSelectionField)
import Data.Morpheus.Types.Internal.AST
  ( Argument (..),
    Arguments,
    CONST,
    Directive (..),
    DirectiveDefinition (..),
    DirectiveDefinitions,
    FieldDefinition (..),
    FieldName,
    FieldsDefinition,
    Fragment (..),
    Fragments,
    IMPLEMENTABLE,
    IN,
    OUT,
    Object,
    ObjectEntry (..),
    Ref (..),
    Schema,
    TypeCategory,
    TypeName,
    TypeRef (..),
    ValidationError (..),
    Variable (..),
    VariableDefinitions,
    getOperationName,
    msg,
    msgValidation,
    withPosition,
  )
import Data.Morpheus.Types.Internal.Validation.Validator
  ( CurrentSelection (..),
    InputContext (..),
    OperationContext (..),
    Scope (..),
    ScopeKind (..),
    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 {selection = CurrentSelection {operationName}}
    Variable {variableName, variablePosition} =
      ValidationError
        { validationMessage =
            "Variable " <> msg ("$" <> variableName)
              <> " is never used in operation "
              <> msg (getOperationName operationName)
              <> ".",
          validationLocations = [variablePosition]
        }

instance Unused (OperationContext s1 s2) (Fragment s) where
  unused
    _
    Fragment {fragmentName, fragmentPosition} =
      ValidationError
        { validationMessage =
            "Fragment " <> msg fragmentName
              <> " is never used.",
          validationLocations = [fragmentPosition]
        }

class MissingRequired c ctx where
  missingRequired :: Scope -> ctx -> Ref FieldName -> c -> ValidationError

instance MissingRequired (Arguments s) ctx where
  missingRequired
    Scope {position, kind, fieldname}
    _
    Ref {refName}
    _ =
      ValidationError
        { validationMessage =
            inScope kind
              <> " argument "
              <> msg refName
              <> " is required but not provided.",
          validationLocations = maybeToList position
        }
      where
        inScope DIRECTIVE = "Directive " <> msg ("@" <> fieldname)
        inScope _ = "Field " <> msg fieldname

instance MissingRequired (Object s) (InputContext ctx) where
  missingRequired
    Scope {position}
    ctx
    Ref {refName}
    _ =
      withPosition
        position
        ( renderInputPrefix
            ctx
            <> "Undefined Field "
            <> msgValidation refName
            <> "."
        )

instance MissingRequired (VariableDefinitions s) (OperationContext s1 s2) where
  missingRequired
    _
    OperationContext
      { selection = CurrentSelection {operationName}
      }
    Ref {refName, refPosition}
    _ =
      ValidationError
        { validationMessage =
            "Variable "
              <> msg refName
              <> " is not defined by operation "
              <> msg (getOperationName operationName)
              <> ".",
          validationLocations = [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 FieldName) ctx where
  unknown _ _ _ Ref {refName, refPosition} =
    ValidationError
      { validationMessage = "Unknown Fragment " <> msg refName <> ".",
        validationLocations = [refPosition]
      }

instance Unknown (Schema s) (Ref TypeName) ctx where
  unknown _ _ _ Ref {refName, refPosition} =
    ValidationError
      { validationMessage = "Unknown type " <> msg refName <> ".",
        validationLocations = [refPosition]
      }

instance Unknown (FieldDefinition OUT s) (Argument CONST) ctx where
  unknown _ _ FieldDefinition {fieldName} Argument {argumentName, argumentPosition} =
    ValidationError
      { validationMessage = "Unknown Argument " <> msg argumentName <> " on Field " <> msg fieldName <> ".",
        validationLocations = [argumentPosition]
      }

instance Unknown (FieldsDefinition IN s) (ObjectEntry valueS) (InputContext ctx) where
  unknown
    Scope {position}
    ctx
    _
    ObjectEntry {entryName} =
      withPosition position $
        renderInputPrefix ctx <> "Unknown Field " <> msgValidation entryName <> "."

instance Unknown (DirectiveDefinition s) (Argument s') ctx where
  unknown _ _ DirectiveDefinition {directiveDefinitionName} Argument {argumentName, argumentPosition} =
    ValidationError
      { validationMessage = "Unknown Argument " <> msg argumentName <> " on Directive " <> msg directiveDefinitionName <> ".",
        validationLocations = [argumentPosition]
      }

instance Unknown (DirectiveDefinitions s) (Directive s') ctx where
  unknown _ _ _ Directive {directiveName, directivePosition} =
    ValidationError
      { validationMessage = "Unknown Directive " <> msg directiveName <> ".",
        validationLocations = [directivePosition]
      }

instance Unknown (FieldsDefinition OUT s) (Ref FieldName) (OperationContext s1 s2) where
  unknown Scope {currentTypeName} _ _ = unknownSelectionField currentTypeName

class KindViolation (t :: TypeCategory) ctx where
  kindViolation :: c t -> ctx -> ValidationError

instance KindViolation IMPLEMENTABLE (Fragment s) where
  kindViolation _ Fragment {fragmentName, fragmentType, fragmentPosition} =
    ValidationError
      { validationMessage =
          "Fragment "
            <> msg fragmentName
            <> " cannot condition on non composite type "
            <> msg fragmentType
            <> ".",
        validationLocations = [fragmentPosition]
      }

instance KindViolation IN (Variable s) where
  kindViolation
    _
    Variable
      { variableName,
        variablePosition,
        variableType = TypeRef {typeConName}
      } =
      ValidationError
        { validationMessage =
            "Variable "
              <> msg ("$" <> variableName)
              <> " cannot be non-input type "
              <> msg typeConName
              <> ".",
          validationLocations = [variablePosition]
        }