{-# 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 :: forall ctx (schemaS :: Stage) (valueS :: Stage).
(ValidateWithDefault ctx schemaS valueS,
 ValidateWithDefault ctx schemaS schemaS) =>
Arguments valueS
-> ArgumentDefinition schemaS
-> Validator schemaS ctx (Argument VALID)
validateArgument
  OrdMap FieldName (Argument valueS)
requestArgs
  ArgumentDefinition {FieldDefinition IN schemaS
argument :: forall (s :: Stage). ArgumentDefinition s -> FieldDefinition IN s
argument :: FieldDefinition IN schemaS
argument} =
    forall ctx (c :: * -> *) (s :: Stage) validValue a.
(IsMap FieldName c, MissingRequired (c a) ctx) =>
(Value s -> Validator s ctx validValue)
-> (a -> Validator s ctx validValue)
-> FieldDefinition IN s
-> c a
-> Validator s ctx validValue
selectWithDefaultValue
      (forall (s :: Stage) (schemaS :: Stage) (schemaStage :: Stage) ctx.
FieldDefinition IN s
-> Value schemaS -> Validator schemaStage ctx (Argument schemaS)
toArgument FieldDefinition IN schemaS
argument forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
FieldDefinition IN schemaS
-> Argument valueS -> Validator schemaS ctx (Argument VALID)
validateArgumentValue FieldDefinition IN schemaS
argument)
      (forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
FieldDefinition IN schemaS
-> Argument valueS -> Validator schemaS ctx (Argument VALID)
validateArgumentValue FieldDefinition IN schemaS
argument)
      FieldDefinition IN schemaS
argument
      OrdMap FieldName (Argument valueS)
requestArgs

toArgument :: FieldDefinition IN s -> Value schemaS -> Validator schemaStage ctx (Argument schemaS)
toArgument :: forall (s :: Stage) (schemaS :: Stage) (schemaStage :: Stage) ctx.
FieldDefinition IN s
-> Value schemaS -> Validator schemaStage ctx (Argument schemaS)
toArgument
  FieldDefinition {FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName}
  Value schemaS
value = Position -> Argument schemaS
mkArg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe (Int -> Int -> Position
Position Int
0 Int
0) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (s :: Stage) ctx (m :: * -> *) a.
MonadReader (ValidatorContext s ctx) m =>
(Scope -> a) -> m a
asksScope Scope -> Maybe Position
position
    where
      mkArg :: Position -> Argument schemaS
mkArg Position
pos = forall (valid :: Stage).
Position -> FieldName -> Value valid -> Argument valid
Argument Position
pos FieldName
fieldName Value schemaS
value

validateArgumentValue ::
  (ValidateWithDefault ctx schemaS valueS) =>
  FieldDefinition IN schemaS ->
  Argument valueS ->
  Validator schemaS ctx (Argument VALID)
validateArgumentValue :: forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
FieldDefinition IN schemaS
-> Argument valueS -> Validator schemaS ctx (Argument VALID)
validateArgumentValue
  FieldDefinition IN schemaS
field
  Argument {Value valueS
argumentValue :: forall (valid :: Stage). Argument valid -> Value valid
argumentValue :: Value valueS
argumentValue, Position
FieldName
argumentName :: forall (valid :: Stage). Argument valid -> FieldName
argumentPosition :: forall (valid :: Stage). Argument valid -> Position
argumentName :: FieldName
argumentPosition :: Position
..} =
    forall (s :: Stage) c (m :: * -> *) b.
MonadReader (ValidatorContext s c) m =>
(Scope -> Scope) -> m b -> m b
withScope (Position -> Scope -> Scope
setPosition Position
argumentPosition) forall a b. (a -> b) -> a -> b
$
      forall (s :: Stage) ctx a.
InputSource -> InputValidator s ctx a -> Validator s ctx a
startInput (FieldName -> InputSource
SourceArgument FieldName
argumentName) forall a b. (a -> b) -> a -> b
$
        forall (valid :: Stage).
Position -> FieldName -> Value valid -> Argument valid
Argument
          Position
argumentPosition
          FieldName
argumentName
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c (schemaS :: Stage) (s :: Stage).
ValidateWithDefault c schemaS s =>
Typed IN schemaS TypeRef
-> Value s -> Validator schemaS (InputContext c) (Value VALID)
validateInputByTypeRef (forall (a :: TypeCategory -> Stage -> *) (c :: TypeCategory)
       (s :: Stage) b.
(a c s -> b) -> a c s -> Typed c s b
typed forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType FieldDefinition IN schemaS
field) Value valueS
argumentValue

validateFieldArguments ::
  FieldDefinition OUT VALID ->
  Arguments RAW ->
  FragmentValidator s (Arguments VALID)
validateFieldArguments :: forall (s :: Stage).
FieldDefinition OUT VALID
-> Arguments RAW -> FragmentValidator s (Arguments VALID)
validateFieldArguments FieldDefinition OUT VALID
field =
  forall ctx (schemaStage :: Stage) (s :: Stage).
ArgumentsConstraints ctx schemaStage s =>
(Argument CONST
 -> Validator schemaStage ctx (ArgumentDefinition schemaStage))
-> ArgumentsDefinition schemaStage
-> Arguments s
-> Validator schemaStage ctx (Arguments VALID)
validateArguments
    (forall k (c :: * -> *) sel ctx a (s :: Stage).
(IsMap k c, Unknown sel ctx, KeyOf k sel) =>
sel -> c a -> Validator s ctx a
`selectKnown` ArgumentsDefinition VALID
arguments)
    ArgumentsDefinition VALID
arguments
  where
    arguments :: ArgumentsDefinition VALID
arguments = forall (c :: TypeCategory) (s :: Stage).
FieldDefinition c s -> ArgumentsDefinition s
fieldArguments FieldDefinition OUT VALID
field

validateDirectiveArguments ::
  ArgumentsConstraints ctx schemaStage valueStage =>
  DirectiveDefinition schemaStage ->
  Arguments valueStage ->
  Validator schemaStage ctx (Arguments VALID)
validateDirectiveArguments :: forall ctx (schemaStage :: Stage) (valueStage :: Stage).
ArgumentsConstraints ctx schemaStage valueStage =>
DirectiveDefinition schemaStage
-> Arguments valueStage
-> Validator schemaStage ctx (Arguments VALID)
validateDirectiveArguments
  DirectiveDefinition
    { ArgumentsDefinition schemaStage
directiveDefinitionArgs :: forall (s :: Stage). DirectiveDefinition s -> ArgumentsDefinition s
directiveDefinitionArgs :: ArgumentsDefinition schemaStage
directiveDefinitionArgs
    } =
    forall ctx (schemaStage :: Stage) (s :: Stage).
ArgumentsConstraints ctx schemaStage s =>
(Argument CONST
 -> Validator schemaStage ctx (ArgumentDefinition schemaStage))
-> ArgumentsDefinition schemaStage
-> Arguments s
-> Validator schemaStage ctx (Arguments VALID)
validateArguments
      (forall k (c :: * -> *) sel ctx a (s :: Stage).
(IsMap k c, Unknown sel ctx, KeyOf k sel) =>
sel -> c a -> Validator s ctx a
`selectKnown` ArgumentsDefinition schemaStage
directiveDefinitionArgs)
      ArgumentsDefinition schemaStage
directiveDefinitionArgs

validateArguments ::
  ArgumentsConstraints ctx schemaStage s =>
  (Argument CONST -> Validator schemaStage ctx (ArgumentDefinition schemaStage)) ->
  ArgumentsDefinition schemaStage ->
  Arguments s ->
  Validator schemaStage ctx (Arguments VALID)
validateArguments :: forall ctx (schemaStage :: Stage) (s :: Stage).
ArgumentsConstraints ctx schemaStage s =>
(Argument CONST
 -> Validator schemaStage ctx (ArgumentDefinition schemaStage))
-> ArgumentsDefinition schemaStage
-> Arguments s
-> Validator schemaStage ctx (Arguments VALID)
validateArguments Argument CONST
-> Validator schemaStage ctx (ArgumentDefinition schemaStage)
checkUnknown ArgumentsDefinition schemaStage
argsDef Arguments s
rawArgs = do
  OrdMap FieldName (Argument CONST)
args <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (f :: Stage -> *) (s :: Stage) ctx (schemaS :: Stage).
Resolve f s ctx =>
f s -> Validator schemaS ctx (f CONST)
resolve Arguments s
rawArgs
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Argument CONST
-> Validator schemaStage ctx (ArgumentDefinition schemaStage)
checkUnknown OrdMap FieldName (Argument CONST)
args
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall ctx (schemaS :: Stage) (valueS :: Stage).
(ValidateWithDefault ctx schemaS valueS,
 ValidateWithDefault ctx schemaS schemaS) =>
Arguments valueS
-> ArgumentDefinition schemaS
-> Validator schemaS ctx (Argument VALID)
validateArgument OrdMap FieldName (Argument CONST)
args) ArgumentsDefinition schemaStage
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 :: forall (schemaS :: Stage).
Argument RAW
-> Validator schemaS (OperationContext VALID s) (Argument CONST)
resolve (Argument Position
key FieldName
position Value RAW
val) = forall (valid :: Stage).
Position -> FieldName -> Value valid -> Argument valid
Argument Position
key FieldName
position forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: Stage -> *) (s :: Stage) ctx (schemaS :: Stage).
Resolve f s ctx =>
f s -> Validator schemaS ctx (f CONST)
resolve Value RAW
val

