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

module Data.Morpheus.Types.Internal.Validation.SchemaValidator
  ( SchemaValidator,
    TypeSystemContext (..),
    constraintInterface,
    renderField,
    withLocalContext,
    runSchemaValidator,
    inInterface,
    inType,
    inField,
    inArgument,
    ON_INTERFACE,
    ON_TYPE,
    TypeEntity (..),
    Field (..),
    InterfaceName (..),
    PLACE,
  )
where

import Control.Monad.Except (throwError)
import Data.Morpheus.Ext.Result (GQLResult)
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    CONST,
    FieldName,
    FieldsDefinition,
    Name,
    OUT,
    PropName (PropName),
    TypeContent (..),
    TypeDefinition (..),
    TypeName,
    mkBaseType,
    msg,
    unpackName,
  )
import Data.Morpheus.Types.Internal.AST.Type (TypeKind (KindObject))
import Data.Morpheus.Types.Internal.AST.TypeSystem (Schema)
import Data.Morpheus.Types.Internal.Config (Config)
import Data.Morpheus.Types.Internal.Validation (Scope (..), ScopeKind (TYPE), runValidator)
import Data.Morpheus.Types.Internal.Validation.Validator
  ( Validator (..),
    renderField,
    withContext,
    withScope,
  )
import Relude hiding (local)

