{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Deriving.Schema
  ( compileTimeSchemaValidation,
    DeriveType,
    deriveSchema,
    SchemaConstraints,
    SchemaT,
  )
where

import Data.Morpheus.App.Internal.Resolving
  ( Resolver,
  )
import Data.Morpheus.Core (defaultConfig, validateSchema)
import Data.Morpheus.Internal.Ext
import Data.Morpheus.Server.Deriving.Schema.DeriveKinded
  ( DERIVE_TYPE,
    toFieldContent,
  )
import Data.Morpheus.Server.Deriving.Schema.Internal
  ( fromSchema,
  )
import Data.Morpheus.Server.Deriving.Schema.Object
  ( asObjectType,
  )
import Data.Morpheus.Server.Deriving.Schema.TypeContent
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( CatContext (OutputContext),
    outputType,
  )
import Data.Morpheus.Server.Types.GQLType
  ( DeriveType,
    GQLType (..),
    withDeriveType,
    withDir,
    withGQL,
    __isEmptyType,
  )
import Data.Morpheus.Server.Types.SchemaT
  ( SchemaT,
    toSchema,
  )
import Data.Morpheus.Types.Internal.AST
  ( CONST,
    MUTATION,
    OBJECT,
    OUT,
    QUERY,
    SUBSCRIPTION,
    Schema (..),
    TypeDefinition (..),
  )
import Language.Haskell.TH (Exp, Q)
import Relude

type SchemaConstraints event (m :: Type -> Type) query mutation subscription =
  ( DERIVE_TYPE GQLType DeriveType OUT (query (Resolver QUERY event m)),
    DERIVE_TYPE GQLType DeriveType OUT (mutation (Resolver MUTATION event m)),
    DERIVE_TYPE GQLType DeriveType OUT (subscription (Resolver SUBSCRIPTION event m))
  )

-- | normal morpheus server validates schema at runtime (after the schema derivation).
--   this method allows you to validate it at compile time.
compileTimeSchemaValidation ::
  (SchemaConstraints event m qu mu su) =>
  proxy (root m event qu mu su) ->
  Q Exp
compileTimeSchemaValidation :: forall {k} event (m :: * -> *) (qu :: (* -> *) -> *)
       (mu :: (* -> *) -> *) (su :: (* -> *) -> *) (proxy :: k -> *)
       (root :: (* -> *)
                -> *
                -> ((* -> *) -> *)
                -> ((* -> *) -> *)
                -> ((* -> *) -> *)
                -> k).
SchemaConstraints event m qu mu su =>
proxy (root m event qu mu su) -> Q Exp
compileTimeSchemaValidation =
  GQLResult (Schema VALID) -> Q Exp
fromSchema forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall {k}
       (root :: (* -> *)
                -> * -> ((* -> *) -> *) -> ((* -> *) -> *) -> ((* -> *) -> *) -> k)
       (proxy :: k -> *) (m :: * -> *) e (query :: (* -> *) -> *)
       (mut :: (* -> *) -> *) (subs :: (* -> *) -> *).
SchemaConstraints e m query mut subs =>
proxy (root m e query mut subs) -> GQLResult (Schema CONST)
deriveSchema forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (s :: Stage).
ValidateSchema s =>
Bool -> Config -> Schema s -> GQLResult (Schema VALID)
validateSchema Bool
True Config
defaultConfig)

deriveSchema ::
  forall
    root
    proxy
    m
    e
    query
    mut
    subs.
  ( SchemaConstraints e m query mut subs
  ) =>
  proxy (root m e query mut subs) ->
  GQLResult (Schema CONST)
deriveSchema :: forall {k}
       (root :: (* -> *)
                -> * -> ((* -> *) -> *) -> ((* -> *) -> *) -> ((* -> *) -> *) -> k)
       (proxy :: k -> *) (m :: * -> *) e (query :: (* -> *) -> *)
       (mut :: (* -> *) -> *) (subs :: (* -> *) -> *).
SchemaConstraints e m query mut subs =>
proxy (root m e query mut subs) -> GQLResult (Schema CONST)
deriveSchema proxy (root m e query mut subs)
_ = forall (c :: TypeCategory).
SchemaT
  c
  (TypeDefinition OBJECT CONST, Maybe (TypeDefinition OBJECT CONST),
   Maybe (TypeDefinition OBJECT CONST))
-> GQLResult (Schema CONST)
toSchema SchemaT
  OUT
  (TypeDefinition OBJECT CONST, Maybe (TypeDefinition OBJECT CONST),
   Maybe (TypeDefinition OBJECT CONST))
schemaT
  where
    schemaT ::
      SchemaT
        OUT
        ( TypeDefinition OBJECT CONST,
          Maybe (TypeDefinition OBJECT CONST),
          Maybe (TypeDefinition OBJECT CONST)
        )
    schemaT :: SchemaT
  OUT
  (TypeDefinition OBJECT CONST, Maybe (TypeDefinition OBJECT CONST),
   Maybe (TypeDefinition OBJECT CONST))
