{-# 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 :: Maybe Position
position :: Scope -> Maybe Position
position,
      TypeName
currentTypeName :: TypeName
currentTypeName :: Scope -> TypeName
currentTypeName,
      TypeWrapper
currentTypeWrappers :: TypeWrapper
currentTypeWrappers :: Scope -> TypeWrapper
currentTypeWrappers
    } <-
    (Scope -> Scope) -> Validator schemaS (InputContext ctx) Scope
forall (s :: Stage) ctx (m :: * -> *) a.
MonadReader (ValidatorContext s ctx) m =>
(Scope -> a) -> m a
asksScope Scope -> Scope
forall a. a -> a
id
  GQLError
prefix <- InputValidator schemaS ctx GQLError
forall (s :: Stage) ctx. InputValidator s ctx GQLError
inputMessagePrefix
  GQLError -> InputValidator schemaS ctx a
forall a. GQLError -> Validator schemaS (InputContext ctx) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> InputValidator schemaS ctx a)
-> GQLError -> InputValidator schemaS ctx a
forall a b. (a -> b) -> a -> b
$
    ( GQLError
prefix
        GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeRef -> Value s -> GQLError
forall (s :: Stage). TypeRef -> Value s -> GQLError
typeViolation
          (TypeName -> TypeWrapper -> TypeRef
TypeRef TypeName
currentTypeName TypeWrapper
currentTypeWrappers)
          Value s
value
        GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError -> (GQLError -> GQLError) -> Maybe GQLError -> GQLError
forall b a. b -> (a -> b) -> Maybe a -> b
maybe GQLError
"" (GQLError
" " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<>) Maybe GQLError
message
    )
      GQLError -> Maybe Position -> GQLError
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 :: TypeRef
variableType :: forall (stage :: Stage). Variable stage -> TypeRef
variableType}
  | TypeRef
variableType TypeRef -> TypeRef -> Bool
forall t. Subtyping t => t -> t -> Bool
`isSubtype` TypeRef
valueType = ValidValue -> Validator schemaS (InputContext ctx) ValidValue
forall a. a -> Validator schemaS (InputContext ctx) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValidValue
value
  | Bool
otherwise = GQLError -> Validator schemaS (InputContext ctx) ValidValue
forall a. GQLError -> Validator schemaS (InputContext ctx) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> Validator schemaS (InputContext ctx) ValidValue)
-> GQLError -> Validator schemaS (InputContext ctx) ValidValue
forall a b. (a -> b) -> a -> b
$ Ref FieldName -> Variable VALID -> TypeRef -> GQLError
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 <- Typed IN schemaS TypeRef
-> Validator schemaS (InputContext c) (TypeDefinition IN schemaS)
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
    TypeWrapper
