{-# 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
  { Prop -> FieldName
propName :: FieldName,
    Prop -> TypeName
propTypeName :: TypeName
  }
  deriving (Int -> Prop -> ShowS
[Prop] -> ShowS
Prop -> String
(Int -> Prop -> ShowS)
-> (Prop -> String) -> ([Prop] -> ShowS) -> Show Prop
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Prop] -> ShowS
$cshowList :: [Prop] -> ShowS
show :: Prop -> String
$cshow :: Prop -> String
showsPrec :: Int -> Prop -> ShowS
$cshowsPrec :: Int -> Prop -> ShowS
Show)

type Path = [Prop]

renderPath :: Path -> GQLError
renderPath :: [Prop] -> GQLError
renderPath [] = GQLError
""
renderPath [Prop]
path = GQLError
"in field " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> Name Any -> GQLError
forall a. Msg a => a -> GQLError
msg (Name Any -> [FieldName] -> Name Any
forall (t1 :: NAME) (t2 :: NAME) (t3 :: NAME).
Name t1 -> [Name t2] -> Name t3
intercalate Name Any
"." ([FieldName] -> Name Any) -> [FieldName] -> Name Any
forall a b. (a -> b) -> a -> b
$ (Prop -> FieldName) -> [Prop] -> [FieldName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Prop -> FieldName
propName [Prop]
path) GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
": "

renderInputPrefix :: InputContext c -> GQLError
renderInputPrefix :: InputContext c -> GQLError
renderInputPrefix InputContext {[Prop]
inputPath :: forall ctx. InputContext ctx -> [Prop]
inputPath :: [Prop]
inputPath, InputSource
inputSource :: forall ctx. InputContext ctx -> InputSource
inputSource :: InputSource
inputSource} =
  InputSource -> GQLError
renderSource InputSource
inputSource GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> [Prop] -> GQLError
renderPath [Prop]
inputPath

renderSource :: InputSource -> GQLError
renderSource :: InputSource -> GQLError
renderSource (SourceArgument FieldName
argumentName) =
  GQLError
"Argument " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> FieldName -> GQLError
forall a. Msg a => a -> GQLError
msg FieldName
argumentName GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" got invalid value. "
renderSource (SourceVariable Variable {FieldName
variableName :: forall (stage :: Stage). Variable stage -> FieldName
variableName :: FieldName
variableName} Bool
_) =
  GQLError
"Variable " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> FieldName -> GQLError
forall a. Msg a => a -> GQLError
msg (FieldName
"$" FieldName -> FieldName -> FieldName
forall a. Semigroup a => a -> a -> a
<> FieldName
variableName) GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" got invalid value. "
renderSource SourceInputField {TypeName
sourceTypeName :: InputSource -> TypeName
sourceTypeName :: TypeName
sourceTypeName, FieldName
sourceFieldName :: InputSource -> FieldName
sourceFieldName :: FieldName
sourceFieldName, Maybe FieldName
sourceArgumentName :: InputSource -> Maybe FieldName
sourceArgumentName :: Maybe FieldName
sourceArgumentName} =
  GQLError
"Field " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> FieldName -> Maybe FieldName -> GQLError
renderField TypeName
sourceTypeName FieldName
sourceFieldName Maybe FieldName
sourceArgumentName GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" got invalid default value. "

renderField :: TypeName -> FieldName -> Maybe FieldName -> GQLError
renderField :: TypeName -> FieldName -> Maybe FieldName -> GQLError
renderField TypeName
tName FieldName
fName Maybe FieldName
arg =
  Text -> GQLError
forall a. Msg a => a -> GQLError
msg (TypeName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
tName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FieldName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
unpackName FieldName
fName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe FieldName -> Text
forall p (t :: NAME).
(Semigroup p, IsString p, NamePacking p) =>
Maybe (Name t) -> p
renderArg Maybe FieldName
arg :: Text)
  where
    renderArg :: Maybe (Name t) -> p
renderArg (Just Name t
argName) = p
"(" p -> p -> p
forall a. Semigroup a => a -> a -> a
<> Name t -> p
forall a (t :: NAME). NamePacking a => Name t -> a
unpackName Name t
argName p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
":)"
    renderArg Maybe (Name t)
Nothing = p
""

data OperationContext (s1 :: Stage) (s2 :: Stage) = OperationContext
  { OperationContext s1 s2 -> Fragments s2
fragments :: Fragments s2,
    OperationContext s1 s2 -> VariableDefinitions s1
variables :: VariableDefinitions s1,
    OperationContext s1 s2 -> Maybe FieldName
operationName :: Maybe FieldName
  }
  deriving (Int -> OperationContext s1 s2 -> ShowS
[OperationContext s1 s2] -> ShowS
OperationContext s1 s2 -> String
(Int -> OperationContext s1 s2 -> ShowS)
-> (OperationContext s1 s2 -> String)
-> ([OperationContext s1 s2] -> ShowS)
-> Show (OperationContext s1 s2)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s1 :: Stage) (s2 :: Stage).
Int -> OperationContext s1 s2 -> ShowS
forall (s1 :: Stage) (s2 :: Stage).
[OperationContext s1 s2] -> ShowS
forall (s1 :: Stage) (s2 :: Stage).
OperationContext s1 s2 -> String
showList :: [OperationContext s1 s2] -> ShowS
$cshowList :: forall (s1 :: Stage) (s2 :: Stage).
[OperationContext s1 s2] -> ShowS
show :: OperationContext s1 s2 -> String
$cshow :: forall (s1 :: Stage) (s2 :: Stage).
OperationContext s1 s2 -> String
showsPrec :: Int -> OperationContext s1 s2 -> ShowS
$cshowsPrec :: forall (s1 :: Stage) (s2 :: Stage).
Int -> OperationContext s1 s2 -> ShowS
Show)

