Arguments.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Validation.Internal.Arguments
  ( validateDirectiveArguments,
    validateFieldArguments,
    ArgumentsConstraints,
    Resolve,
  )
where

import Data.Morpheus.Types.Internal.AST
  ( Argument (..),
    ArgumentDefinition (..),
    Arguments,
    ArgumentsDefinition,
    CONST,
    DirectiveDefinition (..),
    FieldDefinition (..),
    IN,
    OUT,
    ObjectEntry (..),
    Position (..),
    RAW,
    VALID,
    Value (..),
    VariableDefinitions,
    fieldArguments,
    typed,
  )
import Data.Morpheus.Types.Internal.Validation
  ( FragmentValidator,
    InputSource (..),
    MissingRequired,
    OperationContext,
    Scope (..),
    Validator,
    askVariables,
    asksScope,
    selectKnown,
    selectRequired,
    selectWithDefaultValue,
    setPosition,
    startInput,
    withScope,
  )
import Data.Morpheus.Validation.Internal.Value
  ( ValidateWithDefault,
    validateInputByTypeRef,
  )
import Relude hiding (empty)

type VariableConstraints ctx =
  ( MissingRequired (VariableDefinitions VALID) ctx
  )

type ArgumentsConstraints c schemaS valueS =
  ( Resolve Argument valueS c,
    ValidateWithDefault c schemaS schemaS,
    ValidateWithDefault c schemaS CONST
  )

validateArgument ::
  ( ValidateWithDefault ctx schemaS valueS,
    ValidateWithDefault ctx schemaS schemaS
  ) =>
  Arguments valueS ->
  ArgumentDefinition schemaS ->
  Validator schemaS ctx (Argument VALID)
validateArgument
  requestArgs
  ArgumentDefinition {argument} =
    selectWithDefaultValue
      (toArgument argument >=> validateArgumentValue argument)
      (validateArgumentValue argument)
      argument
      requestArgs

toArgument :: FieldDefinition IN s -> Value schemaS -> Validator schemaStage ctx (Argument schemaS)
toArgument
  FieldDefinition {fieldName}
  value = mkArg . fromMaybe (Position 0 0) <$> asksScope position
    where
      mkArg pos = Argument pos fieldName value

validateArgumentValue ::
  (ValidateWithDefault ctx schemaS valueS) =>
  FieldDefinition IN schemaS ->
  Argument valueS ->
  Validator schemaS ctx (Argument VALID)
validateArgumentValue
  field
  Argument {argumentValue, ..} =
    withScope (setPosition argumentPosition)
      $ startInput (SourceArgument argumentName)
      $ Argument
        argumentPosition
        argumentName
      <$> validateInputByTypeRef (typed fieldType field) argumentValue

validateFieldArguments ::
  FieldDefinition OUT VALID ->
  Arguments RAW ->
  FragmentValidator s (Arguments VALID)
validateFieldArguments field =
  validateArguments
    (`selectKnown` arguments)
    arguments
  where
    arguments = fieldArguments field

validateDirectiveArguments ::
  (ArgumentsConstraints ctx schemaStage valueStage) =>
  DirectiveDefinition schemaStage ->
  Arguments valueStage ->
  Validator schemaStage ctx (Arguments VALID)
validateDirectiveArguments
  DirectiveDefinition
    { directiveDefinitionArgs
    } =
    validateArguments
      (`selectKnown` directiveDefinitionArgs)
      directiveDefinitionArgs

validateArguments ::
  (ArgumentsConstraints ctx schemaStage s) =>
  (Argument CONST -> Validator schemaStage ctx (ArgumentDefinition schemaStage)) ->
  ArgumentsDefinition schemaStage ->
  Arguments s ->
  Validator schemaStage ctx (Arguments VALID)
validateArguments checkUnknown argsDef rawArgs = do
  args <- traverse resolve rawArgs
  traverse_ checkUnknown args
    *> traverse (validateArgument args) argsDef

class Resolve f s ctx where
  resolve :: f s -> Validator schemaS ctx (f CONST)

instance (VariableConstraints (OperationContext VALID s)) => Resolve Argument RAW (OperationContext VALID s) where
  resolve (Argument key position val) = Argument key position <$> resolve val

instance Resolve f CONST ctx where
  resolve = pure

instance (VariableConstraints (OperationContext VALID s)) => Resolve Value RAW (OperationContext VALID s) where
  resolve Null = pure Null
  resolve (Scalar x) = pure $ Scalar x
  resolve (Enum x) = pure $ Enum x
  resolve (List elems) = List <$> traverse resolve elems
  resolve (Object fields) = Object <$> traverse resolve fields
  resolve (VariableValue ref) =
    askVariables
      >>= fmap (ResolvedVariable ref)
      . selectRequired ref

instance (VariableConstraints (OperationContext VALID s)) => Resolve ObjectEntry RAW (OperationContext VALID s) where
  resolve (ObjectEntry name value) = ObjectEntry name <$> resolve value