{-# 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
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 " forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg (forall (t1 :: NAME) (t2 :: NAME) (t3 :: NAME).
Name t1 -> [Name t2] -> Name t3
intercalate Name Any
"." forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Prop -> FieldName
propName [Prop]
path) forall a. Semigroup a => a -> a -> a
<> GQLError
": "

renderInputPrefix :: InputContext c -> GQLError
renderInputPrefix :: forall c. 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 forall a. Semigroup a => a -> a -> a
<> [Prop] -> GQLError
renderPath [Prop]
inputPath

renderSource :: InputSource -> GQLError
renderSource :: InputSource -> GQLError
renderSource (SourceArgument FieldName
argumentName) =
  GQLError
"Argument " forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg FieldName
argumentName 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 " forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg (FieldName
"$" forall a. Semigroup a => a -> a -> a
<> FieldName
variableName) 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 " forall a. Semigroup a => a -> a -> a
<> TypeName -> FieldName -> Maybe FieldName -> GQLError
renderField TypeName
sourceTypeName FieldName
sourceFieldName Maybe FieldName
sourceArgumentName 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 =
  forall a. Msg a => a -> GQLError
msg (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
tName forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> forall a (t :: NAME). NamePacking a => Name t -> a
unpackName FieldName
fName forall a. Semigroup a => a -> a -> a
<> forall {a} {t :: NAME}.
(Semigroup a, IsString a, NamePacking a) =>
Maybe (Name t) -> a
renderArg Maybe FieldName
arg :: Text)
  where
    renderArg :: Maybe (Name t) -> a
renderArg (Just Name t
argName) = a
"(" forall a. Semigroup a => a -> a -> a
<> forall a (t :: NAME). NamePacking a => Name t -> a
unpackName Name t
argName forall a. Semigroup a => a -> a -> a
<> a
":)"
    renderArg Maybe (Name t)
Nothing = a
""

data OperationContext (s1 :: Stage) (s2 :: Stage) = OperationContext
  { forall (s1 :: Stage) (s2 :: Stage).
OperationContext s1 s2 -> Fragments s2
fragments :: Fragments s2,
    forall (s1 :: Stage) (s2 :: Stage).
OperationContext s1 s2 -> VariableDefinitions s1
variables :: VariableDefinitions s1,
    forall (s1 :: Stage) (s2 :: Stage).
OperationContext s1 s2 -> Maybe FieldName
operationName :: Maybe FieldName
  }
  deriving (Int -> OperationContext s1 s2 -> ShowS
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
  { forall ctx. InputContext ctx -> InputSource
inputSource :: InputSource,
    forall ctx. InputContext ctx -> [Prop]
inputPath :: [Prop],
    forall ctx. InputContext ctx -> ctx
sourceContext :: ctx
  }
  deriving (Int -> InputContext ctx -> ShowS
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
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 :: forall (s :: Stage) c a.
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}
    } = 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
            { inputPath :: [Prop]
inputPath = [Prop]
old 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 :: forall (s :: Stage) c (m :: * -> *).
MonadReader (ValidatorContext s (InputContext c)) m =>
m InputSource
inputValueSource = forall (s :: Stage) c (m :: * -> *) a.
MonadReader (ValidatorContext s c) m =>
(c -> a) -> m a
asksLocal forall ctx. InputContext ctx -> InputSource
inputSource

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

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

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

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

runValidator :: Validator s ctx a -> Config -> Schema s -> Scope -> ctx -> GQLResult a
runValidator :: forall (s :: Stage) ctx a.
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 =
  forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (ValidatorContext s ctx) GQLResult a
x 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 :: forall c' c (s :: Stage) a.
(c' -> c) -> Validator s c a -> Validator s c' a
withContext c' -> c
f = forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
Validator forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c' -> c
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage) ctx a.
Validator s ctx a -> ReaderT (ValidatorContext s ctx) GQLResult a
_runValidator

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

startInput :: InputSource -> InputValidator s ctx a -> Validator s ctx a
startInput :: forall (s :: Stage) ctx a.
InputSource -> InputValidator s ctx a -> Validator s ctx a
startInput InputSource
inputSource = 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
        { InputSource
inputSource :: InputSource
inputSource :: InputSource
inputSource,
          inputPath :: [Prop]
inputPath = [],
          ctx
sourceContext :: ctx
sourceContext :: ctx
sourceContext
        }

data ValidatorContext (s :: Stage) (ctx :: Type) = ValidatorContext
  { forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
scope :: Scope,
    forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
schema :: Schema s,
    forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
localContext :: ctx,
    forall (s :: Stage) ctx. ValidatorContext s ctx -> Config
config :: Config
  }
  deriving
    ( Int -> ValidatorContext s ctx -> ShowS
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,
      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
<$ :: forall a b. a -> ValidatorContext s b -> ValidatorContext s a
$c<$ :: forall (s :: Stage) a b.
a -> ValidatorContext s b -> ValidatorContext s a
fmap :: forall a b.
(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
  { forall (s :: Stage) ctx a.
Validator s ctx a -> ReaderT (ValidatorContext s ctx) GQLResult a
_runValidator ::
      ReaderT
        (ValidatorContext s ctx)
        GQLResult
        a
  }
  deriving newtype
    ( 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
<$ :: forall a b. 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 :: forall a b. (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,
      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
<* :: forall a b.
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
*> :: forall a b.
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 :: forall a b c.
(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
<*> :: forall a b.
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 :: forall a. a -> Validator s ctx a
$cpure :: forall (s :: Stage) ctx a. a -> Validator s ctx a
Applicative,
      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 :: forall a. a -> Validator s ctx a
$creturn :: forall (s :: Stage) ctx a. a -> Validator s ctx a
>> :: forall a b.
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
>>= :: forall a 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
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 :: forall (s :: Stage) c (m :: * -> *) b.
MonadReader (ValidatorContext s c) m =>
(Scope -> Scope) -> m b -> m b
withScope Scope -> Scope
f = 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 {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 :: forall (s :: Stage) c (m :: * -> *) a.
MonadReader (ValidatorContext s c) m =>
(c -> a) -> m a
asksLocal c -> a
f = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (c -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
localContext)

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

fromValidationError :: ValidatorContext s ctx -> GQLError -> GQLError
fromValidationError :: forall (s :: Stage) ctx.
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
            forall a. Semigroup a => a -> a -> a
<> forall (s :: Stage) ctx. ValidatorContext s ctx -> GQLError
renderContext ValidatorContext s ctx
context
            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 :: forall (s :: Stage) ctx. 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
      forall a. Semigroup a => a -> a -> a
<> forall a. RenderGQL a => GQLError -> a -> GQLError
renderSection GQLError
"SchemaDefinition" Schema s
schema