instance Resolve f CONST ctx where
  resolve :: forall (schemaS :: Stage).
f CONST -> Validator schemaS ctx (f CONST)
resolve = forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance VariableConstraints (OperationContext VALID s) => Resolve Value RAW (OperationContext VALID s) where
  resolve :: forall (schemaS :: Stage).
Value RAW
-> Validator schemaS (OperationContext VALID s) (Value CONST)
resolve Value RAW
Null = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (stage :: Stage). Value stage
Null
  resolve (Scalar ScalarValue
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (stage :: Stage). ScalarValue -> Value stage
Scalar ScalarValue
x
  resolve (Enum TypeName
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (stage :: Stage). TypeName -> Value stage
Enum TypeName
x
  resolve (List [Value RAW]
elems) = forall (stage :: Stage). [Value stage] -> Value stage
List forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (f :: Stage -> *) (s :: Stage) ctx (schemaS :: Stage).
Resolve f s ctx =>
f s -> Validator schemaS ctx (f CONST)
resolve [Value RAW]
elems
  resolve (Object Object RAW
fields) = forall (stage :: Stage). Object stage -> Value stage
Object forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (f :: Stage -> *) (s :: Stage) ctx (schemaS :: Stage).
Resolve f s ctx =>
f s -> Validator schemaS ctx (f CONST)
resolve Object RAW
fields
  resolve (VariableValue Ref FieldName
ref) =
    forall (s1 :: Stage) (s2 :: Stage) (s3 :: Stage) (m :: * -> *).
MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m =>
m (VariableDefinitions s2)
askVariables
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Ref FieldName -> Variable VALID -> Value CONST
ResolvedVariable Ref FieldName
ref)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (c :: * -> *) a ctx (s :: Stage).
(IsMap FieldName c, MissingRequired (c a) ctx) =>
Ref FieldName -> c a -> Validator s ctx a
selectRequired Ref FieldName
ref

instance VariableConstraints (OperationContext VALID s) => Resolve ObjectEntry RAW (OperationContext VALID s) where
  resolve :: forall (schemaS :: Stage).
ObjectEntry RAW
-> Validator schemaS (OperationContext VALID s) (ObjectEntry CONST)
resolve (ObjectEntry FieldName
name Value RAW
value) = forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: Stage -> *) (s :: Stage) ctx (schemaS :: Stage).
Resolve f s ctx =>
f s -> Validator schemaS ctx (f CONST)
resolve Value RAW
value