inInterface ::
  TypeName ->
  SchemaValidator (TypeEntity 'ON_INTERFACE) v ->
  SchemaValidator (TypeEntity 'ON_TYPE) v
inInterface :: TypeName
-> SchemaValidator (TypeEntity 'ON_INTERFACE) v
-> SchemaValidator (TypeEntity 'ON_TYPE) v
inInterface TypeName
name = TypeName
-> SchemaValidator (TypeEntity 'ON_TYPE) v
-> SchemaValidator (TypeEntity 'ON_TYPE) v
forall (t :: NAME) a v.
Name t -> SchemaValidator a v -> SchemaValidator a v
pushPath TypeName
name (SchemaValidator (TypeEntity 'ON_TYPE) v
 -> SchemaValidator (TypeEntity 'ON_TYPE) v)
-> (SchemaValidator (TypeEntity 'ON_INTERFACE) v
    -> SchemaValidator (TypeEntity 'ON_TYPE) v)
-> SchemaValidator (TypeEntity 'ON_INTERFACE) v
-> SchemaValidator (TypeEntity 'ON_TYPE) v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeEntity 'ON_TYPE -> TypeEntity 'ON_INTERFACE)
-> SchemaValidator (TypeEntity 'ON_INTERFACE) v
-> SchemaValidator (TypeEntity 'ON_TYPE) v
forall a b v.
(a -> b) -> SchemaValidator b v -> SchemaValidator a v
withLocalContext (\TypeEntity 'ON_TYPE
t -> TypeEntity 'ON_TYPE
t {$sel:interfaceName:TypeEntity :: InterfaceName 'ON_INTERFACE
interfaceName = TypeName -> InterfaceName 'ON_INTERFACE
OnInterface TypeName
name})

inType ::
  TypeName ->
  SchemaValidator (TypeEntity 'ON_TYPE) v ->
  SchemaValidator () v
inType :: TypeName
-> SchemaValidator (TypeEntity 'ON_TYPE) v -> SchemaValidator () v
inType TypeName
name = TypeName -> SchemaValidator () v -> SchemaValidator () v
forall (t :: NAME) a v.
Name t -> SchemaValidator a v -> SchemaValidator a v
pushPath TypeName
name (SchemaValidator () v -> SchemaValidator () v)
-> (SchemaValidator (TypeEntity 'ON_TYPE) v
    -> SchemaValidator () v)
-> SchemaValidator (TypeEntity 'ON_TYPE) v
-> SchemaValidator () v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() -> TypeEntity 'ON_TYPE)
-> SchemaValidator (TypeEntity 'ON_TYPE) v -> SchemaValidator () v
forall a b v.
(a -> b) -> SchemaValidator b v -> SchemaValidator a v
withLocalContext (TypeEntity 'ON_TYPE -> () -> TypeEntity 'ON_TYPE
forall a b. a -> b -> a
const (InterfaceName 'ON_TYPE -> TypeName -> TypeEntity 'ON_TYPE
forall (p :: PLACE). InterfaceName p -> TypeName -> TypeEntity p
TypeEntity InterfaceName 'ON_TYPE
OnType TypeName
name))

inField ::
  FieldName ->
  SchemaValidator (Field p) v ->
  SchemaValidator (TypeEntity p) v
inField :: FieldName
-> SchemaValidator (Field p) v -> SchemaValidator (TypeEntity p) v
inField FieldName
fieldName = FieldName
-> SchemaValidator (TypeEntity p) v
-> SchemaValidator (TypeEntity p) v
forall (t :: NAME) a v.
Name t -> SchemaValidator a v -> SchemaValidator a v
pushPath FieldName
fieldName (SchemaValidator (TypeEntity p) v
 -> SchemaValidator (TypeEntity p) v)
-> (SchemaValidator (Field p) v
    -> SchemaValidator (TypeEntity p) v)
-> SchemaValidator (Field p) v
-> SchemaValidator (TypeEntity p) v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeEntity p -> Field p)
-> SchemaValidator (Field p) v -> SchemaValidator (TypeEntity p) v
forall a b v.
(a -> b) -> SchemaValidator b v -> SchemaValidator a v
withLocalContext (FieldName -> Maybe FieldName -> TypeEntity p -> Field p
forall (p :: PLACE).
FieldName -> Maybe FieldName -> TypeEntity p -> Field p
Field FieldName
fieldName Maybe FieldName
forall a. Maybe a
Nothing)

inArgument ::
  FieldName ->
  SchemaValidator (Field p) v ->
  SchemaValidator (Field p) v
inArgument :: FieldName
-> SchemaValidator (Field p) v -> SchemaValidator (Field p) v
inArgument FieldName
name = FieldName
-> SchemaValidator (Field p) v -> SchemaValidator (Field p) v
forall (t :: NAME) a v.
Name t -> SchemaValidator a v -> SchemaValidator a v
pushPath FieldName
name (SchemaValidator (Field p) v -> SchemaValidator (Field p) v)
-> (SchemaValidator (Field p) v -> SchemaValidator (Field p) v)
-> SchemaValidator (Field p) v
-> SchemaValidator (Field p) v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Field p -> Field p)
-> SchemaValidator (Field p) v -> SchemaValidator (Field p) v
forall a b v.
(a -> b) -> SchemaValidator b v -> SchemaValidator a v
withLocalContext (\Field p
field -> Field p
field {$sel:fieldArgument:Field :: Maybe FieldName
fieldArgument = FieldName -> Maybe FieldName
forall a. a -> Maybe a
Just FieldName
name})

data PLACE = ON_INTERFACE | ON_TYPE

type ON_INTERFACE = 'ON_INTERFACE

type ON_TYPE = 'ON_TYPE

data InterfaceName (p :: PLACE) where
  OnInterface :: TypeName -> InterfaceName 'ON_INTERFACE
  OnType :: InterfaceName 'ON_TYPE

data TypeEntity (p :: PLACE) = TypeEntity
  { TypeEntity p -> InterfaceName p
interfaceName :: InterfaceName p,
    TypeEntity p -> TypeName
typeName :: TypeName
  }

data Field p = Field
  { Field p -> FieldName
fieldName :: FieldName,
    Field p -> Maybe FieldName
fieldArgument :: Maybe FieldName,
    Field p -> TypeEntity p
fieldOf :: TypeEntity p
  }

initialScope :: Scope
initialScope :: Scope
initialScope =
  Scope :: Maybe Position
-> TypeName
-> TypeKind
-> TypeWrapper
-> FieldName
-> ScopeKind
-> [PropName]
-> Scope
Scope
    { position :: Maybe Position
position = Maybe Position
forall a. Maybe a
Nothing,
      currentTypeName :: TypeName
currentTypeName = TypeName
"Root",
      currentTypeKind :: TypeKind
currentTypeKind = Maybe OperationType -> TypeKind
KindObject Maybe OperationType
forall a. Maybe a
Nothing,
      currentTypeWrappers :: TypeWrapper
currentTypeWrappers = TypeWrapper
mkBaseType,
      kind :: ScopeKind
kind = ScopeKind
TYPE,
      fieldName :: FieldName
fieldName = FieldName
"Root",
      path :: [PropName]
path = []
    }

newtype TypeSystemContext c = TypeSystemContext
  {TypeSystemContext c -> c
local :: c}
  deriving (Int -> TypeSystemContext c -> ShowS
[TypeSystemContext c] -> ShowS
TypeSystemContext c -> String
(Int -> TypeSystemContext c -> ShowS)
-> (TypeSystemContext c -> String)
-> ([TypeSystemContext c] -> ShowS)
-> Show (TypeSystemContext c)
forall c. Show c => Int -> TypeSystemContext c -> ShowS
forall c. Show c => [TypeSystemContext c] -> ShowS
forall c. Show c => TypeSystemContext c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeSystemContext c] -> ShowS
$cshowList :: forall c. Show c => [TypeSystemContext c] -> ShowS
show :: TypeSystemContext c -> String
$cshow :: forall c. Show c => TypeSystemContext c -> String
showsPrec :: Int -> TypeSystemContext c -> ShowS
$cshowsPrec :: forall c. Show c => Int -> TypeSystemContext c -> ShowS
Show)

pushPath :: Name t -> SchemaValidator a v -> SchemaValidator a v
pushPath :: Name t -> SchemaValidator a v -> SchemaValidator a v
pushPath Name t
name = (Scope -> Scope) -> SchemaValidator a v -> SchemaValidator a v
forall (s :: Stage) c (m :: * -> *) b.
MonadReader (ValidatorContext s c) m =>
(Scope -> Scope) -> m b -> m b
withScope (\Scope
x -> Scope
x {path :: [PropName]
path = Scope -> [PropName]
path Scope
x [PropName] -> [PropName] -> [PropName]
forall a. Semigroup a => a -> a -> a
<> [Text -> PropName
PropName (Name t -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
unpackName Name t
name)]})

withLocalContext :: (a -> b) -> SchemaValidator b v -> SchemaValidator a v
withLocalContext :: (a -> b) -> SchemaValidator b v -> SchemaValidator a v
withLocalContext = (TypeSystemContext a -> TypeSystemContext b)
-> SchemaValidator b v -> SchemaValidator a v
forall c' c (s :: Stage) a.
(c' -> c) -> Validator s c a -> Validator s c' a
withContext ((TypeSystemContext a -> TypeSystemContext b)
 -> SchemaValidator b v -> SchemaValidator a v)
-> ((a -> b) -> TypeSystemContext a -> TypeSystemContext b)
-> (a -> b)
-> SchemaValidator b v
-> SchemaValidator a v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> TypeSystemContext a -> TypeSystemContext b
forall a b. (a -> b) -> TypeSystemContext a -> TypeSystemContext b
updateLocal

updateLocal :: (a -> b) -> TypeSystemContext a -> TypeSystemContext b
updateLocal :: (a -> b) -> TypeSystemContext a -> TypeSystemContext b
updateLocal a -> b
f TypeSystemContext a
ctx = TypeSystemContext a
ctx {$sel:local:TypeSystemContext :: b
local = a -> b
f (TypeSystemContext a -> a
forall c. TypeSystemContext c -> c
local TypeSystemContext a
ctx)}

type SchemaValidator c = Validator CONST (TypeSystemContext c)

runSchemaValidator :: Validator s (TypeSystemContext ()) a -> Config -> Schema s -> GQLResult a
runSchemaValidator :: Validator s (TypeSystemContext ()) a
-> Config -> Schema s -> GQLResult a
runSchemaValidator Validator s (TypeSystemContext ()) a
value Config
config Schema s
sysSchema =
  Validator s (TypeSystemContext ()) a
-> Config
-> Schema s
-> Scope
-> TypeSystemContext ()
-> GQLResult a
forall (s :: Stage) ctx a.
Validator s ctx a
-> Config -> Schema s -> Scope -> ctx -> GQLResult a
runValidator
    Validator s (TypeSystemContext ()) a
value
    Config
config
    Schema s
sysSchema
    Scope
initialScope
    TypeSystemContext :: forall c. c -> TypeSystemContext c
TypeSystemContext
      { $sel:local:TypeSystemContext :: ()
local = ()
      }

constraintInterface ::
  TypeDefinition ANY CONST ->
  SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST)
constraintInterface :: TypeDefinition ANY CONST
-> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST)
constraintInterface
  TypeDefinition
    { TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName :: TypeName
typeName,
      typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataInterface FieldsDefinition OUT CONST
fields
    } = (TypeName, FieldsDefinition OUT CONST)
-> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeName
typeName, FieldsDefinition OUT CONST
fields)
constraintInterface TypeDefinition {TypeName
typeName :: TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName} =
  GQLError
-> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError
 -> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST))
-> GQLError
-> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST)
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 interface"