{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Validation.Internal.Value
  ( validateInputByTypeRef,
    validateInputByType,
    ValidateWithDefault,
  )
where

import Control.Monad.Except (throwError)
import Data.Morpheus.Error.Input (typeViolation)
import Data.Morpheus.Error.Variable (incompatibleVariableType)
import Data.Morpheus.Internal.Utils
  ( singleton,
  )
import Data.Morpheus.Types.Internal.AST
  ( CONST,
    DataEnumValue (..),
    FieldDefinition (..),
    FieldName,
    FieldsDefinition,
    GQLError,
    IN,
    Object,
    ObjectEntry (..),
    Ref (..),
    ScalarDefinition (..),
    ScalarValue (..),
    TRUE,
    TypeContent (..),
    TypeDefinition (..),
    TypeName,
    TypeRef (..),
    TypeWrapper (..),
    Typed (..),
    UnionMember (..),
    UnionTypeDefinition,
    VALID,
    ValidValue,
    Value (..),
    Variable (..),
    VariableContent (..),
    atPositions,
    isNullable,
    isSubtype,
    mkMaybeType,
    mkTypeRef,
    msg,
    packName,
    toCategory,
    typed,
    unitFieldName,
    unitTypeName,
    untyped,
  )
import Data.Morpheus.Types.Internal.Validation
  ( askType,
    askTypeMember,
    constraintInputUnion,
    selectKnown,
    selectWithDefaultValue,
  )
import Data.Morpheus.Types.Internal.Validation.Scope (setType)
import Data.Morpheus.Types.Internal.Validation.Validator
import Relude

violation ::
  Maybe GQLError ->
  Value s ->
  InputValidator schemaS ctx a
violation :: forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation Maybe GQLError
message Value s
value = do
  Scope
    { Maybe Position
position :: Scope -> Maybe Position
position :: Maybe Position
position,
      TypeName
currentTypeName :: Scope -> TypeName
currentTypeName :: TypeName
currentTypeName,
      TypeWrapper
currentTypeWrappers :: Scope -> TypeWrapper
currentTypeWrappers :: TypeWrapper
currentTypeWrappers
    } <-
    forall (s :: Stage) ctx (m :: * -> *) a.
MonadReader (ValidatorContext s ctx) m =>
(Scope -> a) -> m a
asksScope forall a. a -> a
id
  GQLError
prefix <- forall (s :: Stage) ctx. InputValidator s ctx GQLError
inputMessagePrefix
  forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
    ( GQLError
prefix
        forall a. Semigroup a => a -> a -> a
<> forall (s :: Stage). TypeRef -> Value s -> GQLError
typeViolation
          (TypeName -> TypeWrapper -> TypeRef
TypeRef TypeName
currentTypeName TypeWrapper
currentTypeWrappers)
          Value s
value
        forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe GQLError
"" (GQLError
" " forall a. Semigroup a => a -> a -> a
<>) Maybe GQLError
message
    )
      forall (t :: * -> *).
Foldable t =>
GQLError -> t Position -> GQLError
`atPositions` Maybe Position
position

checkTypeCompatibility ::
  TypeRef ->
  Ref FieldName ->
  Variable VALID ->
  InputValidator schemaS ctx ValidValue
checkTypeCompatibility :: forall (schemaS :: Stage) ctx.
TypeRef
-> Ref FieldName
-> Variable VALID
-> InputValidator schemaS ctx ValidValue
checkTypeCompatibility TypeRef
valueType Ref FieldName
ref var :: Variable VALID
var@Variable {variableValue :: forall (stage :: Stage).
Variable stage -> VariableContent (CONST_OR_VALID stage)
variableValue = ValidVariableValue ValidValue
value, TypeRef
variableType :: forall (stage :: Stage). Variable stage -> TypeRef
variableType :: TypeRef
variableType}
  | TypeRef
variableType forall t. Subtyping t => t -> t -> Bool
`isSubtype` TypeRef
valueType = forall (f :: * -> *) a. Applicative f => a -> f a
pure ValidValue
value
  | Bool
otherwise = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall (s :: Stage).
Ref FieldName -> Variable s -> TypeRef -> GQLError
incompatibleVariableType Ref FieldName
ref Variable VALID
var TypeRef
valueType

validateInputByTypeRef ::
  ValidateWithDefault c schemaS s =>
  Typed IN schemaS TypeRef ->
  Value s ->
  Validator schemaS (InputContext c) (Value VALID)
validateInputByTypeRef :: forall c (schemaS :: Stage) (s :: Stage).
ValidateWithDefault c schemaS s =>
Typed IN schemaS TypeRef
-> Value s -> Validator schemaS (InputContext c) ValidValue
validateInputByTypeRef
  Typed IN schemaS TypeRef
ref
  Value s
value = do
    TypeDefinition IN schemaS
inputTypeDef <- forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx.
Constraints m c cat s ctx =>
Typed cat s TypeRef -> m (TypeDefinition cat s)
askType Typed IN schemaS TypeRef
ref
    forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
TypeWrapper
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
validateInputByType
      (forall a b (c :: TypeCategory) (s :: Stage).
(a -> b) -> Typed c s a -> b
untyped TypeRef -> TypeWrapper
typeWrappers Typed IN schemaS TypeRef
ref)
      TypeDefinition IN schemaS
inputTypeDef
      Value s
value

validateValueByField ::
  ValidateWithDefault c schemaS s =>
  FieldDefinition IN schemaS ->
  Value s ->
  Validator schemaS (InputContext c) (Value VALID)
validateValueByField :: forall c (schemaS :: Stage) (s :: Stage).
ValidateWithDefault c schemaS s =>
FieldDefinition IN schemaS
-> Value s -> Validator schemaS (InputContext c) ValidValue
validateValueByField FieldDefinition IN schemaS
field =
  forall (s :: Stage) c a.
FieldDefinition IN s
-> InputValidator s c a -> InputValidator s c a
inField FieldDefinition IN schemaS
field
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (schemaS :: Stage) (s :: Stage).
ValidateWithDefault c schemaS s =>
Typed IN schemaS TypeRef
-> Value s -> Validator schemaS (InputContext c) ValidValue
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)

