{-# 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 :: forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx.
Constraints m c cat s ctx =>
Typed cat s TypeRef -> m (TypeDefinition cat s)
askType = forall a b (c :: TypeCategory) (s :: Stage).
(a -> b) -> Typed c s a -> b
untyped (forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx.
Constraints m c cat s ctx =>
TypeName -> m (TypeDefinition cat s)
__askType 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 :: forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx.
Constraints m c cat s ctx =>
Typed cat s TypeName -> m (TypeDefinition cat s)
askType2 = forall a b (c :: TypeCategory) (s :: Stage).
(a -> b) -> Typed c s a -> b
untyped 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 :: forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx.
Constraints m c cat s ctx =>
TypeName -> m (TypeDefinition cat s)
__askType TypeName
name =
  forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
schema
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TypeName -> GQLError
unknownType TypeName
name)) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage).
TypeName -> Schema s -> Maybe (TypeDefinition ANY s)
lookupDataType TypeName
name
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 :: forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx.
Constraints m c cat s ctx =>
UnionMember cat s -> m (TypeDefinition (ToOBJECT cat) s)
askTypeMember = forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx.
Constraints m c cat s ctx =>
Typed cat s TypeName -> m (TypeDefinition cat s)
askType2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: TypeCategory -> Stage -> *) (c :: TypeCategory)
       (s :: Stage) b.
(a c s -> b) -> a c s -> Typed c s b
typed forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> 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 :: forall (m :: * -> *) (s :: Stage) ctx.
(MonadError GQLError m, MonadReader (ValidatorContext s ctx) m,
 FromCategory (TypeContent TRUE) ANY IMPLEMENTABLE) =>
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} =
  forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
schema
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall {f :: * -> *} {a}. MonadError GQLError f => Maybe a -> f a
validate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (k' :: TypeCategory) (s :: Stage).
FromCategory a k k' =>
a k s -> Maybe (a k' s)
fromCategory) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage). TypeName -> Schema s -> [TypeDefinition ANY s]
possibleInterfaceTypes TypeName
typeName
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) k a (map :: * -> * -> *).
(Monad m, KeyOf k a, FromList m map k a) =>
[a] -> m (map k a)
fromElems forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeDefinition IMPLEMENTABLE s
typeDef forall a. a -> [a] -> [a]
:)
  where
    validate :: Maybe a -> f a
validate (Just a
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    validate Maybe a
Nothing = 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 :: forall (a :: Stage).
Operation a -> SelectionValidator (TypeDefinition OBJECT VALID)
getOperationType Operation a
operation = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
schema forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 forall a b. (a -> b) -> a -> b
$ GQLError
"Type \"" forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg TypeName
name 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 :: forall (f :: * -> *) (k :: TypeCategory) (s :: Stage).
KindConstraint f k =>
Token -> TypeDefinition ANY s -> f (TypeDefinition k s)
_kindConstraint Token
err TypeDefinition ANY s
anyType =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Token -> TypeName -> GQLError
violation Token
err (forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeDefinition ANY s
anyType))
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (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 :: forall (f :: * -> *) (s :: Stage).
KindConstraint f IN =>
TypeDefinition ANY s -> f (TypeDefinition IN s)
kindConstraint = forall (f :: * -> *) (k :: TypeCategory) (s :: Stage).
KindConstraint f k =>
Token -> TypeDefinition ANY s -> f (TypeDefinition k s)
_kindConstraint Token
"input type"
  constraintObject :: forall (f :: * -> *) (s :: Stage).
(Applicative f, MonadError GQLError f) =>
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 (s :: Stage) (a :: TypeCategory).
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
..} = forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeDefinition {typeContent :: TypeContent TRUE INPUT_OBJECT s
typeContent = 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} = 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 :: forall (f :: * -> *) (s :: Stage).
KindConstraint f OUT =>
TypeDefinition ANY s -> f (TypeDefinition OUT s)
kindConstraint = forall (f :: * -> *) (k :: TypeCategory) (s :: Stage).
KindConstraint f k =>
Token -> TypeDefinition ANY s -> f (TypeDefinition k s)
_kindConstraint Token
"output type"
  constraintObject :: forall (f :: * -> *) (s :: Stage).
(Applicative f, MonadError GQLError f) =>
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 (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectImplements :: forall (s :: Stage) (a :: TypeCategory).
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
..} = forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeDefinition {typeContent :: TypeContent TRUE OBJECT s
typeContent = 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} = 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 forall a b. (a -> b) -> a -> b
$
    GQLError
"Type \""
      forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg TypeName
typeName
      forall a. Semigroup a => a -> a -> a
<> GQLError
"\" must be an"
      forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg Token
kind
      forall a. Semigroup a => a -> a -> a
<> GQLError
"."