data InputContext ctx = InputContext
  { InputContext ctx -> InputSource
inputSource :: InputSource,
    InputContext ctx -> [Prop]
inputPath :: [Prop],
    InputContext ctx -> ctx
sourceContext :: ctx
  }
  deriving (Int -> InputContext ctx -> ShowS
[InputContext ctx] -> ShowS
InputContext ctx -> String
(Int -> InputContext ctx -> ShowS)
-> (InputContext ctx -> String)
-> ([InputContext ctx] -> ShowS)
-> Show (InputContext ctx)
forall ctx. Show ctx => Int -> InputContext ctx -> ShowS
forall ctx. Show ctx => [InputContext ctx] -> ShowS
forall ctx. Show ctx => InputContext ctx -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InputContext ctx] -> ShowS
$cshowList :: forall ctx. Show ctx => [InputContext ctx] -> ShowS
show :: InputContext ctx -> String
$cshow :: forall ctx. Show ctx => InputContext ctx -> String
showsPrec :: Int -> InputContext ctx -> ShowS
$cshowsPrec :: forall ctx. Show ctx => Int -> InputContext ctx -> ShowS
Show)

data InputSource
  = SourceArgument FieldName
  | SourceVariable
      { InputSource -> Variable RAW
sourceVariable :: Variable RAW,
        InputSource -> Bool
isDefaultValue :: Bool
      }
  | SourceInputField
      { InputSource -> TypeName
sourceTypeName :: TypeName,
        InputSource -> FieldName
sourceFieldName :: FieldName,
        InputSource -> Maybe FieldName
sourceArgumentName :: Maybe FieldName
      }
  deriving (Int -> InputSource -> ShowS
[InputSource] -> ShowS
InputSource -> String
(Int -> InputSource -> ShowS)
-> (InputSource -> String)
-> ([InputSource] -> ShowS)
-> Show InputSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InputSource] -> ShowS
$cshowList :: [InputSource] -> ShowS
show :: InputSource -> String
$cshow :: InputSource -> String
showsPrec :: Int -> InputSource -> ShowS
$cshowsPrec :: Int -> InputSource -> ShowS
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 IN s
-> InputValidator s c a -> InputValidator s c a
inField
  FieldDefinition
    { FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName,
      fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType = TypeRef {TypeName
typeConName :: TypeRef -> TypeName
typeConName :: TypeName
typeConName}
    } = (InputContext c -> InputContext c)