-- Validate input Values
validateInputByType ::
  ValidateWithDefault ctx schemaS valueS =>
  TypeWrapper ->
  TypeDefinition IN schemaS ->
  Value valueS ->
  InputValidator schemaS ctx ValidValue
validateInputByType :: forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
TypeWrapper
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
validateInputByType TypeWrapper
tyWrappers TypeDefinition IN schemaS
typeDef =
  forall (s :: Stage) c (m :: * -> *) b.
MonadReader (ValidatorContext s c) m =>
(Scope -> Scope) -> m b -> m b
withScope (forall (c :: TypeCategory) (s :: Stage).
TypeDefinition c s -> TypeWrapper -> Scope -> Scope
setType TypeDefinition IN schemaS
typeDef TypeWrapper
tyWrappers) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
TypeWrapper
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
validateWrapped TypeWrapper
tyWrappers TypeDefinition IN schemaS
typeDef

-- VALIDATION
validateWrapped ::
  ValidateWithDefault ctx schemaS valueS =>
  TypeWrapper ->
  TypeDefinition IN schemaS ->
  Value valueS ->
  InputValidator schemaS ctx ValidValue
-- Validate Null. value = null ?
validateWrapped :: forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
TypeWrapper
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
validateWrapped TypeWrapper
wrappers TypeDefinition IN schemaS
_ (ResolvedVariable Ref FieldName
ref Variable VALID
variable) = do
  TypeName
typeName <- forall (s :: Stage) ctx (m :: * -> *) a.
MonadReader (ValidatorContext s ctx) m =>
(Scope -> a) -> m a
asksScope Scope -> TypeName
currentTypeName
  forall (schemaS :: Stage) ctx.
TypeRef
-> Ref FieldName
-> Variable VALID
-> InputValidator schemaS ctx ValidValue
checkTypeCompatibility (TypeName -> TypeWrapper -> TypeRef
TypeRef TypeName
typeName TypeWrapper
wrappers) Ref FieldName
ref Variable VALID
variable
validateWrapped TypeWrapper
wrappers TypeDefinition IN schemaS
_ Value valueS
Null
  | forall a. Nullable a => a -> Bool