-> TypeDefinition IN schemaS
-> Value s
-> Validator schemaS (InputContext c) ValidValue
forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
TypeWrapper
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
validateInputByType
      ((TypeRef -> TypeWrapper) -> Typed IN schemaS TypeRef -> TypeWrapper
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 =
  FieldDefinition IN schemaS
-> InputValidator schemaS c ValidValue
-> InputValidator schemaS c ValidValue
forall (s :: Stage) c a.
FieldDefinition IN s
-> InputValidator s c a -> InputValidator s c a
inField FieldDefinition IN schemaS
field
    (InputValidator schemaS c ValidValue
 -> InputValidator schemaS c ValidValue)
-> (Value s -> InputValidator schemaS c ValidValue)
-> Value s
-> InputValidator schemaS c ValidValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typed IN schemaS TypeRef
-> Value s -> InputValidator schemaS c ValidValue
forall c (schemaS :: Stage) (s :: Stage).
ValidateWithDefault c schemaS s =>
Typed IN schemaS TypeRef
-> Value s -> Validator schemaS (InputContext c) ValidValue
validateInputByTypeRef
      ((FieldDefinition IN schemaS -> TypeRef)
-> FieldDefinition IN schemaS -> Typed IN schemaS TypeRef
forall (a :: TypeCategory -> Stage -> *) (c :: TypeCategory)
       (s :: Stage) b.
(a c s -> b) -> a c s -> Typed c s b
typed FieldDefinition IN schemaS -> TypeRef
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 =
  (Scope -> Scope)
-> Validator schemaS (InputContext ctx) ValidValue
-> Validator schemaS (InputContext ctx) ValidValue
forall (s :: Stage) c (m :: * -> *) b.
MonadReader (ValidatorContext s c) m =>
(Scope -> Scope) -> m b -> m b
withScope (TypeDefinition IN schemaS -> TypeWrapper -> Scope -> Scope
forall (c :: TypeCategory) (s :: Stage).
TypeDefinition c s -> TypeWrapper -> Scope -> Scope
setType TypeDefinition IN schemaS
typeDef TypeWrapper
tyWrappers) (Validator schemaS (InputContext ctx) ValidValue
 -> Validator schemaS (InputContext ctx) ValidValue)
-> (Value valueS
    -> Validator schemaS (InputContext ctx) ValidValue)
-> Value valueS
-> Validator schemaS (InputContext ctx) ValidValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeWrapper
-> TypeDefinition IN schemaS
-> Value valueS
-> Validator schemaS (InputContext ctx) ValidValue
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 <- (Scope -> TypeName)
-> Validator schemaS (InputContext ctx) TypeName
forall (s :: Stage) ctx (m :: * -> *) a.
MonadReader (ValidatorContext s ctx) m =>
(Scope -> a) -> m a
asksScope Scope -> TypeName
currentTypeName
  TypeRef
-> Ref FieldName
-> Variable VALID
-> InputValidator schemaS ctx ValidValue
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
  | TypeWrapper -> Bool
forall a. Nullable a => a -> Bool
isNullable TypeWrapper
wrappers = ValidValue -> InputValidator schemaS ctx ValidValue
forall a. a -> Validator schemaS (InputContext ctx) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValidValue
forall (stage :: Stage). Value stage
Null
  | Bool
otherwise = Maybe GQLError
-> Value Any -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation Maybe GQLError
forall a. Maybe a
Nothing Value Any
forall (stage :: Stage). Value stage
Null
-- Validate LIST

validateWrapped (TypeList TypeWrapper
wrappers Bool
_) TypeDefinition IN schemaS
tyCont (List [Value valueS]
list) =
  [ValidValue] -> ValidValue
forall (stage :: Stage). [Value stage] -> Value stage
List ([ValidValue] -> ValidValue)
-> Validator schemaS (InputContext ctx) [ValidValue]
-> InputValidator schemaS ctx ValidValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value valueS -> InputValidator schemaS ctx ValidValue)
-> [Value valueS]
-> Validator schemaS (InputContext ctx) [ValidValue]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (TypeWrapper
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
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 =
  [ValidValue] -> ValidValue
forall (stage :: Stage). [Value stage] -> Value stage
List ([ValidValue] -> ValidValue)
-> (ValidValue -> [ValidValue]) -> ValidValue -> ValidValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidValue -> [ValidValue]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValidValue -> ValidValue)
-> InputValidator schemaS ctx ValidValue
-> InputValidator schemaS ctx ValidValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeWrapper
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
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 :: TypeContent TRUE IN schemaS
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent} Value valueS
entryValue =
  TypeContent TRUE IN schemaS
-> Value valueS -> InputValidator schemaS ctx ValidValue
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) =
  Object VALID -> ValidValue
forall (stage :: Stage). Object stage -> Value stage
Object (Object VALID -> ValidValue)
-> Validator schemaS (InputContext ctx) (Object VALID)
-> Validator schemaS (InputContext ctx) ValidValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldsDefinition IN schemaS
-> Object valueS
-> Validator schemaS (InputContext ctx) (Object VALID)
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) =
  UnionTypeDefinition IN schemaS
-> Object valueS -> Validator schemaS (InputContext ctx) ValidValue
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 =
  DataEnum schemaS
-> Value valueS -> Validator schemaS (InputContext ctx) ValidValue
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 =
  ScalarDefinition
