{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Types.Internal.Validation.Internal
  ( askType,
    askTypeMember,
    getOperationType,
    askInterfaceTypes,
  )
where

import Control.Monad.Except (MonadError (throwError))
import Data.Morpheus.Internal.Utils
  ( fromElems,
  )
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    FromCategory,
    GQLError,
    IMPLEMENTABLE,
    IN,
    OBJECT,
    OUT,
    Operation (..),
    OrdMap,
    TRUE,
    ToOBJECT,
    Token,
    TypeName,
    TypeRef,
    UnionMember (..),
    VALID,
    fromAny,
    fromCategory,
    getOperationDataType,
    internal,
    msg,
    typeConName,
  )
import Data.Morpheus.Types.Internal.AST.TypeSystem
import Data.Morpheus.Types.Internal.Validation.Validator
  ( SelectionValidator,
    ValidatorContext (schema),
  )
import Relude

askType ::
  Constraints m c cat s ctx =>
  Typed cat s TypeRef ->
  m (TypeDefinition cat s)
askType :: Typed cat s TypeRef -> m (TypeDefinition cat s)
askType = (TypeRef -> m (TypeDefinition cat s))
-> Typed cat s TypeRef -> m (TypeDefinition cat s)
forall a b (c :: TypeCategory) (s :: Stage).
(a -> b) -> Typed c s a -> b
untyped (TypeName -> m (TypeDefinition cat s)
forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx.
Constraints m c cat s ctx =>
TypeName -> m (TypeDefinition cat s)
__askType (TypeName -> m (TypeDefinition cat s))
-> (TypeRef -> TypeName) -> TypeRef -> m (TypeDefinition cat s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRef -> TypeName
typeConName)

askType2 ::
  Constraints m c cat s ctx =>
  Typed cat s TypeName ->
  m (TypeDefinition cat s)
askType2 :: Typed cat s TypeName -> m (TypeDefinition cat s)
askType2 = (TypeName -> m (TypeDefinition cat s))
-> Typed cat s TypeName -> m (TypeDefinition cat s)
forall a b (c :: TypeCategory) (s :: Stage).
(a -> b) -> Typed c s a -> b
untyped TypeName -> m (TypeDefinition cat s)
forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx.
Constraints m c cat s ctx =>
TypeName -> m (TypeDefinition cat s)
__askType

__askType ::
  Constraints m c cat s ctx => TypeName -> m (TypeDefinition cat s)
__askType :: TypeName -> m (TypeDefinition cat s)
__askType TypeName
name =
  (ValidatorContext s ctx -> Schema s) -> m (Schema s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidatorContext s ctx -> Schema s
forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
schema
    m (Schema s)
-> (Schema s -> m (TypeDefinition ANY s))
-> m (TypeDefinition ANY s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (TypeDefinition ANY s)
-> (TypeDefinition ANY s -> m (TypeDefinition ANY s))
-> Maybe (TypeDefinition ANY s)
-> m (TypeDefinition ANY s)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (GQLError -> m (TypeDefinition ANY s)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TypeName -> GQLError
unknownType TypeName
name)) TypeDefinition ANY s -> m (TypeDefinition ANY s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TypeDefinition ANY s) -> m (TypeDefinition ANY s))
-> (Schema s -> Maybe (TypeDefinition ANY s))
-> Schema s
-> m (TypeDefinition ANY s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Schema s -> Maybe (TypeDefinition ANY s)
forall (s :: Stage).
TypeName -> Schema s -> Maybe (TypeDefinition ANY s)
lookupDataType TypeName
name
    m (TypeDefinition ANY s)
-> (TypeDefinition ANY s -> m (TypeDefinition cat s))
-> m (TypeDefinition cat s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeDefinition ANY s -> m (TypeDefinition cat s)
forall (c :: TypeCategory) (f :: * -> *) (s :: Stage).
(KindErrors c, KindConstraint f c) =>
TypeDefinition ANY s -> f (TypeDefinition c s)
kindConstraint

askTypeMember ::
  Constraints m c cat s ctx =>
  UnionMember cat s ->
  m (TypeDefinition (ToOBJECT cat) s)
askTypeMember :: UnionMember cat s -> m (TypeDefinition (ToOBJECT cat) s)
askTypeMember = Typed cat s TypeName -> m (TypeDefinition cat s)
forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx.
Constraints m c cat s ctx =>
Typed cat s TypeName -> m (TypeDefinition cat s)
askType2 (Typed cat s TypeName -> m (TypeDefinition cat s))
-> (UnionMember cat s -> Typed cat s TypeName)
-> UnionMember cat s
-> m (TypeDefinition cat s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnionMember cat s -> TypeName)
-> UnionMember cat s -> Typed cat s TypeName
forall (a :: TypeCategory -> Stage -> *) (c :: TypeCategory)
       (s :: Stage) b.
(a c s -> b) -> a c s -> Typed c s b
typed UnionMember cat s -> TypeName
forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName (UnionMember cat s -> m (TypeDefinition cat s))
-> (TypeDefinition cat s -> m (TypeDefinition (ToOBJECT cat) s))
-> UnionMember cat s
-> m (TypeDefinition (ToOBJECT cat) s)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> TypeDefinition cat s -> m (TypeDefinition (ToOBJECT cat) s)
forall (c :: TypeCategory) (f :: * -> *) (s :: Stage).
(KindErrors c, Applicative f, MonadError GQLError f) =>
TypeDefinition c s -> f (TypeDefinition (ToOBJECT c) s)
constraintObject

askInterfaceTypes ::
  ( MonadError GQLError m,
    MonadReader (ValidatorContext s ctx) m,
    FromCategory (TypeContent TRUE) ANY IMPLEMENTABLE
  ) =>
  TypeDefinition IMPLEMENTABLE s ->
  m (OrdMap TypeName (TypeDefinition IMPLEMENTABLE s))
askInterfaceTypes :: TypeDefinition IMPLEMENTABLE s
-> m (OrdMap TypeName (TypeDefinition IMPLEMENTABLE s))
askInterfaceTypes typeDef :: TypeDefinition IMPLEMENTABLE s
typeDef@TypeDefinition {TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName :: TypeName
typeName} =
  (ValidatorContext s ctx -> Schema s) -> m (Schema s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidatorContext s ctx -> Schema s
forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
schema
    m (Schema s)
-> (Schema s -> m [TypeDefinition IMPLEMENTABLE s])
-> m [TypeDefinition IMPLEMENTABLE s]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (TypeDefinition ANY s -> m (TypeDefinition IMPLEMENTABLE s))
-> [TypeDefinition ANY s] -> m [TypeDefinition IMPLEMENTABLE s]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Maybe (TypeDefinition IMPLEMENTABLE s)
-> m (TypeDefinition IMPLEMENTABLE s)
forall (f :: * -> *) a. MonadError GQLError f => Maybe a -> f a
validate (Maybe (TypeDefinition IMPLEMENTABLE s)
 -> m (TypeDefinition IMPLEMENTABLE s))
-> (TypeDefinition ANY s -> Maybe (TypeDefinition IMPLEMENTABLE s))
-> TypeDefinition ANY s
-> m (TypeDefinition IMPLEMENTABLE s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDefinition ANY s -> Maybe (TypeDefinition IMPLEMENTABLE s)
forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (k' :: TypeCategory) (s :: Stage).
FromCategory a k k' =>
a k s -> Maybe (a k' s)
fromCategory) ([TypeDefinition ANY s] -> m [TypeDefinition IMPLEMENTABLE s])
-> (Schema s -> [TypeDefinition ANY s])
-> Schema s
-> m [TypeDefinition IMPLEMENTABLE s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Schema s -> [TypeDefinition ANY s]
forall (s :: Stage). TypeName -> Schema s -> [TypeDefinition ANY s]
possibleInterfaceTypes TypeName
typeName
    m [TypeDefinition IMPLEMENTABLE s]
-> ([TypeDefinition IMPLEMENTABLE s]
    -> m (OrdMap TypeName (TypeDefinition IMPLEMENTABLE s)))
-> m (OrdMap TypeName (TypeDefinition IMPLEMENTABLE s))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [TypeDefinition IMPLEMENTABLE s]
-> m (OrdMap TypeName (TypeDefinition IMPLEMENTABLE s))
forall (m :: * -> *) k a (map :: * -> * -> *).
(Monad m, KeyOf k a, FromList m map k a) =>
[a] -> m (map k a)
fromElems ([TypeDefinition IMPLEMENTABLE s]
 -> m (OrdMap TypeName (TypeDefinition IMPLEMENTABLE s)))
-> ([TypeDefinition IMPLEMENTABLE s]
    -> [TypeDefinition IMPLEMENTABLE s])
-> [TypeDefinition IMPLEMENTABLE s]
-> m (OrdMap TypeName (TypeDefinition IMPLEMENTABLE s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeDefinition IMPLEMENTABLE s
typeDef TypeDefinition IMPLEMENTABLE s
-> [TypeDefinition IMPLEMENTABLE s]
-> [TypeDefinition IMPLEMENTABLE s]
forall a. a -> [a] -> [a]
:)
  where
    validate :: Maybe a -> f a
validate (Just a
x) = a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    validate Maybe a
Nothing = GQLError -> f a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"Invalid interface Types")

type Constraints m c cat s ctx =
  ( MonadError GQLError m,
    Monad m,
    MonadReader (ValidatorContext s ctx) m,
    KindErrors cat,
    FromCategory (TypeContent TRUE) ANY cat
  )

getOperationType :: Operation a -> SelectionValidator (TypeDefinition OBJECT VALID)
getOperationType :: Operation a -> SelectionValidator (TypeDefinition OBJECT VALID)
getOperationType Operation a
operation = (ValidatorContext VALID (OperationContext VALID VALID)
 -> Schema VALID)
-> Validator VALID (OperationContext VALID VALID) (Schema VALID)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidatorContext VALID (OperationContext VALID VALID)
-> Schema VALID
forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
schema Validator VALID (OperationContext VALID VALID) (Schema VALID)
-> (Schema VALID
    -> Validator
         VALID (OperationContext VALID VALID) (TypeDefinition OBJECT VALID))
-> Validator
     VALID (OperationContext VALID VALID) (TypeDefinition OBJECT VALID)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Operation a
-> Schema VALID
-> Validator
     VALID (OperationContext VALID VALID) (TypeDefinition OBJECT VALID)
forall (m :: * -> *) (s :: Stage).
MonadError GQLError m =>
Operation s -> Schema VALID -> m (TypeDefinition OBJECT VALID)
getOperationDataType Operation a
operation

unknownType :: TypeName -> GQLError
unknownType :: TypeName -> GQLError
unknownType TypeName
name = GQLError -> GQLError
internal (GQLError -> GQLError) -> GQLError -> GQLError
forall a b. (a -> b) -> a -> b
$ GQLError
"Type \"" GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> GQLError
forall a. Msg a => a -> GQLError
msg TypeName
name GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
"\" can't found in Schema."

type KindConstraint f c =
  ( MonadError GQLError f,
    FromCategory TypeDefinition ANY c
  )

_kindConstraint ::
  KindConstraint f k =>
  Token ->
  TypeDefinition ANY s ->
  f (TypeDefinition k s)
_kindConstraint :: Token -> TypeDefinition ANY s -> f (TypeDefinition k s)
_kindConstraint Token
err TypeDefinition ANY s
anyType =
  f (TypeDefinition k s)
-> (TypeDefinition k s -> f (TypeDefinition k s))
-> Maybe (TypeDefinition k s)
-> f (TypeDefinition k s)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    (GQLError -> f (TypeDefinition k s)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> f (TypeDefinition k s))
-> GQLError -> f (TypeDefinition k s)
forall a b. (a -> b) -> a -> b
$ Token -> TypeName -> GQLError
violation Token
err (TypeDefinition ANY s -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeDefinition ANY s
anyType))
    TypeDefinition k s -> f (TypeDefinition k s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (TypeDefinition ANY s -> Maybe (TypeDefinition k s)
forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (s :: Stage).
FromCategory a ANY k =>
a ANY s -> Maybe (a k s)
fromAny TypeDefinition ANY s
anyType)

class KindErrors c where
  kindConstraint :: KindConstraint f c => TypeDefinition ANY s -> f (TypeDefinition c s)
  constraintObject ::
    ( Applicative f,
      MonadError GQLError f
    ) =>
    TypeDefinition c s ->
    f (TypeDefinition (ToOBJECT c) s)

instance KindErrors IN where
  kindConstraint :: TypeDefinition ANY s -> f (TypeDefinition IN s)
kindConstraint = Token -> TypeDefinition ANY s -> f (TypeDefinition IN s)
forall (f :: * -> *) (k :: TypeCategory) (s :: Stage).
KindConstraint f k =>
Token -> TypeDefinition ANY s -> f (TypeDefinition k s)
_kindConstraint Token
"input type"
  constraintObject :: TypeDefinition IN s -> f (TypeDefinition (ToOBJECT IN) s)
constraintObject TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataInputObject {FieldsDefinition IN s
inputObjectFields :: forall (a :: TypeCategory) (s :: Stage).
CondTypeContent INPUT_OBJECT a s -> FieldsDefinition IN s
inputObjectFields :: FieldsDefinition IN s
..}, Maybe Token
Directives s
TypeName
typeDirectives :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Token
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Token
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
..} = TypeDefinition INPUT_OBJECT s -> f (TypeDefinition INPUT_OBJECT s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeDefinition :: forall (a :: TypeCategory) (s :: Stage).
Maybe Token
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition {typeContent :: TypeContent TRUE INPUT_OBJECT s
typeContent = DataInputObject :: forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition IN s -> CondTypeContent INPUT_OBJECT a s
DataInputObject {FieldsDefinition IN s
inputObjectFields :: FieldsDefinition IN s
inputObjectFields :: FieldsDefinition IN s
..}, Maybe Token
Directives s
TypeName
typeDirectives :: Directives s
typeDescription :: Maybe Token
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Token
typeName :: TypeName
..}
  constraintObject TypeDefinition {TypeName
typeName :: TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName} = GQLError -> f (TypeDefinition INPUT_OBJECT s)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Token -> TypeName -> GQLError
violation Token
"input object" TypeName
typeName)

instance KindErrors OUT where
  kindConstraint :: TypeDefinition ANY s -> f (TypeDefinition OUT s)
kindConstraint = Token -> TypeDefinition ANY s -> f (TypeDefinition OUT s)
forall (f :: * -> *) (k :: TypeCategory) (s :: Stage).
KindConstraint f k =>
Token -> TypeDefinition ANY s -> f (TypeDefinition k s)
_kindConstraint Token
"output type"
  constraintObject :: TypeDefinition OUT s -> f (TypeDefinition (ToOBJECT OUT) s)
constraintObject TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataObject {[TypeName]
FieldsDefinition OUT s
objectFields :: forall (a :: TypeCategory) (s :: Stage).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectImplements :: forall (a :: TypeCategory) (s :: Stage).
CondTypeContent OBJECT a s -> [TypeName]
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
..}, Maybe Token
Directives s
TypeName
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Token
typeDirectives :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Token
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
..} = TypeDefinition OBJECT s -> f (TypeDefinition OBJECT s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeDefinition :: forall (a :: TypeCategory) (s :: Stage).
Maybe Token
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition {typeContent :: TypeContent TRUE OBJECT s
typeContent = DataObject :: forall (s :: Stage) (a :: TypeCategory).
[TypeName] -> FieldsDefinition OUT s -> CondTypeContent OBJECT a s
DataObject {[TypeName]
FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
..}, Maybe Token
Directives s
TypeName
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Token
typeDirectives :: Directives s
typeDescription :: Maybe Token
typeName :: TypeName
..}
  constraintObject TypeDefinition {TypeName
typeName :: TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName} = GQLError -> f (TypeDefinition OBJECT s)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Token -> TypeName -> GQLError
violation Token
"object" TypeName
typeName)

violation ::
  Token ->
  TypeName ->
  GQLError
violation :: Token -> TypeName -> GQLError
violation Token
kind TypeName
typeName =
  GQLError -> GQLError
internal (GQLError -> GQLError) -> GQLError -> GQLError
forall a b. (a -> b) -> a -> b
$
    GQLError
"Type \"" GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> GQLError
forall a. Msg a => a -> GQLError
msg TypeName
typeName
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
"\" must be an"
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> Token -> GQLError
forall a. Msg a => a -> GQLError
msg Token
kind
      GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
"."