schemaT =
      (,,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (f :: * -> *).
DERIVE_TYPE GQLType DeriveType OUT a =>
f a -> SchemaT OUT (TypeDefinition OBJECT CONST)
deriveRoot (forall {k} (t :: k). Proxy t
Proxy @(query (Resolver QUERY e m)))
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (f :: * -> *).
DERIVE_TYPE GQLType DeriveType OUT a =>
f a -> SchemaT OUT (Maybe (TypeDefinition OBJECT CONST))
deriveMaybeRoot (forall {k} (t :: k). Proxy t
Proxy @(mut (Resolver MUTATION e m)))
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (f :: * -> *).
DERIVE_TYPE GQLType DeriveType OUT a =>
f a -> SchemaT OUT (Maybe (TypeDefinition OBJECT CONST))
deriveMaybeRoot (forall {k} (t :: k). Proxy t
Proxy @(subs (Resolver SUBSCRIPTION e m)))

--

deriveMaybeRoot :: DERIVE_TYPE GQLType DeriveType OUT a => f a -> SchemaT OUT (Maybe (TypeDefinition OBJECT CONST))
deriveMaybeRoot :: forall a (f :: * -> *).
DERIVE_TYPE GQLType DeriveType OUT a =>
f a -> SchemaT OUT (Maybe (TypeDefinition OBJECT CONST))
deriveMaybeRoot f a
proxy
  | forall (f :: * -> *) a. GQLType a => f a -> Bool
__isEmptyType f a
proxy = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  | Bool
otherwise = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (gql :: * -> Constraint) a (f :: * -> *)
       (kind :: TypeCategory).
gql a =>
UseGQLType gql
-> (f a -> SchemaT kind (FieldsDefinition OUT CONST))
-> f a
-> SchemaT kind (TypeDefinition OBJECT CONST)
asObjectType UseGQLType GQLType
withGQL (forall (gql :: * -> Constraint) a (derive :: * -> Constraint)
       (cat :: TypeCategory) (args :: * -> Constraint).
(gql a,
 DeriveWith gql derive (SchemaT cat (TyContent cat)) (Rep a)) =>
UseDirective gql args
-> DeriveTypeOptions cat gql derive (SchemaT cat (TyContent cat))
-> CatType cat a
-> SchemaT cat (FieldsDefinition cat CONST)
deriveFieldsWith UseDirective GQLType DeriveDirective
withDir (forall (kind :: TypeCategory) (gql :: * -> Constraint)
       (dir :: * -> Constraint)
       (derive :: TypeCategory -> * -> Constraint).
CatContext kind
-> UseDirective gql dir
-> UseDeriveType derive
-> DeriveTypeOptions kind gql (derive kind) (TyContentM kind)
toFieldContent CatContext OUT
OutputContext UseDirective GQLType DeriveDirective
withDir UseDeriveType DeriveType
withDeriveType) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (a :: k). f a -> CatType OUT a
outputType) f a
proxy

deriveRoot :: DERIVE_TYPE GQLType DeriveType OUT a => f a -> SchemaT OUT (TypeDefinition OBJECT CONST)
deriveRoot :: forall a (f :: * -> *).
DERIVE_TYPE GQLType DeriveType OUT a =>
f a -> SchemaT OUT (TypeDefinition OBJECT CONST)
deriveRoot = forall (gql :: * -> Constraint) a (f :: * -> *)
       (kind :: TypeCategory).
gql a =>
UseGQLType gql
-> (f a -> SchemaT kind (FieldsDefinition OUT CONST))
-> f a
-> SchemaT kind (TypeDefinition OBJECT CONST)
asObjectType UseGQLType GQLType
withGQL (forall (gql :: * -> Constraint) a (derive :: * -> Constraint)
       (cat :: TypeCategory) (args :: * -> Constraint).
(gql a,
 DeriveWith gql derive (SchemaT cat (TyContent cat)) (Rep a)) =>
UseDirective gql args
-> DeriveTypeOptions cat gql derive (SchemaT cat (TyContent cat))
-> CatType cat a
-> SchemaT cat (FieldsDefinition cat CONST)
deriveFieldsWith UseDirective GQLType DeriveDirective
withDir (forall (kind :: TypeCategory) (gql :: * -> Constraint)
       (dir :: * -> Constraint)
       (derive :: TypeCategory -> * -> Constraint).
CatContext kind
-> UseDirective gql dir
-> UseDeriveType derive
-> DeriveTypeOptions kind gql (derive kind) (TyContentM kind)
toFieldContent CatContext OUT
OutputContext UseDirective GQLType DeriveDirective
withDir UseDeriveType DeriveType
withDeriveType) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (a :: k). f a -> CatType OUT a
outputType)