isNullable TypeWrapper
wrappers = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (stage :: Stage). Value stage
Null
  | Bool
otherwise = forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation forall a. Maybe a
Nothing forall (stage :: Stage). Value stage
Null
-- Validate LIST

validateWrapped (TypeList TypeWrapper
wrappers Bool
_) TypeDefinition IN schemaS
tyCont (List [Value valueS]
list) =
  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 ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
TypeWrapper
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
validateInputByType TypeWrapper
wrappers TypeDefinition IN schemaS
tyCont) [Value valueS]
list
validateWrapped (TypeList TypeWrapper
wrappers Bool
_) TypeDefinition IN schemaS
tyCont Value valueS
singleElem =
  forall (stage :: Stage). [Value stage] -> Value stage
List forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
TypeWrapper
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
validateInputByType TypeWrapper
wrappers TypeDefinition IN schemaS
tyCont Value valueS
singleElem
{-- 2. VALIDATE TYPES, all wrappers are already Processed --}
{-- VALIDATE OBJECT--}
validateWrapped BaseType {} TypeDefinition {TypeContent TRUE IN schemaS
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent :: TypeContent TRUE IN schemaS
typeContent} Value valueS
entryValue =
  forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
TypeContent TRUE IN schemaS
-> Value valueS -> InputValidator schemaS ctx ValidValue
validateUnwrapped TypeContent TRUE IN schemaS
typeContent Value valueS
entryValue

validateUnwrapped ::
  ValidateWithDefault ctx schemaS valueS =>
  TypeContent TRUE IN schemaS ->
  Value valueS ->
  InputValidator schemaS ctx ValidValue
validateUnwrapped :: forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
TypeContent TRUE IN schemaS
-> Value valueS -> InputValidator schemaS ctx ValidValue
validateUnwrapped (DataInputObject FieldsDefinition IN schemaS
parentFields) (Object Object valueS
fields) =
  forall (stage :: Stage). Object stage -> Value stage
Object forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
FieldsDefinition IN schemaS
-> Object valueS -> InputValidator schemaS ctx (Object VALID)
validateInputObject FieldsDefinition IN schemaS
parentFields Object valueS
fields
validateUnwrapped (DataInputUnion UnionTypeDefinition IN schemaS
inputUnion) (Object Object valueS
rawFields) =
  forall ctx (schemaS :: Stage) (s :: Stage).
ValidateWithDefault ctx schemaS s =>
UnionTypeDefinition IN schemaS
-> Object s -> InputValidator schemaS ctx ValidValue
validateInputUnion UnionTypeDefinition IN schemaS
inputUnion Object valueS
rawFields
validateUnwrapped (DataEnum DataEnum schemaS
tags) Value valueS
value =
  forall (s :: Stage) (valueS :: Stage) (schemaS :: Stage) c.
[DataEnumValue s]
-> Value valueS -> InputValidator schemaS c ValidValue
validateEnum DataEnum schemaS
tags Value valueS
value
validateUnwrapped (DataScalar ScalarDefinition
dataScalar) Value valueS
value =
  forall (s :: Stage) (schemaS :: Stage) ctx.
ScalarDefinition
-> Value s -> InputValidator schemaS ctx ValidValue
validateScalar ScalarDefinition
dataScalar Value valueS
value
validateUnwrapped TypeContent TRUE IN schemaS
_ Value valueS
value = forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation forall a. Maybe a
Nothing Value valueS
value

-- INPUT UNION
validateInputUnion ::
  ValidateWithDefault ctx schemaS s =>
  UnionTypeDefinition IN schemaS ->
  Object s ->
  InputValidator schemaS ctx (Value VALID)
validateInputUnion :: forall ctx (schemaS :: Stage) (s :: Stage).
ValidateWithDefault ctx schemaS s =>
UnionTypeDefinition IN schemaS
-> Object s -> InputValidator schemaS ctx ValidValue
validateInputUnion UnionTypeDefinition IN schemaS
inputUnion Object s
rawFields =
  case forall (stage :: Stage) (schemaStage :: Stage).
