{-# 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 Data.Morpheus.Internal.Utils
  ( Failure (..),
    selectBy,
  )
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    FieldsDefinition,
    FromCategory,
    IMPLEMENTABLE,
    IN,
    InternalError,
    OBJECT,
    OUT,
    Operation,
    Operation (..),
    Stage,
    TRUE,
    Token,
    TypeCategory,
    TypeContent (..),
    TypeContent,
    TypeDefinition (..),
    TypeName (..),
    TypeRef,
    Typed,
    UnionMember (..),
    VALID,
    fromAny,
    fromCategory,
    getOperationDataType,
    msgInternal,
    possibleInterfaceTypes,
    typeConName,
    typed,
    untyped,
  )
import Data.Morpheus.Types.Internal.Validation.Validator
  ( MonadContext,
    SelectionValidator,
    askSchema,
  )
import Relude

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

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

__askType ::
  Constraints m c cat s => TypeName -> m c (TypeDefinition cat s)
__askType :: TypeName -> m c (TypeDefinition cat s)
__askType TypeName
name =
  m c (Schema s)
forall (m :: * -> * -> *) (s :: Stage) c.
MonadContext m s c =>
m c (Schema s)
askSchema
    m c (Schema s)
-> (Schema s -> m c (TypeDefinition ANY s))
-> m c (TypeDefinition ANY s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InternalError -> TypeName -> Schema s -> m c (TypeDefinition ANY s)
forall e (m :: * -> *) k a c.
(Failure e m, Selectable k a c, Monad m) =>
e -> k -> c -> m a
selectBy (TypeName -> InternalError
unknownType TypeName
name) TypeName
name
    m c (TypeDefinition ANY s)
-> (TypeDefinition ANY s -> m c (TypeDefinition cat s))
-> m c (TypeDefinition cat s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeDefinition ANY s -> m c (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 =>
  UnionMember cat s ->
  m c (TypeMemberResponse cat s)
askTypeMember :: UnionMember cat s -> m c (TypeMemberResponse cat s)
askTypeMember = Typed cat s TypeName -> m c (TypeDefinition cat s)
forall (m :: * -> * -> *) c (cat :: TypeCategory) (s :: Stage).
Constraints m c cat s =>
Typed cat s TypeName -> m c (TypeDefinition cat s)
askType2 (Typed cat s TypeName -> m c (TypeDefinition cat s))
-> (UnionMember cat s -> Typed cat s TypeName)
-> UnionMember cat s
-> m c (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 c (TypeDefinition cat s))
-> (TypeDefinition cat s -> m c (TypeMemberResponse cat s))
-> UnionMember cat s
-> m c (TypeMemberResponse cat s)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> TypeDefinition cat s -> m c (TypeMemberResponse cat s)
forall (c :: TypeCategory) (f :: * -> *) (s :: Stage).
(KindErrors c, Applicative f, Failure InternalError f) =>
TypeDefinition c s -> f (TypeMemberResponse c s)
constraintObject

askInterfaceTypes ::
  ( Failure InternalError (m c),
    Monad (m c),
    MonadContext m s c,
    FromCategory (TypeContent TRUE) ANY IMPLEMENTABLE
  ) =>
  TypeDefinition IMPLEMENTABLE s ->
  m c [TypeDefinition IMPLEMENTABLE s]
askInterfaceTypes :: TypeDefinition IMPLEMENTABLE s
-> m c [TypeDefinition IMPLEMENTABLE s]
askInterfaceTypes typeDef :: TypeDefinition IMPLEMENTABLE s
typeDef@TypeDefinition {TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName :: TypeName
typeName} =
  (TypeDefinition IMPLEMENTABLE s
typeDef TypeDefinition IMPLEMENTABLE s
-> [TypeDefinition IMPLEMENTABLE s]
-> [TypeDefinition IMPLEMENTABLE s]
forall a. a -> [a] -> [a]
:)
    ([TypeDefinition IMPLEMENTABLE s]
 -> [TypeDefinition IMPLEMENTABLE s])
-> m c [TypeDefinition IMPLEMENTABLE s]
-> m c [TypeDefinition IMPLEMENTABLE s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( m c (Schema s)
forall (m :: * -> * -> *) (s :: Stage) c.
MonadContext m s c =>
m c (Schema s)
askSchema
            m c (Schema s)
-> (Schema s -> m c [TypeDefinition IMPLEMENTABLE s])
-> m c [TypeDefinition IMPLEMENTABLE s]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (TypeDefinition ANY s -> m c (TypeDefinition IMPLEMENTABLE s))
-> [TypeDefinition ANY s] -> m c [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 c (TypeDefinition IMPLEMENTABLE s)
forall (f :: * -> *) a. Failure InternalError f => Maybe a -> f a
validate (Maybe (TypeDefinition IMPLEMENTABLE s)
 -> m c (TypeDefinition IMPLEMENTABLE s))
-> (TypeDefinition ANY s -> Maybe (TypeDefinition IMPLEMENTABLE s))
-> TypeDefinition ANY s
-> m c (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 c [TypeDefinition IMPLEMENTABLE s])
-> (Schema s -> [TypeDefinition ANY s])
-> Schema s
-> m c [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
        )
  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 = InternalError -> f a
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (InternalError
"TODO: invalid interface Types" :: InternalError)

type family TypeMemberResponse (cat :: TypeCategory) (s :: Stage)

type instance TypeMemberResponse OUT s = TypeDefinition OBJECT s

type instance TypeMemberResponse IN s = (TypeDefinition IN s, FieldsDefinition IN s)

type Constraints m c cat s =
  ( Failure InternalError (m c),
    Monad (m c),
    MonadContext m s c,
    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 = Validator VALID (OperationContext VALID VALID) (Schema VALID)
forall (m :: * -> * -> *) (s :: Stage) c.
MonadContext m s c =>
m c (Schema s)
askSchema Validator VALID (OperationContext VALID VALID) (Schema VALID)
-> (Schema VALID
    -> SelectionValidator (TypeDefinition OBJECT VALID))
-> SelectionValidator (TypeDefinition OBJECT VALID)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Operation a
-> Schema VALID -> SelectionValidator (TypeDefinition OBJECT VALID)
forall (m :: * -> *) (s :: Stage).
Failure ValidationError m =>
Operation s -> Schema VALID -> m (TypeDefinition OBJECT VALID)
getOperationDataType Operation a
operation

unknownType :: TypeName -> InternalError
unknownType :: TypeName -> InternalError
unknownType TypeName
name = InternalError
"Type \"" InternalError -> InternalError -> InternalError
forall a. Semigroup a => a -> a -> a
<> TypeName -> InternalError
forall a. Msg a => a -> InternalError
msgInternal TypeName
name InternalError -> InternalError -> InternalError
forall a. Semigroup a => a -> a -> a
<> InternalError
"\" can't found in Schema."

type KindConstraint f c =
  ( Failure InternalError 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
    (InternalError -> f (TypeDefinition k s)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (InternalError -> f (TypeDefinition k s))
-> InternalError -> f (TypeDefinition k s)
forall a b. (a -> b) -> a -> b
$ Token -> TypeName -> InternalError
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,
      Failure InternalError f
    ) =>
    TypeDefinition c s ->
    f (TypeMemberResponse 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 (TypeMemberResponse IN s)
constraintObject typeDef :: TypeDefinition IN s
typeDef@TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataInputObject FieldsDefinition IN s
inputFields} = (TypeDefinition IN s, FieldsDefinition IN s)
-> f (TypeDefinition IN s, FieldsDefinition IN s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition IN s
typeDef, FieldsDefinition IN s
inputFields)
  constraintObject TypeDefinition {TypeName
typeName :: TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName} = InternalError -> f (TypeDefinition IN s, FieldsDefinition IN s)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (Token -> TypeName -> InternalError
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 (TypeMemberResponse 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).
TypeContent (ELEM OBJECT a) a s -> FieldsDefinition OUT s
objectImplements :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> [TypeName]
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
..}, Directives s
Maybe Token
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 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 -> TypeContent (ELEM OBJECT a) a s
DataObject {[TypeName]
FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
objectFields :: FieldsDefinition OUT s
objectImplements :: [TypeName]
..}, Directives s
Maybe Token
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} = InternalError -> f (TypeDefinition OBJECT s)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (Token -> TypeName -> InternalError
violation Token
"object" TypeName
typeName)

violation ::
  Token ->
  TypeName ->
  InternalError
violation :: Token -> TypeName -> InternalError
violation Token
kind TypeName
typeName =
  InternalError
"Type \"" InternalError -> InternalError -> InternalError
forall a. Semigroup a => a -> a -> a
<> TypeName -> InternalError
forall a. Msg a => a -> InternalError
msgInternal TypeName
typeName
    InternalError -> InternalError -> InternalError
forall a. Semigroup a => a -> a -> a
<> InternalError
"\" must be an"
    InternalError -> InternalError -> InternalError
forall a. Semigroup a => a -> a -> a
<> Token -> InternalError
forall a. Msg a => a -> InternalError
msgInternal Token
kind
    InternalError -> InternalError -> InternalError
forall a. Semigroup a => a -> a -> a
<> InternalError
"."