content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE DeriveFunctor #-}
  {-# LANGUAGE DerivingStrategies #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# LANGUAGE NoImplicitPrelude #-}
  
  module Data.Morpheus.Types.Internal.Validation.Validator
    ( Validator (..),
      SelectionValidator,
      InputValidator,
      BaseValidator,
      runValidator,
      Constraint (..),
      setSelection,
      inField,
      inputMessagePrefix,
      InputSource (..),
      InputContext (..),
      OperationContext (..),
      renderInputPrefix,
      Prop (..),
      --  Resolution,
      ScopeKind (..),
      inputValueSource,
      Scope (..),
      setDirective,
      startInput,
      withContext,
      renderField,
      -- asks,
      asksScope,
      askVariables,
      askFragments,
      ValidatorContext (..),
      FragmentValidator,
      askTypeDefinitions,
      withScope,
      setPosition,
    )
  where
  
  import Control.Monad.Except (MonadError (catchError, throwError))
  import Control.Monad.Reader (asks)
  import Data.Morpheus.Ext.Result
    ( GQLResult,
    )
  import Data.Morpheus.Types.Internal.AST
    ( ANY,
      FieldDefinition (..),
      FieldName,
      Fragments,
      IMPLEMENTABLE,
      IN,
      RAW,
      Schema,
      Stage,
      TypeCategory,
      TypeDefinition (..),
      TypeName,
      TypeRef (..),
      VALID,
      Variable (..),
      VariableDefinitions,
      intercalate,
      typeDefinitions,
      unpackName,
    )
  import Data.Morpheus.Types.Internal.AST.Error
  import Data.Morpheus.Types.Internal.Config (Config (..))
  import Data.Morpheus.Types.Internal.Validation.Scope
    ( Scope (..),
      ScopeKind (..),
      renderScope,
      renderSection,
      setDirective,
      setPosition,
      setSelection,
    )
  import Relude hiding
    ( Constraint,
      asks,
      get,
      intercalate,
    )
  
  data Prop = Prop
    { propName :: FieldName,
      propTypeName :: TypeName
    }
    deriving (Show)
  
  type Path = [Prop]
  
  renderPath :: Path -> GQLError
  renderPath [] = ""
  renderPath path = "in field " <> msg (intercalate "." $ fmap propName path) <> ": "
  
  renderInputPrefix :: InputContext c -> GQLError
  renderInputPrefix InputContext {inputPath, inputSource} =
    renderSource inputSource <> renderPath inputPath
  
  renderSource :: InputSource -> GQLError
  renderSource (SourceArgument argumentName) =
    "Argument " <> msg argumentName <> " got invalid value. "
  renderSource (SourceVariable Variable {variableName} _) =
    "Variable " <> msg ("$" <> variableName) <> " got invalid value. "
  renderSource SourceInputField {sourceTypeName, sourceFieldName, sourceArgumentName} =
    "Field " <> renderField sourceTypeName sourceFieldName sourceArgumentName <> " got invalid default value. "
  
  renderField :: TypeName -> FieldName -> Maybe FieldName -> GQLError
  renderField tName fName arg =
    msg (unpackName tName <> "." <> unpackName fName <> renderArg arg :: Text)
    where
      renderArg (Just argName) = "(" <> unpackName argName <> ":)"
      renderArg Nothing = ""
  
  data OperationContext (s1 :: Stage) (s2 :: Stage) = OperationContext
    { fragments :: Fragments s2,
      variables :: VariableDefinitions s1,
      operationName :: Maybe FieldName
    }
    deriving (Show)
  
  data InputContext ctx = InputContext
    { inputSource :: InputSource,
      inputPath :: [Prop],
      sourceContext :: ctx
    }
    deriving (Show)
  
  data InputSource
    = SourceArgument FieldName
    | SourceVariable
        { sourceVariable :: Variable RAW,
          isDefaultValue :: Bool
        }
    | SourceInputField
        { sourceTypeName :: TypeName,
          sourceFieldName :: FieldName,
          sourceArgumentName :: Maybe FieldName
        }
    deriving (Show)
  
  data Constraint (a :: TypeCategory) where
    IMPLEMENTABLE :: Constraint IMPLEMENTABLE
    INPUT :: Constraint IN
  
  inField :: FieldDefinition IN s -> InputValidator s c a -> InputValidator s c a
  inField
    FieldDefinition
      { fieldName,
        fieldType = TypeRef {typeConName}
      } = withContext update
      where
        update
          InputContext
            { inputPath = old,
              ..
            } =
            InputContext
              { inputPath = old <> [Prop fieldName typeConName],
                ..
              }
  
  inputValueSource :: (MonadReader (ValidatorContext s (InputContext c)) m) => m InputSource
  inputValueSource = asksLocal inputSource
  
  asksScope :: (MonadReader (ValidatorContext s ctx) m) => (Scope -> a) -> m a
  asksScope f = asks (f . scope)
  
  askTypeDefinitions ::
    (MonadReader (ValidatorContext s ctx) m) =>
    m (HashMap TypeName (TypeDefinition ANY s))
  askTypeDefinitions = asks (typeDefinitions . schema)
  
  askVariables :: (MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m) => m (VariableDefinitions s2)
  askVariables = asksLocal variables
  
  askFragments :: (MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m) => m (Fragments s3)
  askFragments = asksLocal fragments
  
  runValidator :: Validator s ctx a -> Config -> Schema s -> Scope -> ctx -> GQLResult a
  runValidator (Validator x) config schema scope localContext =
    runReaderT x ValidatorContext {..}
  
  withContext :: (c' -> c) -> Validator s c a -> Validator s c' a
  withContext f = Validator . withReaderT (fmap f) . _runValidator
  
  inputMessagePrefix :: InputValidator s ctx GQLError
  inputMessagePrefix =
    renderInputPrefix
      . localContext
      <$> Validator ask
  
  startInput :: InputSource -> InputValidator s ctx a -> Validator s ctx a
  startInput inputSource = withContext update
    where
      update sourceContext =
        InputContext
          { inputSource,
            inputPath = [],
            sourceContext
          }
  
  data ValidatorContext (s :: Stage) (ctx :: Type) = ValidatorContext
    { scope :: Scope,
      schema :: Schema s,
      localContext :: ctx,
      config :: Config
    }
    deriving
      ( Show,
        Functor
      )
  
  newtype Validator s ctx a = Validator
    { _runValidator ::
        ReaderT
          (ValidatorContext s ctx)
          GQLResult
          a
    }
    deriving newtype
      ( Functor,
        Applicative,
        Monad,
        MonadReader (ValidatorContext s ctx)
      )
  
  data ValidationTarget
    = Base
    | Fragments
    | Selections
  
  type family ValidationStage (s :: ValidationTarget) where
    ValidationStage 'Base = OperationContext RAW RAW
    ValidationStage 'Fragments = OperationContext VALID RAW
    ValidationStage 'Selections = OperationContext VALID VALID
  
  type ValidatorM (s :: ValidationTarget) = Validator VALID (ValidationStage s)
  
  type BaseValidator = ValidatorM 'Base
  
  type FragmentValidator (s :: Stage) = Validator VALID (OperationContext VALID s)
  
  type SelectionValidator = ValidatorM 'Selections
  
  type InputValidator s ctx = Validator s (InputContext ctx)
  
  withScope ::
    (MonadReader (ValidatorContext s c) m) =>
    (Scope -> Scope) ->
    m b ->
    m b
  withScope f = local (\ValidatorContext {..} -> ValidatorContext {scope = f scope, ..})
  
  asksLocal :: (MonadReader (ValidatorContext s c) m) => (c -> a) -> m a
  asksLocal f = asks (f . localContext)
  
  instance MonadError GQLError (Validator s ctx) where
    throwError err = Validator $ do
      ctx <- ask
      throwError (fromValidationError ctx err)
    catchError (Validator x) f = Validator (catchError x (_runValidator . f))
  
  fromValidationError :: ValidatorContext s ctx -> GQLError -> GQLError
  fromValidationError
    context@ValidatorContext
      { config,
        scope = Scope {position, path}
      }
    err
      | isInternal err || debug config =
          ( err
              <> renderContext context
              `atPositions` position
          )
            `withPath` path
      | otherwise = err
  
  renderContext :: ValidatorContext s ctx -> GQLError
  renderContext
    ValidatorContext
      { schema,
        scope
      } =
      renderScope scope
        <> renderSection "SchemaDefinition" schema
  