{-# 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

--  UNION  :: Constraint 'TARGET_UNION

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
..}

-- Helpers
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

-- Setters
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

-- can be only used for internal errors
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
"-"