{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# 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 (..),
withScope,
withScopeType,
withPosition,
inField,
inputMessagePrefix,
InputSource (..),
InputContext (..),
OperationContext (..),
CurrentSelection (..),
renderInputPrefix,
Target (..),
Prop (..),
Resolution,
ScopeKind (..),
inputValueSource,
Scope (..),
withDirective,
startInput,
GetWith (..),
SetWith (..),
MonadContext (..),
withContext,
renderField,
asks,
asksScope,
askSchema,
askVariables,
askFragments,
DirectiveValidator,
ValidatorContext (..),
FragmentValidator,
)
where
import Data.Morpheus.Error.Utils
( validationErrorMessage,
)
import Data.Morpheus.Internal.Utils
( Failure (..),
)
import Data.Morpheus.Rendering.RenderGQL (RenderGQL (..), renderGQL)
import Data.Morpheus.Types.Internal.AST
( Directive (..),
FieldDefinition (..),
FieldName (..),
Fragments,
GQLError (..),
GQLErrors,
IMPLEMENTABLE,
IN,
InternalError,
Message,
Position,
RAW,
Ref (..),
Schema,
Stage,
TypeDefinition (..),
TypeKind (..),
TypeName (..),
TypeRef (..),
TypeWrapper,
VALID,
ValidationError (..),
Variable (..),
VariableDefinitions,
intercalateName,
kindOf,
msg,
msgValidation,
)
import Data.Morpheus.Types.Internal.Config (Config (..))
import Data.Morpheus.Types.Internal.Resolving
( Eventless,
)
import Relude hiding
( Constraint,
asks,
get,
)
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 -> ValidationError
renderPath :: [Prop] -> ValidationError
renderPath [] = ValidationError
""
renderPath [Prop]
path = ValidationError
"in field " ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> FieldName -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation (FieldName -> [FieldName] -> FieldName
intercalateName FieldName
"." ([FieldName] -> FieldName) -> [FieldName] -> FieldName
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) ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
": "
renderInputPrefix :: InputContext c -> ValidationError
renderInputPrefix :: InputContext c -> ValidationError
renderInputPrefix InputContext {[Prop]
inputPath :: forall ctx. InputContext ctx -> [Prop]
inputPath :: [Prop]
inputPath, InputSource
inputSource :: forall ctx. InputContext ctx -> InputSource
inputSource :: InputSource
inputSource} =
InputSource -> ValidationError
renderSource InputSource
inputSource ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> [Prop] -> ValidationError
renderPath [Prop]
inputPath
renderSource :: InputSource -> ValidationError
renderSource :: InputSource -> ValidationError
renderSource (SourceArgument FieldName
argumentName) =
ValidationError
"Argument " ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> FieldName -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation FieldName
argumentName ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
" got invalid value. "
renderSource (SourceVariable Variable {FieldName
variableName :: forall (stage :: Stage). Variable stage -> FieldName
variableName :: FieldName
variableName} Bool
_) =
ValidationError
"Variable " ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> FieldName -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation (FieldName
"$" FieldName -> FieldName -> FieldName
forall a. Semigroup a => a -> a -> a
<> FieldName
variableName) ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
" 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} =
ValidationError
"Field " ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> TypeName -> FieldName -> Maybe FieldName -> ValidationError
renderField TypeName
sourceTypeName FieldName
sourceFieldName Maybe FieldName
sourceArgumentName ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
" got invalid default value. "
renderField :: TypeName -> FieldName -> Maybe FieldName -> ValidationError
renderField :: TypeName -> FieldName -> Maybe FieldName -> ValidationError
renderField (TypeName Text
tname) (FieldName Text
fname) Maybe FieldName
arg =
Text -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation (Text
tname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe FieldName -> Text
renderArg Maybe FieldName
arg)
where
renderArg :: Maybe FieldName -> Text
renderArg (Just (FieldName Text
argName)) = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
argName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":)"
renderArg Maybe FieldName
Nothing = Text
""
data ScopeKind
= DIRECTIVE
| SELECTION
| TYPE
deriving (Int -> ScopeKind -> ShowS
[ScopeKind] -> ShowS
ScopeKind -> String
(Int -> ScopeKind -> ShowS)
-> (ScopeKind -> String)
-> ([ScopeKind] -> ShowS)
-> Show ScopeKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScopeKind] -> ShowS
$cshowList :: [ScopeKind] -> ShowS
show :: ScopeKind -> String
$cshow :: ScopeKind -> String
showsPrec :: Int -> ScopeKind -> ShowS
$cshowsPrec :: Int -> ScopeKind -> ShowS
Show)
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 -> CurrentSelection
selection :: CurrentSelection
}
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)
newtype CurrentSelection = CurrentSelection
{ CurrentSelection -> Maybe FieldName
operationName :: Maybe FieldName
}
deriving (Int -> CurrentSelection -> ShowS
[CurrentSelection] -> ShowS
CurrentSelection -> String
(Int -> CurrentSelection -> ShowS)
-> (CurrentSelection -> String)
-> ([CurrentSelection] -> ShowS)
-> Show CurrentSelection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CurrentSelection] -> ShowS
$cshowList :: [CurrentSelection] -> ShowS
show :: CurrentSelection -> String
$cshow :: CurrentSelection -> String
showsPrec :: Int -> CurrentSelection -> ShowS
$cshowsPrec :: Int -> CurrentSelection -> ShowS
Show)
data Scope = Scope
{ Scope -> Maybe Position
position :: Maybe Position,
Scope -> TypeName
currentTypeName :: TypeName,
Scope -> TypeKind
currentTypeKind :: TypeKind,
Scope -> [TypeWrapper]
currentTypeWrappers :: [TypeWrapper],
Scope -> FieldName
fieldname :: FieldName,
Scope -> ScopeKind
kind :: ScopeKind
}
deriving (Int -> Scope -> ShowS
[Scope] -> ShowS
Scope -> String
(Int -> Scope -> ShowS)
-> (Scope -> String) -> ([Scope] -> ShowS) -> Show Scope
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Scope] -> ShowS
$cshowList :: [Scope] -> ShowS
show :: Scope -> String
$cshow :: Scope -> String
showsPrec :: Int -> Scope -> ShowS
$cshowsPrec :: Int -> Scope -> 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 Target
= TARGET_IMPLEMENTABLE
| TARGET_INPUT
data Constraint (a :: Target) where
IMPLEMENTABLE :: Constraint 'TARGET_IMPLEMENTABLE
INPUT :: Constraint 'TARGET_INPUT
type family Resolution (s :: Stage) (a :: Target)
type instance Resolution s 'TARGET_IMPLEMENTABLE = TypeDefinition IMPLEMENTABLE s
type instance Resolution s 'TARGET_INPUT = TypeDefinition IN s
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 ::
forall m c s.
( GetWith c InputSource,
MonadContext m s c
) =>
m c InputSource
inputValueSource :: m c InputSource
inputValueSource = m c InputSource
forall (m :: * -> * -> *) (s :: Stage) ctx a.
(MonadContext m s ctx, GetWith ctx a) =>
m ctx a
get
asks ::
( MonadContext m s c,
GetWith c t
) =>
(t -> a) ->
m c a
asks :: (t -> a) -> m c a
asks t -> a
f = t -> a
f (t -> a) -> m c t -> m c a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m c t
forall (m :: * -> * -> *) (s :: Stage) ctx a.
(MonadContext m s ctx, GetWith ctx a) =>
m ctx a
get
asksScope ::
( MonadContext m s c
) =>
(Scope -> a) ->
m c a
asksScope :: (Scope -> a) -> m c a
asksScope Scope -> a
f = Scope -> a
f (Scope -> a) -> m c Scope -> m c a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ValidatorContext s c -> Scope) -> m c Scope
forall (m :: * -> * -> *) (s :: Stage) c a.
MonadContext m s c =>
(ValidatorContext s c -> a) -> m c a
getGlobalContext ValidatorContext s c -> Scope
forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
scope
setSelectionName ::
(MonadContext m s c) =>
FieldName ->
m c a ->
m c a
setSelectionName :: FieldName -> m c a -> m c a
setSelectionName FieldName
fieldname = (Scope -> Scope) -> m c a -> m c a
forall (m :: * -> * -> *) (s :: Stage) c b.
MonadContext m s c =>
(Scope -> Scope) -> m c b -> m c b
setScope Scope -> Scope
update
where
update :: Scope -> Scope
update Scope
ctx = Scope
ctx {FieldName
fieldname :: FieldName
fieldname :: FieldName
fieldname}
askSchema ::
( MonadContext m s c
) =>
m c (Schema s)
askSchema :: m c (Schema s)
askSchema = (ValidatorContext s c -> Schema s) -> m c (Schema s)
forall (m :: * -> * -> *) (s :: Stage) c a.
MonadContext m s c =>
(ValidatorContext s c -> a) -> m c a
getGlobalContext ValidatorContext s c -> Schema s
forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
schema
askVariables ::
( MonadContext m s c,
GetWith c (VariableDefinitions VALID)
) =>
m c (VariableDefinitions VALID)
askVariables :: m c (VariableDefinitions VALID)
askVariables = m c (VariableDefinitions VALID)
forall (m :: * -> * -> *) (s :: Stage) ctx a.
(MonadContext m s ctx, GetWith ctx a) =>
m ctx a
get
askFragments ::
( MonadContext m s c,
GetWith c (Fragments s')
) =>
m c (Fragments s')
askFragments :: m c (Fragments s')
askFragments = m c (Fragments s')
forall (m :: * -> * -> *) (s :: Stage) ctx a.
(MonadContext m s ctx, GetWith ctx a) =>
m ctx a
get
runValidator :: Validator s ctx a -> Config -> Schema s -> Scope -> ctx -> Eventless a
runValidator :: Validator s ctx a
-> Config -> Schema s -> Scope -> ctx -> Eventless a
runValidator (Validator ReaderT (ValidatorContext s ctx) Eventless a
x) Config
config Schema s
schema Scope
scope ctx
validatorCTX =
ReaderT (ValidatorContext s ctx) Eventless a
-> ValidatorContext s ctx -> Eventless a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (ValidatorContext s ctx) Eventless a
x ValidatorContext :: forall (s :: Stage) ctx.
Scope -> Schema s -> ctx -> Config -> ValidatorContext s ctx
ValidatorContext {ctx
Schema s
Config
Scope
config :: Config
validatorCTX :: ctx
validatorCTX :: 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') Eventless a -> Validator s c' a
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) Eventless a -> Validator s ctx a
Validator (ReaderT (ValidatorContext s c') Eventless a -> Validator s c' a)
-> (Validator s c a -> ReaderT (ValidatorContext s c') Eventless 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) Eventless a
-> ReaderT (ValidatorContext s c') Eventless 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) Eventless a
-> ReaderT (ValidatorContext s c') Eventless a)
-> (Validator s c a -> ReaderT (ValidatorContext s c) Eventless a)
-> Validator s c a
-> ReaderT (ValidatorContext s c') Eventless a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validator s c a -> ReaderT (ValidatorContext s c) Eventless a
forall (s :: Stage) ctx a.
Validator s ctx a -> ReaderT (ValidatorContext s ctx) Eventless a
_runValidator
withDirective ::
( MonadContext m schemaS c
) =>
Directive s ->
m c a ->
m c a
withDirective :: Directive s -> m c a -> m c a
withDirective
Directive
{ FieldName
directiveName :: forall (s :: Stage). Directive s -> FieldName
directiveName :: FieldName
directiveName,
Position
directivePosition :: forall (s :: Stage). Directive s -> Position
directivePosition :: Position
directivePosition
} = FieldName -> m c a -> m c a
forall (m :: * -> * -> *) (s :: Stage) c a.
MonadContext m s c =>
FieldName -> m c a -> m c a
setSelectionName FieldName
directiveName (m c a -> m c a) -> (m c a -> m c a) -> m c a -> m c a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Scope -> Scope) -> m c a -> m c a
forall (m :: * -> * -> *) (s :: Stage) c b.
MonadContext m s c =>
(Scope -> Scope) -> m c b -> m c b
setScope Scope -> Scope
update
where
update :: Scope -> Scope
update Scope {[TypeWrapper]
Maybe Position
TypeKind
TypeName
FieldName
ScopeKind
kind :: ScopeKind
fieldname :: FieldName
currentTypeWrappers :: [TypeWrapper]
currentTypeKind :: TypeKind
currentTypeName :: TypeName
position :: Maybe Position
kind :: Scope -> ScopeKind
fieldname :: Scope -> FieldName
currentTypeWrappers :: Scope -> [TypeWrapper]
currentTypeKind :: Scope -> TypeKind
currentTypeName :: Scope -> TypeName
position :: Scope -> Maybe Position
..} =
Scope :: Maybe Position
-> TypeName
-> TypeKind
-> [TypeWrapper]
-> FieldName
-> ScopeKind
-> Scope
Scope
{ position :: Maybe Position
position = Position -> Maybe Position
forall a. a -> Maybe a
Just Position
directivePosition,
kind :: ScopeKind
kind = ScopeKind
DIRECTIVE,
[TypeWrapper]
TypeKind
TypeName
FieldName
fieldname :: FieldName
currentTypeWrappers :: [TypeWrapper]
currentTypeKind :: TypeKind
currentTypeName :: TypeName
fieldname :: FieldName
currentTypeWrappers :: [TypeWrapper]
currentTypeKind :: TypeKind
currentTypeName :: TypeName
..
}
withScope ::
( MonadContext m s c
) =>
TypeDefinition cat s ->
Ref ->
m c a ->
m c a
withScope :: TypeDefinition cat s -> Ref -> m c a -> m c a
withScope t :: TypeDefinition cat s
t@TypeDefinition {TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName :: TypeName
typeName} (Ref FieldName
selName Position
pos) =
FieldName -> m c a -> m c a
forall (m :: * -> * -> *) (s :: Stage) c a.
MonadContext m s c =>
FieldName -> m c a -> m c a
setSelectionName FieldName
selName (m c a -> m c a) -> (m c a -> m c a) -> m c a -> m c a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Scope -> Scope) -> m c a -> m c a
forall (m :: * -> * -> *) (s :: Stage) c b.
MonadContext m s c =>
(Scope -> Scope) -> m c b -> m c b
setScope Scope -> Scope
update
where
update :: Scope -> Scope
update Scope {[TypeWrapper]
Maybe Position
TypeKind
TypeName
FieldName
ScopeKind
kind :: ScopeKind
fieldname :: FieldName
currentTypeWrappers :: [TypeWrapper]
currentTypeKind :: TypeKind
currentTypeName :: TypeName
position :: Maybe Position
kind :: Scope -> ScopeKind
fieldname :: Scope -> FieldName
currentTypeWrappers :: Scope -> [TypeWrapper]
currentTypeKind :: Scope -> TypeKind
currentTypeName :: Scope -> TypeName
position :: Scope -> Maybe Position
..} =
Scope :: Maybe Position
-> TypeName
-> TypeKind
-> [TypeWrapper]
-> FieldName
-> ScopeKind
-> Scope
Scope
{ currentTypeName :: TypeName
currentTypeName = TypeName
typeName,
currentTypeKind :: TypeKind
currentTypeKind = TypeDefinition cat s -> TypeKind
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeKind
kindOf TypeDefinition cat s
t,
position :: Maybe Position
position = Position -> Maybe Position
forall a. a -> Maybe a
Just Position
pos,
[TypeWrapper]
FieldName
ScopeKind
kind :: ScopeKind
fieldname :: FieldName
currentTypeWrappers :: [TypeWrapper]
kind :: ScopeKind
fieldname :: FieldName
currentTypeWrappers :: [TypeWrapper]
..
}
withScopeType ::
( MonadContext m s c
) =>
(TypeDefinition cat s, [TypeWrapper]) ->
m c a ->
m c a
withScopeType :: (TypeDefinition cat s, [TypeWrapper]) -> m c a -> m c a
withScopeType (t :: TypeDefinition cat s
t@TypeDefinition {TypeName
typeName :: TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName}, [TypeWrapper]
wrappers) = (Scope -> Scope) -> m c a -> m c a
forall (m :: * -> * -> *) (s :: Stage) c b.
MonadContext m s c =>
(Scope -> Scope) -> m c b -> m c b
setScope Scope -> Scope
update
where
update :: Scope -> Scope
update Scope {[TypeWrapper]
Maybe Position
TypeKind
TypeName
FieldName
ScopeKind
kind :: ScopeKind
fieldname :: FieldName
currentTypeWrappers :: [TypeWrapper]
currentTypeKind :: TypeKind
currentTypeName :: TypeName
position :: Maybe Position
kind :: Scope -> ScopeKind
fieldname :: Scope -> FieldName
currentTypeWrappers :: Scope -> [TypeWrapper]
currentTypeKind :: Scope -> TypeKind
currentTypeName :: Scope -> TypeName
position :: Scope -> Maybe Position
..} =
Scope :: Maybe Position
-> TypeName
-> TypeKind
-> [TypeWrapper]
-> FieldName
-> ScopeKind
-> Scope
Scope
{ currentTypeName :: TypeName
currentTypeName = TypeName
typeName,
currentTypeKind :: TypeKind
currentTypeKind = TypeDefinition cat s -> TypeKind
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeKind
kindOf TypeDefinition cat s
t,
currentTypeWrappers :: [TypeWrapper]
currentTypeWrappers = [TypeWrapper]
wrappers,
Maybe Position
FieldName
ScopeKind
kind :: ScopeKind
fieldname :: FieldName
position :: Maybe Position
kind :: ScopeKind
fieldname :: FieldName
position :: Maybe Position
..
}
withPosition ::
( MonadContext m s c
) =>
Position ->
m c a ->
m c a
withPosition :: Position -> m c a -> m c a
withPosition Position
pos = (Scope -> Scope) -> m c a -> m c a
forall (m :: * -> * -> *) (s :: Stage) c b.
MonadContext m s c =>
(Scope -> Scope) -> m c b -> m c b
setScope Scope -> Scope
update
where
update :: Scope -> Scope
update Scope {[TypeWrapper]
Maybe Position
TypeKind
TypeName
FieldName
ScopeKind
kind :: ScopeKind
fieldname :: FieldName
currentTypeWrappers :: [TypeWrapper]
currentTypeKind :: TypeKind
currentTypeName :: TypeName
position :: Maybe Position
kind :: Scope -> ScopeKind
fieldname :: Scope -> FieldName
currentTypeWrappers :: Scope -> [TypeWrapper]
currentTypeKind :: Scope -> TypeKind
currentTypeName :: Scope -> TypeName
position :: Scope -> Maybe Position
..} = Scope :: Maybe Position
-> TypeName
-> TypeKind
-> [TypeWrapper]
-> FieldName
-> ScopeKind
-> Scope
Scope {position :: Maybe Position
position = Position -> Maybe Position
forall a. a -> Maybe a
Just Position
pos, [TypeWrapper]
TypeKind
TypeName
FieldName
ScopeKind
kind :: ScopeKind
fieldname :: FieldName
currentTypeWrappers :: [TypeWrapper]
currentTypeKind :: TypeKind
currentTypeName :: TypeName
kind :: ScopeKind
fieldname :: FieldName
currentTypeWrappers :: [TypeWrapper]
currentTypeKind :: TypeKind
currentTypeName :: TypeName
..}
inputMessagePrefix :: InputValidator s ctx ValidationError
inputMessagePrefix :: InputValidator s ctx ValidationError
inputMessagePrefix =
InputContext ctx -> ValidationError
forall c. InputContext c -> ValidationError
renderInputPrefix
(InputContext ctx -> ValidationError)
-> (ValidatorContext s (InputContext ctx) -> InputContext ctx)
-> ValidatorContext s (InputContext ctx)
-> ValidationError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatorContext s (InputContext ctx) -> InputContext ctx
forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
validatorCTX (ValidatorContext s (InputContext ctx) -> ValidationError)
-> Validator
s (InputContext ctx) (ValidatorContext s (InputContext ctx))
-> InputValidator s ctx ValidationError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
(ValidatorContext s (InputContext ctx))
Eventless
(ValidatorContext s (InputContext ctx))
-> Validator
s (InputContext ctx) (ValidatorContext s (InputContext ctx))
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) Eventless a -> Validator s ctx a
Validator ReaderT
(ValidatorContext s (InputContext ctx))
Eventless
(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 :: *) = ValidatorContext
{ ValidatorContext s ctx -> Scope
scope :: Scope,
ValidatorContext s ctx -> Schema s
schema :: Schema s,
ValidatorContext s ctx -> ctx
validatorCTX :: 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) Eventless a
_runValidator ::
ReaderT
(ValidatorContext s ctx)
Eventless
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
)
instance MonadReader ctx (Validator s ctx) where
ask :: Validator s ctx ctx
ask = ValidatorContext s ctx -> ctx
forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
validatorCTX (ValidatorContext s ctx -> ctx)
-> Validator s ctx (ValidatorContext s ctx) -> Validator s ctx ctx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (ValidatorContext s ctx) Eventless (ValidatorContext s ctx)
-> Validator s ctx (ValidatorContext s ctx)
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) Eventless a -> Validator s ctx a
Validator ReaderT (ValidatorContext s ctx) Eventless (ValidatorContext s ctx)
forall r (m :: * -> *). MonadReader r m => m r
ask
local :: (ctx -> ctx) -> Validator s ctx a -> Validator s ctx a
local = (ctx -> ctx) -> Validator s ctx a -> Validator s ctx a
forall c' c (s :: Stage) a.
(c' -> c) -> Validator s c a -> Validator s c' a
withContext
type BaseValidator = Validator VALID (OperationContext RAW RAW)
type FragmentValidator (s :: Stage) = Validator VALID (OperationContext VALID s)
type SelectionValidator = Validator VALID (OperationContext VALID VALID)
type InputValidator s ctx = Validator s (InputContext ctx)
type DirectiveValidator ctx = Validator ctx
setScope ::
(MonadContext m s c) =>
(Scope -> Scope) ->
m c b ->
m c b
setScope :: (Scope -> Scope) -> m c b -> m c b
setScope Scope -> Scope
f = (ValidatorContext s c -> ValidatorContext s c) -> m c b -> m c b
forall (m :: * -> * -> *) (s :: Stage) c b.
MonadContext m s c =>
(ValidatorContext s c -> ValidatorContext s c) -> m c b -> m c b
setGlobalContext ((Scope -> Scope) -> ValidatorContext s c -> ValidatorContext s c
forall (s :: Stage) ctx.
(Scope -> Scope)
-> ValidatorContext s ctx -> ValidatorContext s ctx
mapScope Scope -> Scope
f)
mapScope :: (Scope -> Scope) -> ValidatorContext s ctx -> ValidatorContext s ctx
mapScope :: (Scope -> Scope)
-> ValidatorContext s ctx -> ValidatorContext s ctx
mapScope Scope -> Scope
f ValidatorContext {Scope
scope :: Scope
scope :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
scope, ctx
Schema s
Config
config :: Config
validatorCTX :: ctx
schema :: Schema s
config :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Config
validatorCTX :: forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
schema :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
..} = ValidatorContext :: forall (s :: Stage) ctx.
Scope -> Schema s -> ctx -> Config -> ValidatorContext s ctx
ValidatorContext {scope :: Scope
scope = Scope -> Scope
f Scope
scope, ctx
Schema s
Config
config :: Config
validatorCTX :: ctx
schema :: Schema s
config :: Config
validatorCTX :: ctx
schema :: Schema s
..}
get :: (MonadContext m s ctx, GetWith ctx a) => m ctx a
get :: m ctx a
get = (ctx -> a) -> m ctx a
forall (m :: * -> * -> *) (s :: Stage) c a.
MonadContext m s c =>
(c -> a) -> m c a
getContext ctx -> a
forall c v. GetWith c v => c -> v
getWith
class
Monad (m c) =>
MonadContext m s c
| m -> s
where
getGlobalContext :: (ValidatorContext s c -> a) -> m c a
setGlobalContext :: (ValidatorContext s c -> ValidatorContext s c) -> m c b -> m c b
getContext :: (c -> a) -> m c a
setContext :: (c -> c) -> m c b -> m c b
instance MonadContext (Validator s) s c where
getGlobalContext :: (ValidatorContext s c -> a) -> Validator s c a
getGlobalContext ValidatorContext s c -> a
f = ValidatorContext s c -> a
f (ValidatorContext s c -> a)
-> Validator s c (ValidatorContext s c) -> Validator s c a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (ValidatorContext s c) Eventless (ValidatorContext s c)
-> Validator s c (ValidatorContext s c)
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) Eventless a -> Validator s ctx a
Validator ReaderT (ValidatorContext s c) Eventless (ValidatorContext s c)
forall r (m :: * -> *). MonadReader r m => m r
ask
getContext :: (c -> a) -> Validator s c a
getContext c -> a
f = 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
validatorCTX (ValidatorContext s c -> a)
-> Validator s c (ValidatorContext s c) -> Validator s c a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (ValidatorContext s c) Eventless (ValidatorContext s c)
-> Validator s c (ValidatorContext s c)
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) Eventless a -> Validator s ctx a
Validator ReaderT (ValidatorContext s c) Eventless (ValidatorContext s c)
forall r (m :: * -> *). MonadReader r m => m r
ask
setGlobalContext :: (ValidatorContext s c -> ValidatorContext s c)
-> Validator s c b -> Validator s c b
setGlobalContext ValidatorContext s c -> ValidatorContext s c
f = ReaderT (ValidatorContext s c) Eventless b -> Validator s c b
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) Eventless a -> Validator s ctx a
Validator (ReaderT (ValidatorContext s c) Eventless b -> Validator s c b)
-> (Validator s c b -> ReaderT (ValidatorContext s c) Eventless b)
-> Validator s c b
-> Validator s c b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValidatorContext s c -> ValidatorContext s c)
-> ReaderT (ValidatorContext s c) Eventless b
-> ReaderT (ValidatorContext s c) Eventless b
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT ValidatorContext s c -> ValidatorContext s c
f (ReaderT (ValidatorContext s c) Eventless b
-> ReaderT (ValidatorContext s c) Eventless b)
-> (Validator s c b -> ReaderT (ValidatorContext s c) Eventless b)
-> Validator s c b
-> ReaderT (ValidatorContext s c) Eventless b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validator s c b -> ReaderT (ValidatorContext s c) Eventless b
forall (s :: Stage) ctx a.
Validator s ctx a -> ReaderT (ValidatorContext s ctx) Eventless a
_runValidator
setContext :: (c -> c) -> Validator s c b -> Validator s c b
setContext = (c -> c) -> Validator s c b -> Validator s c b
forall c' c (s :: Stage) a.
(c' -> c) -> Validator s c a -> Validator s c' a
withContext
class GetWith (c :: *) (v :: *) where
getWith :: c -> v
instance GetWith (OperationContext VALID fragStage) (VariableDefinitions VALID) where
getWith :: OperationContext VALID fragStage -> VariableDefinitions VALID
getWith = OperationContext VALID fragStage -> VariableDefinitions VALID
forall (s1 :: Stage) (s2 :: Stage).
OperationContext s1 s2 -> VariableDefinitions s1
variables
instance GetWith (InputContext ctx) InputSource where
getWith :: InputContext ctx -> InputSource
getWith = InputContext ctx -> InputSource
forall ctx. InputContext ctx -> InputSource
inputSource
instance GetWith (OperationContext varStage fragStage) (Fragments fragStage) where
getWith :: OperationContext varStage fragStage -> Fragments fragStage
getWith = OperationContext varStage fragStage -> Fragments fragStage
forall (varStage :: Stage) (fragStage :: Stage).
OperationContext varStage fragStage -> Fragments fragStage
fragments
class SetWith (c :: *) (v :: *) where
setWith :: (v -> v) -> c -> c
instance SetWith (OperationContext s1 s2) CurrentSelection where
setWith :: (CurrentSelection -> CurrentSelection)
-> OperationContext s1 s2 -> OperationContext s1 s2
setWith CurrentSelection -> CurrentSelection
f OperationContext {selection :: forall (s1 :: Stage) (s2 :: Stage).
OperationContext s1 s2 -> CurrentSelection
selection = CurrentSelection
selection, VariableDefinitions s1
Fragments s2
variables :: VariableDefinitions s1
fragments :: Fragments s2
variables :: forall (s1 :: Stage) (s2 :: Stage).
OperationContext s1 s2 -> VariableDefinitions s1
fragments :: forall (varStage :: Stage) (fragStage :: Stage).
OperationContext varStage fragStage -> Fragments fragStage
..} =
OperationContext :: forall (s1 :: Stage) (s2 :: Stage).
Fragments s2
-> VariableDefinitions s1
-> CurrentSelection
-> OperationContext s1 s2
OperationContext
{ selection :: CurrentSelection
selection = CurrentSelection -> CurrentSelection
f CurrentSelection
selection,
VariableDefinitions s1
Fragments s2
variables :: VariableDefinitions s1
fragments :: Fragments s2
variables :: VariableDefinitions s1
fragments :: Fragments s2
..
}
instance Failure [ValidationError] (Validator s ctx) where
failure :: [ValidationError] -> Validator s ctx v
failure [ValidationError]
errors = do
ValidatorContext s ctx
ctx <- ReaderT (ValidatorContext s ctx) Eventless (ValidatorContext s ctx)
-> Validator s ctx (ValidatorContext s ctx)
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) Eventless a -> Validator s ctx a
Validator ReaderT (ValidatorContext s ctx) Eventless (ValidatorContext s ctx)
forall r (m :: * -> *). MonadReader r m => m r
ask
GQLErrors -> Validator s ctx v
forall (s :: Stage) ctx a. GQLErrors -> Validator s ctx a
failValidator ((ValidationError -> GQLError) -> [ValidationError] -> GQLErrors
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ValidatorContext s ctx -> ValidationError -> GQLError
forall (s :: Stage) ctx.
ValidatorContext s ctx -> ValidationError -> GQLError
fromValidatinError ValidatorContext s ctx
ctx) [ValidationError]
errors)
instance Failure ValidationError (Validator s ctx) where
failure :: ValidationError -> Validator s ctx v
failure ValidationError
err = [ValidationError] -> Validator s ctx v
forall error (f :: * -> *) v. Failure error f => error -> f v
failure [ValidationError
err]
failValidator :: GQLErrors -> Validator s ctx a
failValidator :: GQLErrors -> Validator s ctx a
failValidator = ReaderT (ValidatorContext s ctx) Eventless a -> Validator s ctx a
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) Eventless a -> Validator s ctx a
Validator (ReaderT (ValidatorContext s ctx) Eventless a -> Validator s ctx a)
-> (GQLErrors -> ReaderT (ValidatorContext s ctx) Eventless a)
-> GQLErrors
-> Validator s ctx a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eventless a -> ReaderT (ValidatorContext s ctx) Eventless a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Eventless a -> ReaderT (ValidatorContext s ctx) Eventless a)
-> (GQLErrors -> Eventless a)
-> GQLErrors
-> ReaderT (ValidatorContext s ctx) Eventless a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GQLErrors -> Eventless a
forall error (f :: * -> *) v. Failure error f => error -> f v
failure
fromValidatinError :: ValidatorContext s ctx -> ValidationError -> GQLError
fromValidatinError :: ValidatorContext s ctx -> ValidationError -> GQLError
fromValidatinError
context :: ValidatorContext s ctx
context@ValidatorContext
{ Config
config :: Config
config :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Config
config
}
(ValidationError Message
text [Position]
locations) =
GQLError :: Message -> [Position] -> GQLError
GQLError
{ Message
message :: Message
message :: Message
message,
[Position]
locations :: [Position]
locations :: [Position]
locations
}
where
message :: Message
message
| Config -> Bool
debug Config
config = Message
text Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> ValidatorContext s ctx -> Message
forall (s :: Stage) ctx. ValidatorContext s ctx -> Message
renderContext ValidatorContext s ctx
context
| Bool
otherwise = Message
text
instance
(MonadContext (Validator s) s ctx) =>
Failure InternalError (Validator s ctx)
where
failure :: InternalError -> Validator s ctx v
failure InternalError
inputMessage = do
ValidatorContext s ctx
ctx <- ReaderT (ValidatorContext s ctx) Eventless (ValidatorContext s ctx)
-> Validator s ctx (ValidatorContext s ctx)
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) Eventless a -> Validator s ctx a
Validator ReaderT (ValidatorContext s ctx) Eventless (ValidatorContext s ctx)
forall r (m :: * -> *). MonadReader r m => m r
ask
ValidationError -> Validator s ctx v
forall error (f :: * -> *) v. Failure error f => error -> f v
failure
( Maybe Position -> Message -> ValidationError
validationErrorMessage
(Scope -> Maybe Position
position (Scope -> Maybe Position) -> Scope -> Maybe Position
forall a b. (a -> b) -> a -> b
$ ValidatorContext s ctx -> Scope
forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
scope ValidatorContext s ctx
ctx)
(Message -> ValidationError) -> Message -> ValidationError
forall a b. (a -> b) -> a -> b
$ InternalError -> Message
forall a. Msg a => a -> Message
msg
InternalError
inputMessage
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> ValidatorContext s ctx -> Message
forall (s :: Stage) ctx. ValidatorContext s ctx -> Message
renderContext ValidatorContext s ctx
ctx
)
renderContext :: ValidatorContext s ctx -> Message
renderContext :: ValidatorContext s ctx -> Message
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 -> Message
renderScope Scope
scope
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message -> Schema s -> Message
forall a. RenderGQL a => Message -> a -> Message
renderSection Message
"SchemaDefinition" Schema s
schema
renderScope :: Scope -> Message
renderScope :: Scope -> Message
renderScope
Scope
{ TypeName
currentTypeName :: TypeName
currentTypeName :: Scope -> TypeName
currentTypeName,
TypeKind
currentTypeKind :: TypeKind
currentTypeKind :: Scope -> TypeKind
currentTypeKind,
FieldName
fieldname :: FieldName
fieldname :: Scope -> FieldName
fieldname
} =
Message -> ByteString -> Message
forall a. RenderGQL a => Message -> a -> Message
renderSection
Message
"Scope"
( ByteString
"referenced by type "
ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> TypeName -> ByteString
forall a. RenderGQL a => a -> ByteString
renderGQL TypeName
currentTypeName
ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" of kind "
ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> TypeKind -> ByteString
forall a. RenderGQL a => a -> ByteString
renderGQL TypeKind
currentTypeKind
ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" in field "
ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> FieldName -> ByteString
forall a. RenderGQL a => a -> ByteString
renderGQL FieldName
fieldname
)
renderSection :: RenderGQL a => Message -> a -> Message
renderSection :: Message -> a -> Message
renderSection Message
label a
content =
Message
"\n\n" Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
label Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
":\n" Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
line
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
"\n\n"
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> ByteString -> Message
forall a. Msg a => a -> Message
msg (a -> ByteString
forall a. RenderGQL a => a -> ByteString
renderGQL a
content)
Message -> Message -> Message
forall a. Semigroup a => a -> a -> a
<> Message
"\n\n"
where
line :: Message
line = Int -> Message -> Message
forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes (Int
50 :: Int) Message
"-"