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

module Data.Morpheus.Types.Internal.Validation.SchemaValidator
  ( SchemaValidator,
    TypeSystemContext (..),
    constraintInterface,
    inField,
    inType,
    inArgument,
    inInterface,
    Field (..),
    Interface (..),
    renderField,
  )
where

import Data.Morpheus.Internal.Utils
  ( Failure (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    CONST,
    FieldName,
    FieldsDefinition,
    OUT,
    TypeContent (..),
    TypeDefinition (..),
    TypeName,
    ValidationError,
    msgValidation,
  )
import Data.Morpheus.Types.Internal.Validation.Validator
  ( Validator (..),
    renderField,
    withContext,
  )
import Relude hiding (local)

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)

inType ::
  TypeName ->
  SchemaValidator TypeName v ->
  SchemaValidator () v
inType :: TypeName -> SchemaValidator TypeName v -> SchemaValidator () v
inType TypeName
name = (() -> TypeName)
-> SchemaValidator TypeName v -> SchemaValidator () v
forall a b v.
(a -> b) -> SchemaValidator b v -> SchemaValidator a v
withLocalContext (TypeName -> () -> TypeName
forall a b. a -> b -> a
const TypeName
name)

inInterface ::
  TypeName ->
  SchemaValidator Interface v ->
  SchemaValidator TypeName v
inInterface :: TypeName
-> SchemaValidator Interface v -> SchemaValidator TypeName v
inInterface TypeName
interfaceName = (TypeName -> Interface)
-> SchemaValidator Interface v -> SchemaValidator TypeName v
forall a b v.
(a -> b) -> SchemaValidator b v -> SchemaValidator a v
withLocalContext (TypeName -> TypeName -> Interface
Interface TypeName
interfaceName)

inField ::
  FieldName ->
  SchemaValidator (t, FieldName) v ->
  SchemaValidator t v
inField :: FieldName
-> SchemaValidator (t, FieldName) v -> SchemaValidator t v
inField FieldName
fname = (t -> (t, FieldName))
-> SchemaValidator (t, FieldName) v -> SchemaValidator t v
forall a b v.
(a -> b) -> SchemaValidator b v -> SchemaValidator a v
withLocalContext (,FieldName
fname)

inArgument ::
  FieldName ->
  SchemaValidator (t, Field) v ->
  SchemaValidator (t, FieldName) v
inArgument :: FieldName
-> SchemaValidator (t, Field) v -> SchemaValidator (t, FieldName) v
inArgument FieldName
aname = ((t, FieldName) -> (t, Field))
-> SchemaValidator (t, Field) v -> SchemaValidator (t, FieldName) v
forall a b v.
(a -> b) -> SchemaValidator b v -> SchemaValidator a v
withLocalContext (\(t
t1, FieldName
f1) -> (t
t1, FieldName -> FieldName -> Field
Field FieldName
f1 FieldName
aname))

data Interface = Interface
  { Interface -> TypeName
interfaceName :: TypeName,
    Interface -> TypeName
typeName :: TypeName
  }

data Field = Field
  { Field -> FieldName
fieldName :: FieldName,
    Field -> FieldName
fieldArgument :: FieldName
  }

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)

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} =
  [ValidationError]
-> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure [ValidationError
"type " ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> TypeName -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation TypeName
typeName ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
" must be an interface" :: ValidationError]