-> InputValidator s c a -> InputValidator s c a
forall c' c (s :: Stage) a.
(c' -> c) -> Validator s c a -> Validator s c' a
withContext InputContext c -> InputContext c
update
    where
      update :: InputContext c -> InputContext c
update
        InputContext
          { inputPath :: forall ctx. InputContext ctx -> [Prop]
inputPath = [Prop]
old,
            c
InputSource
sourceContext :: c
inputSource :: InputSource
sourceContext :: forall ctx. InputContext ctx -> ctx
inputSource :: forall ctx. InputContext ctx -> InputSource
..
          } =
          InputContext :: forall ctx. InputSource -> [Prop] -> ctx -> InputContext ctx
InputContext
            { inputPath :: [Prop]
inputPath = [Prop]
old [Prop] -> [Prop] -> [Prop]
forall a. Semigroup a => a -> a -> a
<> [FieldName -> TypeName -> Prop
Prop FieldName
fieldName TypeName
typeConName],
              c
InputSource
sourceContext :: c
inputSource :: InputSource
sourceContext :: c
inputSource :: InputSource
..
            }

inputValueSource :: MonadReader (ValidatorContext s (InputContext c)) m => m InputSource
inputValueSource :: m InputSource
inputValueSource = (InputContext c -> InputSource) -> m InputSource
forall (s :: Stage) c (m :: * -> *) a.
MonadReader (ValidatorContext s c) m =>
(c -> a) -> m a
asksLocal InputContext c -> InputSource
forall ctx. InputContext ctx -> InputSource
inputSource

asksScope :: MonadReader (ValidatorContext s ctx) m => (Scope -> a) -> m a
asksScope :: (Scope -> a) -> m a
asksScope Scope -> a
f = (ValidatorContext s ctx -> a) -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Scope -> a
f (Scope -> a)
-> (ValidatorContext s ctx -> Scope) -> ValidatorContext s ctx -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatorContext s ctx -> Scope
forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
scope)

askTypeDefinitions ::
  MonadReader (ValidatorContext s ctx) m =>
  m (HashMap TypeName (TypeDefinition ANY s))
askTypeDefinitions :: m (HashMap TypeName (TypeDefinition ANY s))
askTypeDefinitions = (ValidatorContext s ctx -> HashMap TypeName (TypeDefinition ANY s))
-> m (HashMap TypeName (TypeDefinition ANY s))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Schema s -> HashMap TypeName (TypeDefinition ANY s)
forall (s :: Stage).
Schema s -> HashMap TypeName (TypeDefinition ANY s)
typeDefinitions (Schema s -> HashMap TypeName (TypeDefinition ANY s))
-> (ValidatorContext s ctx -> Schema s)
-> ValidatorContext s ctx
-> HashMap TypeName (TypeDefinition ANY s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatorContext s ctx -> Schema s
forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
schema)

askVariables :: MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m => m (VariableDefinitions s2)
askVariables :: m (VariableDefinitions s2)
askVariables = (OperationContext s2 s3 -> VariableDefinitions s2)
-> m (VariableDefinitions s2)
forall (s :: Stage) c (m :: * -> *) a.
MonadReader (ValidatorContext s c) m =>
(c -> a) -> m a
asksLocal OperationContext s2 s3 -> VariableDefinitions s2
forall (s1 :: Stage) (s2 :: Stage).
OperationContext s1 s2 -> VariableDefinitions s1
variables

askFragments :: MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m => m (Fragments s3)
askFragments :: m (Fragments s3)
askFragments = (OperationContext s2 s3 -> Fragments s3) -> m (Fragments s3)
forall (s :: Stage) c (m :: * -> *) a.
MonadReader (ValidatorContext s c) m =>
(c -> a) -> m a
asksLocal OperationContext s2 s3 -> Fragments s3
forall (s1 :: Stage) (s2 :: Stage).
OperationContext s1 s2 -> Fragments s2
fragments

runValidator :: Validator s ctx a -> Config -> Schema s -> Scope -> ctx -> GQLResult a
runValidator :: Validator s ctx a
-> Config -> Schema s -> Scope -> ctx -> GQLResult a
runValidator (Validator ReaderT (ValidatorContext s ctx) GQLResult a
x) Config
config Schema s
schema Scope
scope ctx
localContext =
  ReaderT (ValidatorContext s ctx) GQLResult a