-> Value valueS -> Validator schemaS (InputContext ctx) ValidValue
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 = Maybe GQLError
-> Value valueS -> Validator schemaS (InputContext ctx) ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation Maybe GQLError
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 UnionTypeDefinition IN schemaS
-> Object s -> Either GQLError (UnionMember IN schemaS, Value s)
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 -> Maybe GQLError -> Value s -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation (GQLError -> Maybe GQLError
forall a. a -> Maybe a
Just (GQLError -> Maybe GQLError) -> GQLError -> Maybe GQLError
forall a b. (a -> b) -> a -> b
$ GQLError -> GQLError
forall a. Msg a => a -> GQLError
msg GQLError
message) (Object s -> Value s
forall (stage :: Stage). Object stage -> Value stage
Object Object s
rawFields)
    Right (UnionMember IN schemaS
name, Value s
value) -> UnionMember IN schemaS
-> Value s -> InputValidator schemaS ctx ValidValue
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
  UnionMember IN schemaS -> ValidValue -> ValidValue
forall (s' :: Stage) (s :: Stage).
UnionMember IN s' -> Value s -> Value s
mkInputUnionValue UnionMember IN schemaS
member (ValidValue -> ValidValue)
-> InputValidator schemaS ctx ValidValue
-> InputValidator schemaS ctx ValidValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeWrapper
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
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
      | UnionMember IN schemaS -> Bool
forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> Bool
nullary UnionMember IN schemaS
member = Typed IN schemaS TypeRef
-> Validator schemaS (InputContext ctx) (TypeDefinition IN schemaS)
forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx.
Constraints m c cat s ctx =>
Typed cat s TypeRef -> m (TypeDefinition cat s)
askType (TypeRef -> Typed IN schemaS TypeRef
forall (cat :: TypeCategory) (s :: Stage) a. a -> Typed cat s a
Typed (TypeRef -> Typed IN schemaS TypeRef)
-> TypeRef -> Typed IN schemaS TypeRef
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeRef
mkTypeRef TypeName
unitTypeName)
      | Bool
otherwise = TypeDefinition INPUT_OBJECT schemaS -> TypeDefinition IN schemaS
forall (s :: Stage).
TypeDefinition INPUT_OBJECT s -> TypeDefinition IN s
forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (k' :: TypeCategory) (s :: Stage).
ToCategory a k k' =>
a k s -> a k' s
toCategory (TypeDefinition INPUT_OBJECT schemaS -> TypeDefinition IN schemaS)
-> Validator
     schemaS (InputContext ctx) (TypeDefinition INPUT_OBJECT schemaS)
-> Validator schemaS (InputContext ctx) (TypeDefinition IN schemaS)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnionMember IN schemaS
-> Validator
     schemaS (InputContext ctx) (TypeDefinition (ToOBJECT IN) schemaS)
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 :: TypeName
memberName :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName,
      Bool
nullary :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> Bool
nullary :: Bool
nullary
    } = Object s -> Value s
forall (stage :: Stage). Object stage -> Value stage
Object (Object s -> Value s)
-> (Value s -> Object s) -> Value s -> Value s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> ObjectEntry s -> Object s
forall a. FieldName -> a -> OrdMap FieldName a
forall k (m :: * -> *) a. IsMap k m => k -> a -> m a
singleton FieldName
key (ObjectEntry s -> Object s)
-> (Value s -> ObjectEntry s) -> Value s -> Object s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Value s -> ObjectEntry s
forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
key (Value s -> ObjectEntry s)
-> (Value s -> Value s) -> Value s -> ObjectEntry s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value s -> Value s
packNullary
    where
      key :: FieldName
key = TypeName -> FieldName
forall a b. Coercible a b => a -> b
coerce TypeName
memberName
      packNullary :: Value s -> Value s
packNullary
        | Bool
nullary = Object s -> Value s
forall (stage :: Stage). Object stage -> Value stage
Object (Object s -> Value s)
-> (Value s -> Object s) -> Value s -> Value s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> ObjectEntry s -> Object s
forall a. FieldName -> a -> OrdMap FieldName a
forall k (m :: * -> *) a. IsMap k m => k -> a -> m a
singleton FieldName
unitFieldName (ObjectEntry s -> Object s)
-> (Value s -> ObjectEntry s) -> Value s -> Object s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Value s -> ObjectEntry s
forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
unitFieldName
        | Bool
otherwise = Value s -> Value s
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 =
  (ObjectEntry valueS
 -> Validator
      schemaS (InputContext ctx) (FieldDefinition IN schemaS))
-> Object valueS -> Validator schemaS (InputContext ctx) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (ObjectEntry valueS
-> FieldsDefinition IN schemaS
-> Validator
     schemaS (InputContext ctx) (FieldDefinition IN schemaS)
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
    Validator schemaS (InputContext ctx) ()
-> Validator schemaS (InputContext ctx) (Object VALID)
-> Validator schemaS (InputContext ctx) (Object VALID)
forall a b.
Validator schemaS (InputContext ctx) a
-> Validator schemaS (InputContext ctx) b
-> Validator schemaS (InputContext ctx) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (FieldDefinition IN schemaS
 -> Validator schemaS (InputContext ctx) (ObjectEntry VALID))
-> FieldsDefinition IN schemaS
-> Validator schemaS (InputContext ctx) (Object VALID)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> OrdMap FieldName a -> f (OrdMap FieldName b)
traverse (Object valueS
-> FieldDefinition IN schemaS
-> Validator schemaS (InputContext ctx) (ObjectEntry VALID)
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 :: FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName} =
    FieldName -> ValidValue -> ObjectEntry VALID
forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
fieldName
      (ValidValue -> ObjectEntry VALID)
-> Validator VALID (InputContext c) ValidValue
-> Validator VALID (InputContext c) (ObjectEntry VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ValidValue -> Validator VALID (InputContext c) ValidValue)
-> (ObjectEntry s -> Validator VALID (InputContext c) ValidValue)
-> FieldDefinition IN VALID
-> Object s
-> Validator VALID (InputContext c) ValidValue
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
        ValidValue -> Validator VALID (InputContext c) ValidValue
forall a. a -> Validator VALID (InputContext c) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (FieldDefinition IN VALID
-> Value s -> Validator VALID (InputContext c) ValidValue
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 (Value s -> Validator VALID (InputContext c) ValidValue)
-> (ObjectEntry s -> Value s)
-> ObjectEntry s
-> Validator VALID (InputContext c) ValidValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectEntry s -> Value s
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 :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName} =
    FieldName -> ValidValue -> ObjectEntry VALID
forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
fieldName
      (ValidValue -> ObjectEntry VALID)
-> Validator 'CONST (InputContext c) ValidValue
-> Validator 'CONST (InputContext c) (ObjectEntry VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value 'CONST -> Validator 'CONST (InputContext c) ValidValue)
-> (ObjectEntry s -> Validator 'CONST (InputContext c) ValidValue)
-> FieldDefinition IN 'CONST
-> Object s
-> Validator 'CONST (InputContext c) ValidValue
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
        (FieldDefinition IN 'CONST
-> Value 'CONST -> Validator 'CONST (InputContext c) ValidValue
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)
        (FieldDefinition IN 'CONST
-> Value s -> Validator 'CONST (InputContext c) ValidValue
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 (Value s -> Validator 'CONST (InputContext c) ValidValue)
-> (ObjectEntry s -> Value s)
-> ObjectEntry s
-> Validator 'CONST (InputContext c) ValidValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectEntry s -> Value s
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 :: ValidValue -> Either Token ValidValue
validateValue :: ScalarDefinition -> ValidValue -> Either Token ValidValue
validateValue} Value s
value = do
  TypeName
typeName <- (Scope -> TypeName)
-> Validator schemaS (InputContext ctx) TypeName
forall (s :: Stage) ctx (m :: * -> *) a.
MonadReader (ValidatorContext s ctx) m =>
(Scope -> a) -> m a
asksScope Scope -> TypeName
currentTypeName
  ValidValue
scalarValue <- TypeName -> Value s -> InputValidator schemaS ctx ValidValue
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
_ -> ValidValue -> InputValidator schemaS ctx ValidValue
forall a. a -> Validator schemaS (InputContext ctx) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValidValue
scalarValue
    Left Token
"" -> Maybe GQLError -> Value s -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation Maybe GQLError
forall a. Maybe a
Nothing Value s
value
    Left Token
message -> Maybe GQLError -> Value s -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation (GQLError -> Maybe GQLError
forall a. a -> Maybe a
Just (GQLError -> Maybe GQLError) -> GQLError -> Maybe GQLError
forall a b. (a -> b) -> a -> b
$ Token -> GQLError
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 = ValidValue -> Validator schemaS (InputContext ctx) ValidValue
forall a. a -> Validator schemaS (InputContext ctx) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScalarValue -> ValidValue
forall (stage :: Stage). ScalarValue -> Value stage
Scalar ScalarValue
x)
    toScalar TypeName
_ Value s
_ = Maybe GQLError
-> Value s -> Validator schemaS (InputContext ctx) ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation Maybe GQLError
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" = [ScalarValue -> Bool] -> ScalarValue -> Bool
forall a. [a -> Bool] -> a -> Bool
oneOf [ScalarValue -> Bool
isFloat, ScalarValue -> Bool
isInt]
isValidDefault TypeName
"Int" = ScalarValue -> Bool
isInt
isValidDefault TypeName
"ID" = [ScalarValue -> Bool] -> ScalarValue -> Bool
forall a. [a -> Bool] -> a -> Bool
oneOf [ScalarValue -> Bool
isInt, ScalarValue -> Bool
isFloat, ScalarValue -> Bool
isString]
isValidDefault TypeName
_ = Bool -> ScalarValue -> Bool
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 = ((a -> Bool) -> Bool) -> [a -> Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (a
v a -> (a -> Bool) -> Bool
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 :: Bool
isDefaultValue :: InputSource -> Bool
isDefaultValue} -> Bool -> Bool
not Bool
isDefaultValue
    InputSource
_ -> Bool
False
    (InputSource -> Bool)
-> Validator schemaS (InputContext c) InputSource
-> Validator schemaS (InputContext c) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Validator schemaS (InputContext c) InputSource
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))
  | Token -> TypeName
forall a (t :: NAME). NamePacking a => a -> Name t
forall (t :: NAME). Token -> Name t
packName Token
enumValue TypeName -> [TypeName] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TypeName]
tags = do
      Bool
isFromVariable <- InputValidator schemaS c Bool
forall (schemaS :: Stage) c. InputValidator schemaS c Bool
isVariableValue
      if Bool
isFromVariable
        then ValidValue -> InputValidator schemaS c ValidValue
forall a. a -> Validator schemaS (InputContext c) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeName -> ValidValue
forall (stage :: Stage). TypeName -> Value stage
Enum (Token -> TypeName
forall a (t :: NAME). NamePacking a => a -> Name t
forall (t :: NAME). Token -> Name t
packName Token
enumValue))
        else Maybe GQLError
-> Value valueS -> InputValidator schemaS c ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation Maybe GQLError
forall a. Maybe a
Nothing Value valueS
value
  where
    tags :: [TypeName]
tags = (DataEnumValue s -> TypeName) -> [DataEnumValue s] -> [TypeName]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DataEnumValue s -> TypeName
forall (s :: Stage). DataEnumValue s -> TypeName
enumName [DataEnumValue s]
enumValues
validateEnum [DataEnumValue s]
enumValues value :: Value valueS
value@(Enum TypeName
enumValue)
  | TypeName
enumValue TypeName -> [TypeName] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TypeName]
tags = ValidValue -> InputValidator schemaS c ValidValue
forall a. a -> Validator schemaS (InputContext c) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeName -> ValidValue
forall (stage :: Stage). TypeName -> Value stage
Enum TypeName
enumValue)
  | Bool
otherwise = Maybe GQLError
-> Value valueS -> InputValidator schemaS c ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation Maybe GQLError
forall a. Maybe a
Nothing Value valueS
value
  where
    tags :: [TypeName]
tags = (DataEnumValue s -> TypeName) -> [DataEnumValue s] -> [TypeName]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DataEnumValue s -> TypeName
forall (s :: Stage). DataEnumValue s -> TypeName
enumName [DataEnumValue s]
enumValues
validateEnum [DataEnumValue s]
_ Value valueS
value = Maybe GQLError
-> Value valueS -> InputValidator schemaS c ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation Maybe GQLError
forall a. Maybe a
Nothing Value valueS
value