UnionTypeDefinition IN schemaStage
-> Object stage
-> Either GQLError (UnionMember IN schemaStage, Value stage)
constraintInputUnion UnionTypeDefinition IN schemaS
inputUnion Object s
rawFields of
    Left GQLError
message -> forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Msg a => a -> GQLError
msg GQLError
message) (forall (stage :: Stage). Object stage -> Value stage
Object Object s
rawFields)
    Right (UnionMember IN schemaS
name, Value s
value) -> forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
UnionMember IN schemaS
-> Value valueS -> InputValidator schemaS ctx ValidValue
validateInputUnionMember UnionMember IN schemaS
name Value s
value

validateInputUnionMember ::
  ValidateWithDefault ctx schemaS valueS =>
  UnionMember IN schemaS ->
  Value valueS ->
  InputValidator schemaS ctx (Value VALID)
validateInputUnionMember :: forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
UnionMember IN schemaS
-> Value valueS -> InputValidator schemaS ctx ValidValue
validateInputUnionMember UnionMember IN schemaS
member Value valueS
value = do
  TypeDefinition IN schemaS
inputDef <- Validator schemaS (InputContext ctx) (TypeDefinition IN schemaS)
askDef
  forall (s' :: Stage) (s :: Stage).
UnionMember IN s' -> Value s -> Value s
mkInputUnionValue UnionMember IN schemaS
member forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
TypeWrapper
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
validateInputByType TypeWrapper
mkMaybeType TypeDefinition IN schemaS
inputDef Value valueS
value
  where
    askDef :: Validator schemaS (InputContext ctx) (TypeDefinition IN schemaS)
askDef
      | forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> Bool
nullary UnionMember IN schemaS
member = forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx.
Constraints m c cat s ctx =>
Typed cat s TypeRef -> m (TypeDefinition cat s)
askType (forall (cat :: TypeCategory) (s :: Stage) a. a -> Typed cat s a
Typed forall a b. (a -> b) -> a -> b
$ TypeName -> TypeRef
mkTypeRef TypeName
unitTypeName)
      | Bool
otherwise = forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (k' :: TypeCategory) (s :: Stage).
ToCategory a k k' =>
a k s -> a k' s
toCategory forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx.
Constraints m c cat s ctx =>
UnionMember cat s -> m (TypeDefinition (ToOBJECT cat) s)
askTypeMember UnionMember IN schemaS
member

mkInputUnionValue :: UnionMember IN s' -> Value s -> Value s
mkInputUnionValue :: forall (s' :: Stage) (s :: Stage).
UnionMember IN s' -> Value s -> Value s
mkInputUnionValue
  UnionMember
    { TypeName
memberName :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName :: TypeName
memberName,
      Bool
nullary :: Bool
nullary :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> Bool
nullary
    } = forall (stage :: Stage). Object stage -> Value stage
Object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) a. IsMap k m => k -> a -> m a
singleton FieldName
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value s -> Value s
packNullary
    where
      key :: FieldName
key = coerce :: forall a b. Coercible a b => a -> b
coerce TypeName
memberName
      packNullary :: Value s -> Value s
packNullary
        | Bool
nullary = forall (stage :: Stage). Object stage -> Value stage
Object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) a. IsMap k m => k -> a -> m a
singleton FieldName
unitFieldName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
unitFieldName
        | Bool
otherwise = forall a. a -> a
id

-- INPUT Object
validateInputObject ::
  ValidateWithDefault ctx schemaS valueS =>
  FieldsDefinition IN schemaS ->
  Object valueS ->
  InputValidator schemaS ctx (Object VALID)
validateInputObject :: forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
FieldsDefinition IN schemaS
-> Object valueS -> InputValidator schemaS ctx (Object VALID)
validateInputObject FieldsDefinition IN schemaS
fieldsDef Object valueS
object =
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (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` FieldsDefinition IN schemaS
fieldsDef) Object valueS
object
    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 c (schemaS :: Stage) (s :: Stage).
ValidateWithDefault c schemaS s =>
Object s
-> FieldDefinition IN schemaS
-> Validator schemaS (InputContext c) (ObjectEntry VALID)
validateWithDefault Object valueS
object) FieldsDefinition IN schemaS
fieldsDef

class ValidateWithDefault c schemaS s where
  validateWithDefault ::
    Object s ->
    FieldDefinition IN schemaS ->
    Validator schemaS (InputContext c) (ObjectEntry VALID)

instance ValidateWithDefault c VALID s where
  validateWithDefault :: Object s
-> FieldDefinition IN VALID
-> Validator VALID (InputContext c) (ObjectEntry VALID)
validateWithDefault Object s
object fieldDef :: FieldDefinition IN VALID
fieldDef@FieldDefinition {FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName} =
    forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
fieldName
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (f :: * -> *) a. Applicative f => a -> f a
pure
        (forall c (schemaS :: Stage) (s :: Stage).
ValidateWithDefault c schemaS s =>
FieldDefinition IN schemaS
-> Value s -> Validator schemaS (InputContext c) ValidValue
validateValueByField FieldDefinition IN VALID
fieldDef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage). ObjectEntry s -> Value s
entryValue)
        FieldDefinition IN VALID
fieldDef
        Object s
object

instance ValidateWithDefault c CONST s where
  validateWithDefault :: Object s
-> FieldDefinition IN 'CONST
-> Validator 'CONST (InputContext c) (ObjectEntry VALID)
validateWithDefault Object s
object fieldDef :: FieldDefinition IN 'CONST
fieldDef@FieldDefinition {FieldName
fieldName :: FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName} =
    forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
fieldName
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 c (schemaS :: Stage) (s :: Stage).
ValidateWithDefault c schemaS s =>
FieldDefinition IN schemaS
-> Value s -> Validator schemaS (InputContext c) ValidValue
validateValueByField FieldDefinition IN 'CONST
fieldDef)
        (forall c (schemaS :: Stage) (s :: Stage).
ValidateWithDefault c schemaS s =>
FieldDefinition IN schemaS
-> Value s -> Validator schemaS (InputContext c) ValidValue
validateValueByField FieldDefinition IN 'CONST
fieldDef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage). ObjectEntry s -> Value s
entryValue)
        FieldDefinition IN 'CONST
fieldDef
        Object s
object

-- Leaf Validations
validateScalar ::
  ScalarDefinition ->
  Value s ->
  InputValidator schemaS ctx ValidValue
validateScalar :: forall (s :: Stage) (schemaS :: Stage) ctx.
ScalarDefinition
-> Value s -> InputValidator schemaS ctx ValidValue
validateScalar ScalarDefinition {ValidValue -> Either Token ValidValue
validateValue :: ScalarDefinition -> ValidValue -> Either Token ValidValue
validateValue :: ValidValue -> Either Token ValidValue
validateValue} Value s
value = do
  TypeName
typeName <- forall (s :: Stage) ctx (m :: * -> *) a.
MonadReader (ValidatorContext s ctx) m =>
(Scope -> a) -> m a
asksScope Scope -> TypeName
currentTypeName
  ValidValue
scalarValue <- forall (s :: Stage) (schemaS :: Stage) ctx.
TypeName -> Value s -> InputValidator schemaS ctx ValidValue
toScalar TypeName
typeName Value s
value
  case ValidValue -> Either Token ValidValue
validateValue ValidValue
scalarValue of
    Right ValidValue
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ValidValue
scalarValue
    Left Token
"" -> forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation forall a. Maybe a
Nothing Value s
value
    Left Token
message -> forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Msg a => a -> GQLError
msg Token
message) Value s
value
  where
    toScalar :: TypeName -> Value s -> InputValidator schemaS ctx ValidValue
    toScalar :: forall (s :: Stage) (schemaS :: Stage) ctx.
TypeName -> Value s -> InputValidator schemaS ctx ValidValue
toScalar TypeName
typeName (Scalar ScalarValue
x) | TypeName -> ScalarValue -> Bool
isValidDefault TypeName
typeName ScalarValue
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (stage :: Stage). ScalarValue -> Value stage
Scalar ScalarValue
x)
    toScalar TypeName
_ Value s
_ = forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation forall a. Maybe a
Nothing Value s
value

isValidDefault :: TypeName -> ScalarValue -> Bool
isValidDefault :: TypeName -> ScalarValue -> Bool
isValidDefault TypeName
"Boolean" = ScalarValue -> Bool
isBoolean
isValidDefault TypeName
"String" = ScalarValue -> Bool
isString
isValidDefault TypeName
"Float" = forall a. [a -> Bool] -> a -> Bool
oneOf [ScalarValue -> Bool
isFloat, ScalarValue -> Bool
isInt]
isValidDefault TypeName
"Int" = ScalarValue -> Bool
isInt
isValidDefault TypeName
"ID" = forall a. [a -> Bool] -> a -> Bool
oneOf [ScalarValue -> Bool
isInt, ScalarValue -> Bool
isFloat, ScalarValue -> Bool
isString]
isValidDefault TypeName
_ = forall a b. a -> b -> a
const Bool
True

oneOf :: [a -> Bool] -> a -> Bool
oneOf :: forall a. [a -> Bool] -> a -> Bool
oneOf [a -> Bool]
ls a
v = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (a
v forall a b. a -> (a -> b) -> b
&) [a -> Bool]
ls

isBoolean :: ScalarValue -> Bool
isBoolean :: ScalarValue -> Bool
isBoolean Boolean {} = Bool
True
isBoolean ScalarValue
_ = Bool
False

isString :: ScalarValue -> Bool
isString :: ScalarValue -> Bool
isString String {} = Bool
True
isString ScalarValue
_ = Bool
False

isFloat :: ScalarValue -> Bool
isFloat :: ScalarValue -> Bool
isFloat Float {} = Bool
True
isFloat ScalarValue
_ = Bool
False

isInt :: ScalarValue -> Bool
isInt :: ScalarValue -> Bool
isInt Int {} = Bool
True
isInt ScalarValue
_ = Bool
False

isVariableValue :: InputValidator schemaS c Bool
isVariableValue :: forall (schemaS :: Stage) c. InputValidator schemaS c Bool
isVariableValue =
  \case
    SourceVariable {Bool
isDefaultValue :: InputSource -> Bool
isDefaultValue :: Bool
isDefaultValue} -> Bool -> Bool
not Bool
isDefaultValue
    InputSource
_ -> Bool
False
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (s :: Stage) c (m :: * -> *).
MonadReader (ValidatorContext s (InputContext c)) m =>
m InputSource
inputValueSource

validateEnum ::
  [DataEnumValue s] ->
  Value valueS ->
  InputValidator schemaS c ValidValue
validateEnum :: forall (s :: Stage) (valueS :: Stage) (schemaS :: Stage) c.
[DataEnumValue s]
-> Value valueS -> InputValidator schemaS c ValidValue
validateEnum [DataEnumValue s]
enumValues value :: Value valueS
value@(Scalar (String Token
enumValue))
  | forall a (t :: NAME). NamePacking a => a -> Name t
packName Token
enumValue forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TypeName]
tags = do
      Bool
isFromVariable <- forall (schemaS :: Stage) c. InputValidator schemaS c Bool
isVariableValue
      if Bool
isFromVariable
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (stage :: Stage). TypeName -> Value stage
Enum (forall a (t :: NAME). NamePacking a => a -> Name t
packName Token
enumValue))
        else forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation forall a. Maybe a
Nothing Value valueS
value
  where
    tags :: [TypeName]
tags = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (s :: Stage). DataEnumValue s -> TypeName
enumName [DataEnumValue s]
enumValues
validateEnum [DataEnumValue s]
enumValues value :: Value valueS
value@(Enum TypeName
enumValue)
  | TypeName
enumValue forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TypeName]
tags = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (stage :: Stage). TypeName -> Value stage
Enum TypeName
enumValue)
  | Bool
otherwise = forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation forall a. Maybe a
Nothing Value valueS
value
  where
    tags :: [TypeName]
tags = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (s :: Stage). DataEnumValue s -> TypeName
enumName [DataEnumValue s]
enumValues
validateEnum [DataEnumValue s]
_ Value valueS
value = forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation forall a. Maybe a
Nothing Value valueS
value