-> ValidatorContext s ctx -> GQLResult a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (ValidatorContext s ctx) GQLResult a
x ValidatorContext :: forall (s :: Stage) ctx.
Scope -> Schema s -> ctx -> Config -> ValidatorContext s ctx
ValidatorContext {ctx
Schema s
Config
Scope
config :: Config
localContext :: ctx
localContext :: ctx
scope :: Scope
schema :: Schema s
config :: Config
schema :: Schema s
scope :: Scope
..}

withContext :: (c' -> c) -> Validator s c a -> Validator s c' a
withContext :: (c' -> c) -> Validator s c a -> Validator s c' a
withContext c' -> c
f = ReaderT (ValidatorContext s c') GQLResult a -> Validator s c' a
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
Validator (ReaderT (ValidatorContext s c') GQLResult a -> Validator s c' a)
-> (Validator s c a -> ReaderT (ValidatorContext s c') GQLResult a)
-> Validator s c a
-> Validator s c' a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValidatorContext s c' -> ValidatorContext s c)
-> ReaderT (ValidatorContext s c) GQLResult a
-> ReaderT (ValidatorContext s c') GQLResult a
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT ((c' -> c) -> ValidatorContext s c' -> ValidatorContext s c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c' -> c
f) (ReaderT (ValidatorContext s c) GQLResult a
 -> ReaderT (ValidatorContext s c') GQLResult a)
-> (Validator s c a -> ReaderT (ValidatorContext s c) GQLResult a)
-> Validator s c a
-> ReaderT (ValidatorContext s c') GQLResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validator s c a -> ReaderT (ValidatorContext s c) GQLResult a
forall (s :: Stage) ctx a.
Validator s ctx a -> ReaderT (ValidatorContext s ctx) GQLResult a
_runValidator

inputMessagePrefix :: InputValidator s ctx GQLError
inputMessagePrefix :: InputValidator s ctx GQLError
inputMessagePrefix =
  InputContext ctx -> GQLError
forall c. InputContext c -> GQLError
renderInputPrefix
    (InputContext ctx -> GQLError)
-> (ValidatorContext s (InputContext ctx) -> InputContext ctx)
-> ValidatorContext s (InputContext ctx)
-> GQLError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatorContext s (InputContext ctx) -> InputContext ctx
forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
localContext
    (ValidatorContext s (InputContext ctx) -> GQLError)
-> Validator
     s (InputContext ctx) (ValidatorContext s (InputContext ctx))
-> InputValidator s ctx GQLError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  (ValidatorContext s (InputContext ctx))
  GQLResult
  (ValidatorContext s (InputContext ctx))
-> Validator
     s (InputContext ctx) (ValidatorContext s (InputContext ctx))
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
Validator ReaderT
  (ValidatorContext s (InputContext ctx))
  GQLResult
  (ValidatorContext s (InputContext ctx))
forall r (m :: * -> *). MonadReader r m => m r
ask

startInput :: InputSource -> InputValidator s ctx a -> Validator s ctx a
startInput :: InputSource -> InputValidator s ctx a -> Validator s ctx a
startInput InputSource
inputSource = (ctx -> InputContext ctx)
-> InputValidator s ctx a -> Validator s ctx a
forall c' c (s :: Stage) a.
(c' -> c) -> Validator s c a -> Validator s c' a
withContext ctx -> InputContext ctx
update
  where
    update :: ctx -> InputContext ctx
update ctx
sourceContext =
      InputContext :: forall ctx. InputSource -> [Prop] -> ctx -> InputContext ctx
InputContext
        { InputSource
inputSource :: InputSource
inputSource :: InputSource
inputSource,
          inputPath :: [Prop]
inputPath = [],
          ctx
sourceContext :: ctx
sourceContext :: ctx
sourceContext
        }

data ValidatorContext (s :: Stage) (ctx :: Type) = ValidatorContext
  { ValidatorContext s ctx -> Scope
scope :: Scope,
    ValidatorContext s ctx -> Schema s
schema :: Schema s,
    ValidatorContext s ctx -> ctx
localContext :: ctx,
    ValidatorContext s ctx -> Config
config :: Config
  }
  deriving
    ( Int -> ValidatorContext s ctx -> ShowS
[ValidatorContext s ctx] -> ShowS
ValidatorContext s ctx -> String
(Int -> ValidatorContext s ctx -> ShowS)
-> (ValidatorContext s ctx -> String)
-> ([ValidatorContext s ctx] -> ShowS)
-> Show (ValidatorContext s ctx)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: Stage) ctx.
Show ctx =>
Int -> ValidatorContext s ctx -> ShowS
forall (s :: Stage) ctx.
Show ctx =>
[ValidatorContext s ctx] -> ShowS
forall (s :: Stage) ctx.
Show ctx =>
ValidatorContext s ctx -> String
showList :: [ValidatorContext s ctx] -> ShowS
$cshowList :: forall (s :: Stage) ctx.
Show ctx =>
[ValidatorContext s ctx] -> ShowS
show :: ValidatorContext s ctx -> String
$cshow :: forall (s :: Stage) ctx.
Show ctx =>
ValidatorContext s ctx -> String
showsPrec :: Int -> ValidatorContext s ctx -> ShowS
$cshowsPrec :: forall (s :: Stage) ctx.
Show ctx =>
Int -> ValidatorContext s ctx -> ShowS
Show,
      a -> ValidatorContext s b -> ValidatorContext s a
(a -> b) -> ValidatorContext s a -> ValidatorContext s b
(forall a b.
 (a -> b) -> ValidatorContext s a -> ValidatorContext s b)
-> (forall a b. a -> ValidatorContext s b -> ValidatorContext s a)
-> Functor (ValidatorContext s)
forall a b. a -> ValidatorContext s b -> ValidatorContext s a
forall a b.
(a -> b) -> ValidatorContext s a -> ValidatorContext s b
forall (s :: Stage) a b.
a -> ValidatorContext s b -> ValidatorContext s a
forall (s :: Stage) a b.
(a -> b) -> ValidatorContext s a -> ValidatorContext s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ValidatorContext s b -> ValidatorContext s a
$c<$ :: forall (s :: Stage) a b.
a -> ValidatorContext s b -> ValidatorContext s a
fmap :: (a -> b) -> ValidatorContext s a -> ValidatorContext s b
$cfmap :: forall (s :: Stage) a b.
(a -> b) -> ValidatorContext s a -> ValidatorContext s b
Functor
    )

newtype Validator s ctx a = Validator
  { Validator s ctx a -> ReaderT (ValidatorContext s ctx) GQLResult a
_runValidator ::
      ReaderT
        (ValidatorContext s ctx)
        GQLResult
        a
  }
  deriving newtype
    ( a -> Validator s ctx b -> Validator s ctx a
(a -> b) -> Validator s ctx a -> Validator s ctx b
(forall a b. (a -> b) -> Validator s ctx a -> Validator s ctx b)
-> (forall a b. a -> Validator s ctx b -> Validator s ctx a)
-> Functor (Validator s ctx)
forall a b. a -> Validator s ctx b -> Validator s ctx a
forall a b. (a -> b) -> Validator s ctx a -> Validator s ctx b
forall (s :: Stage) ctx a b.
a -> Validator s ctx b -> Validator s ctx a
forall (s :: Stage) ctx a b.
(a -> b) -> Validator s ctx a -> Validator s ctx b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Validator s ctx b -> Validator s ctx a
$c<$ :: forall (s :: Stage) ctx a b.
a -> Validator s ctx b -> Validator s ctx a
fmap :: (a -> b) -> Validator s ctx a -> Validator s ctx b
$cfmap :: forall (s :: Stage) ctx a b.
(a -> b) -> Validator s ctx a -> Validator s ctx b
Functor,
      Functor (Validator s ctx)
a -> Validator s ctx a
Functor (Validator s ctx)
-> (forall a. a -> Validator s ctx a)
-> (forall a b.
    Validator s ctx (a -> b) -> Validator s ctx a -> Validator s ctx b)
-> (forall a b c.
    (a -> b -> c)
    -> Validator s ctx a -> Validator s ctx b -> Validator s ctx c)
-> (forall a b.
    Validator s ctx a -> Validator s ctx b -> Validator s ctx b)
-> (forall a b.
    Validator s ctx a -> Validator s ctx b -> Validator s ctx a)
-> Applicative (Validator s ctx)
Validator s ctx a -> Validator s ctx b -> Validator s ctx b
Validator s ctx a -> Validator s ctx b -> Validator s ctx a
Validator s ctx (a -> b) -> Validator s ctx a -> Validator s ctx b
(a -> b -> c)
-> Validator s ctx a -> Validator s ctx b -> Validator s ctx c
forall a. a -> Validator s ctx a
forall a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx a
forall a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx b
forall a b.
Validator s ctx (a -> b) -> Validator s ctx a -> Validator s ctx b
forall a b c.
(a -> b -> c)
-> Validator s ctx a -> Validator s ctx b -> Validator s ctx c
forall (s :: Stage) ctx. Functor (Validator s ctx)
forall (s :: Stage) ctx a. a -> Validator s ctx a
forall (s :: Stage) ctx a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx a
forall (s :: Stage) ctx a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx b
forall (s :: Stage) ctx a b.
Validator s ctx (a -> b) -> Validator s ctx a -> Validator s ctx b
forall (s :: Stage) ctx a b c.
(a -> b -> c)
-> Validator s ctx a -> Validator s ctx b -> Validator s ctx c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Validator s ctx a -> Validator s ctx b -> Validator s ctx a
$c<* :: forall (s :: Stage) ctx a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx a
*> :: Validator s ctx a -> Validator s ctx b -> Validator s ctx b
$c*> :: forall (s :: Stage) ctx a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx b
liftA2 :: (a -> b -> c)
-> Validator s ctx a -> Validator s ctx b -> Validator s ctx c
$cliftA2 :: forall (s :: Stage) ctx a b c.
(a -> b -> c)
-> Validator s ctx a -> Validator s ctx b -> Validator s ctx c
<*> :: Validator s ctx (a -> b) -> Validator s ctx a -> Validator s ctx b
$c<*> :: forall (s :: Stage) ctx a b.
Validator s ctx (a -> b) -> Validator s ctx a -> Validator s ctx b
pure :: a -> Validator s ctx a
$cpure :: forall (s :: Stage) ctx a. a -> Validator s ctx a
$cp1Applicative :: forall (s :: Stage) ctx. Functor (Validator s ctx)
Applicative,
      Applicative (Validator s ctx)
a -> Validator s ctx a
Applicative (Validator s ctx)
-> (forall a b.
    Validator s ctx a -> (a -> Validator s ctx b) -> Validator s ctx b)
-> (forall a b.
    Validator s ctx a -> Validator s ctx b -> Validator s ctx b)
-> (forall a. a -> Validator s ctx a)
-> Monad (Validator s ctx)
Validator s ctx a -> (a -> Validator s ctx b) -> Validator s ctx b
Validator s ctx a -> Validator s ctx b -> Validator s ctx b
forall a. a -> Validator s ctx a
forall a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx b
forall a b.
Validator s ctx a -> (a -> Validator s ctx b) -> Validator s ctx b
forall (s :: Stage) ctx. Applicative (Validator s ctx)
forall (s :: Stage) ctx a. a -> Validator s ctx a
forall (s :: Stage) ctx a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx b
forall (s :: Stage) ctx a b.
Validator s ctx a -> (a -> Validator s ctx b) -> Validator s ctx b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Validator s ctx a
$creturn :: forall (s :: Stage) ctx a. a -> Validator s ctx a
>> :: Validator s ctx a -> Validator s ctx b -> Validator s ctx b
$c>> :: forall (s :: Stage) ctx a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx b
>>= :: Validator s ctx a -> (a -> Validator s ctx b) -> Validator s ctx b
$c>>= :: forall (s :: Stage) ctx a b.
Validator s ctx a -> (a -> Validator s ctx b) -> Validator s ctx b
$cp1Monad :: forall (s :: Stage) ctx. Applicative (Validator s ctx)
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 :: (Scope -> Scope) -> m b -> m b
withScope Scope -> Scope
f = (ValidatorContext s c -> ValidatorContext s c) -> m b -> m b
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ValidatorContext {c
Schema s
Config
Scope
config :: Config
localContext :: c
schema :: Schema s
scope :: Scope
config :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Config
localContext :: forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
schema :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
scope :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
..} -> ValidatorContext :: forall (s :: Stage) ctx.
Scope -> Schema s -> ctx -> Config -> ValidatorContext s ctx
ValidatorContext {scope :: Scope
scope = Scope -> Scope
f Scope
scope, c
Schema s
Config
config :: Config
localContext :: c
schema :: Schema s
config :: Config
localContext :: c
schema :: Schema s
..})

asksLocal :: MonadReader (ValidatorContext s c) m => (c -> a) -> m a
asksLocal :: (c -> a) -> m a
asksLocal c -> a
f = (ValidatorContext s c -> a) -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (c -> a
f (c -> a)
-> (ValidatorContext s c -> c) -> ValidatorContext s c -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatorContext s c -> c
forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
localContext)

instance MonadError GQLError (Validator s ctx) where
  throwError :: GQLError -> Validator s ctx a
throwError GQLError
err = ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
Validator (ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a)
-> ReaderT (ValidatorContext s ctx) GQLResult a
-> Validator s ctx a
forall a b. (a -> b) -> a -> b
$ do
    ValidatorContext s ctx
ctx <- ReaderT (ValidatorContext s ctx) GQLResult (ValidatorContext s ctx)
forall r (m :: * -> *). MonadReader r m => m r
ask
    GQLError -> ReaderT (ValidatorContext s ctx) GQLResult a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidatorContext s ctx -> GQLError -> GQLError
forall (s :: Stage) ctx.
ValidatorContext s ctx -> GQLError -> GQLError
fromValidationError ValidatorContext s ctx
ctx GQLError
err)
  catchError :: Validator s ctx a
-> (GQLError -> Validator s ctx a) -> Validator s ctx a
catchError (Validator ReaderT (ValidatorContext s ctx) GQLResult a
x) GQLError -> Validator s ctx a
f = ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
Validator (ReaderT (ValidatorContext s ctx) GQLResult a
-> (GQLError -> ReaderT (ValidatorContext s ctx) GQLResult a)
-> ReaderT (ValidatorContext s ctx) GQLResult a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ReaderT (ValidatorContext s ctx) GQLResult a
x (Validator s ctx a -> ReaderT (ValidatorContext s ctx) GQLResult a
forall (s :: Stage) ctx a.
Validator s ctx a -> ReaderT (ValidatorContext s ctx) GQLResult a
_runValidator (Validator s ctx a -> ReaderT (ValidatorContext s ctx) GQLResult a)
-> (GQLError -> Validator s ctx a)
-> GQLError
-> ReaderT (ValidatorContext s ctx) GQLResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GQLError -> Validator s ctx a
f))

fromValidationError :: ValidatorContext s ctx -> GQLError -> GQLError
fromValidationError :: ValidatorContext s ctx -> GQLError -> GQLError
fromValidationError
  context :: ValidatorContext s ctx
context@ValidatorContext
    { Config
config :: Config
config :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Config
config,
      scope :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
scope = Scope {Maybe Position
position :: Scope -> Maybe Position
position :: Maybe Position
position, [PropName]
path :: Scope -> [PropName]
path :: [PropName]
path}
    }
  GQLError
err
    | GQLError -> Bool
isInternal GQLError
err Bool -> Bool -> Bool
|| Config -> Bool
debug Config
config =
      ( GQLError
err GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> ValidatorContext s ctx -> GQLError
forall (s :: Stage) ctx. ValidatorContext s ctx -> GQLError
renderContext ValidatorContext s ctx
context
          GQLError -> Maybe Position -> GQLError
forall (t :: * -> *).
Foldable t =>
GQLError -> t Position -> GQLError
`atPositions` Maybe Position
position
      )
        GQLError -> [PropName] -> GQLError
`withPath` [PropName]
path
    | Bool
otherwise = GQLError
err

renderContext :: ValidatorContext s ctx -> GQLError
renderContext :: ValidatorContext s ctx -> GQLError
renderContext
  ValidatorContext
    { Schema s
schema :: Schema s
schema :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
schema,
      Scope
scope :: Scope
scope :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
scope
    } =
    Scope -> GQLError
renderScope Scope
scope
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError -> Schema s -> GQLError
forall a. RenderGQL a => GQLError -> a -> GQLError
renderSection GQLError
"SchemaDefinition" Schema s
schema