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

module Data.Morpheus.Server.Deriving.Kinded.Type
  ( DeriveKindedType (..),
    DERIVE_TYPE,
    deriveScalarDefinition,
    deriveTypeGuardUnions,
    scanNode,
  )
where

import Data.Morpheus.Generic
  ( Gmap,
  )
import Data.Morpheus.Internal.Ext (GQLResult)
import Data.Morpheus.Server.Deriving.Internal.Directive (deriveDirectiveDefinition)
import Data.Morpheus.Server.Deriving.Internal.Type
  ( DERIVE_TYPE,
    deriveScalarDefinition,
    deriveTypeDefinition,
    deriveTypeGuardUnions,
  )
import Data.Morpheus.Server.Deriving.Utils.GScan
  ( FreeCatType,
    ScanRef,
    freeLeaf,
    freeNode,
  )
import Data.Morpheus.Server.Deriving.Utils.Kinded
  ( CatType (..),
    inputType,
    mapCat,
    unliftKind,
  )
import Data.Morpheus.Server.Deriving.Utils.Types (GQLTypeNode (..))
import Data.Morpheus.Server.Deriving.Utils.Use
  ( UseDeriving (..),
    UseGQLType (..),
  )
import Data.Morpheus.Server.Types.Directives (GQLDirective (..))
import Data.Morpheus.Server.Types.Kind
  ( DIRECTIVE,
    DerivingKind,
    SCALAR,
    TYPE,
    WRAPPER,
  )
import Data.Morpheus.Types.GQLScalar
  ( DecodeScalar (..),
    scalarValidator,
  )
import GHC.Generics (Generic (Rep))
import Relude

-- | DeriveType With specific Kind: 'kind': object, scalar, enum ...
class DeriveKindedType ctx (k :: DerivingKind) a where
  deriveKindedType :: (ctx ~ UseDeriving gql v) => ctx -> CatType cat (f k a) -> GQLResult (GQLTypeNode cat)
  exploreKindedRefs :: (ctx ~ UseDeriving gql v) => ctx -> CatType cat (f k a) -> [ScanRef FreeCatType gql]

instance (gql a, ctx ~ UseDeriving gql v) => DeriveKindedType ctx WRAPPER (f a) where
  deriveKindedType :: forall {k} (gql :: * -> Constraint) (v :: * -> Constraint)
       (cat :: TypeCategory) (f :: DerivingKind -> k -> k).
(ctx ~ UseDeriving gql v) =>
ctx -> CatType cat (f WRAPPER (f a)) -> GQLResult (GQLTypeNode cat)
deriveKindedType ctx
ctx = ctx -> CatType cat a -> GQLResult (GQLTypeNode cat)
forall a (c :: TypeCategory).
gql a =>
ctx -> CatType c a -> GQLResult (GQLTypeNode c)
forall ctx (con :: * -> Constraint) a (c :: TypeCategory).
(UseGQLType ctx con, con a) =>
ctx -> CatType c a -> GQLResult (GQLTypeNode c)
useDeriveNode ctx
ctx (CatType cat a -> GQLResult (GQLTypeNode cat))
-> (CatType cat (f WRAPPER (f a)) -> CatType cat a)
-> CatType cat (f WRAPPER (f a))
-> GQLResult (GQLTypeNode cat)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> CatType cat (f WRAPPER (f a)) -> CatType cat a
forall {k1} {k2} (f :: k1 -> *) (a :: k1) (cat :: TypeCategory)
       (b :: k2).
f a -> CatType cat b -> CatType cat a
mapCat (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
  exploreKindedRefs :: forall {k} (gql :: * -> Constraint) (v :: * -> Constraint)
       (cat :: TypeCategory) (f :: DerivingKind -> k -> k).
(ctx ~ UseDeriving gql v) =>
ctx -> CatType cat (f WRAPPER (f a)) -> [ScanRef FreeCatType gql]
exploreKindedRefs ctx
ctx = ctx -> CatType cat a -> [ScanRef FreeCatType gql]
forall a (c :: TypeCategory).
gql a =>
ctx -> CatType c a -> [ScanRef FreeCatType gql]
forall ctx (con :: * -> Constraint) a (c :: TypeCategory).
(UseGQLType ctx con, con a) =>
ctx -> CatType c a -> [ScanRef FreeCatType con]
useExploreRef ctx
ctx (CatType cat a -> [ScanRef FreeCatType gql])
-> (CatType cat (f WRAPPER (f a)) -> CatType cat a)
-> CatType cat (f WRAPPER (f a))
-> [ScanRef FreeCatType gql]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> CatType cat (f WRAPPER (f a)) -> CatType cat a
forall {k1} {k2} (f :: k1 -> *) (a :: k1) (cat :: TypeCategory)
       (b :: k2).
f a -> CatType cat b -> CatType cat a
mapCat (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)

scanLeaf :: (c a, UseGQLType ctx gql, gql a) => ctx -> CatType k a -> [ScanRef FreeCatType c]
scanLeaf :: forall (c :: * -> Constraint) a ctx (gql :: * -> Constraint)
       (k :: TypeCategory).
(c a, UseGQLType ctx gql, gql a) =>
ctx -> CatType k a -> [ScanRef FreeCatType c]
scanLeaf ctx
gql CatType k a
p = [TypeFingerprint -> CatType k a -> ScanRef FreeCatType c
forall (c1 :: * -> Constraint) a (c2 :: TypeCategory).
c1 a =>
TypeFingerprint -> CatType c2 a -> ScanRef FreeCatType c1
freeLeaf (ctx -> CatType k a -> TypeFingerprint
forall a (c :: TypeCategory).
gql a =>
ctx -> CatType c a -> TypeFingerprint
forall ctx (con :: * -> Constraint) a (c :: TypeCategory).
(UseGQLType ctx con, con a) =>
ctx -> CatType c a -> TypeFingerprint
useFingerprint ctx
gql CatType k a
p) CatType k a
p]

scanNode :: (c a, gql a, UseGQLType ctx gql, Gmap c (Rep a)) => Bool -> ctx -> CatType k a -> [ScanRef FreeCatType c]
scanNode :: forall (c :: * -> Constraint) a (gql :: * -> Constraint) ctx
       (k :: TypeCategory).
(c a, gql a, UseGQLType ctx gql, Gmap c (Rep a)) =>
Bool -> ctx -> CatType k a -> [ScanRef FreeCatType c]
scanNode Bool
visible ctx
gql CatType k a
p = [Bool -> TypeFingerprint -> CatType k a -> ScanRef FreeCatType c
forall (c :: * -> Constraint) a (c2 :: TypeCategory).
(c a, Gmap c (Rep a)) =>
Bool -> TypeFingerprint -> CatType c2 a -> ScanRef FreeCatType c
freeNode Bool
visible (ctx -> CatType k a -> TypeFingerprint
forall a (c :: TypeCategory).
gql a =>
ctx -> CatType c a -> TypeFingerprint
forall ctx (con :: * -> Constraint) a (c :: TypeCategory).
(UseGQLType ctx con, con a) =>
ctx -> CatType c a -> TypeFingerprint
useFingerprint ctx
gql CatType k a
p) CatType k a
p]

instance (DecodeScalar a, gql a, ctx ~ UseDeriving gql v) => DeriveKindedType ctx SCALAR a where
  deriveKindedType :: forall {k} (gql :: * -> Constraint) (v :: * -> Constraint)
       (cat :: TypeCategory) (f :: DerivingKind -> * -> k).
(ctx ~ UseDeriving gql v) =>
ctx -> CatType cat (f SCALAR a) -> GQLResult (GQLTypeNode cat)
deriveKindedType ctx
ctx = (CatType cat a -> ScalarDefinition)
-> UseDeriving gql v
-> CatType cat a
-> GQLResult (GQLTypeNode cat)
forall (gql :: * -> Constraint) a (cat :: TypeCategory)
       (args :: * -> Constraint).
gql a =>
(CatType cat a -> ScalarDefinition)
-> UseDeriving gql args
-> CatType cat a
-> GQLResult (GQLTypeNode cat)
deriveScalarDefinition CatType cat a -> ScalarDefinition
forall (f :: * -> *) a. DecodeScalar a => f a -> ScalarDefinition
scalarValidator ctx
UseDeriving gql v
ctx (CatType cat a -> GQLResult (GQLTypeNode cat))
-> (CatType cat (f SCALAR a) -> CatType cat a)
-> CatType cat (f SCALAR a)
-> GQLResult (GQLTypeNode cat)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CatType cat (f SCALAR a) -> CatType cat a
forall {k1} {k2} {k3} (cat :: TypeCategory) (f :: k1 -> k2 -> k3)
       (k4 :: k1) (a :: k2).
CatType cat (f k4 a) -> CatType cat a
unliftKind
  exploreKindedRefs :: forall {k} (gql :: * -> Constraint) (v :: * -> Constraint)
       (cat :: TypeCategory) (f :: DerivingKind -> * -> k).
(ctx ~ UseDeriving gql v) =>
ctx -> CatType cat (f SCALAR a) -> [ScanRef FreeCatType gql]
exploreKindedRefs ctx
ctx CatType cat (f SCALAR a)
proxy = ctx -> CatType cat a -> [ScanRef FreeCatType gql]
forall (c :: * -> Constraint) a ctx (gql :: * -> Constraint)
       (k :: TypeCategory).
(c a, UseGQLType ctx gql, gql a) =>
ctx -> CatType k a -> [ScanRef FreeCatType c]
scanLeaf ctx
ctx (Proxy a -> CatType cat (f SCALAR a) -> CatType cat a
forall {k1} {k2} (f :: k1 -> *) (a :: k1) (cat :: TypeCategory)
       (b :: k2).
f a -> CatType cat b -> CatType cat a
mapCat (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a) CatType cat (f SCALAR a)
proxy)

instance (DERIVE_TYPE gql a, Gmap gql (Rep a), ctx ~ UseDeriving gql v) => DeriveKindedType ctx TYPE a where
  deriveKindedType :: forall {k} (gql :: * -> Constraint) (v :: * -> Constraint)
       (cat :: TypeCategory) (f :: DerivingKind -> * -> k).
(ctx ~ UseDeriving gql v) =>
ctx -> CatType cat (f TYPE a) -> GQLResult (GQLTypeNode cat)
deriveKindedType ctx
ctx = ((TypeDefinition cat CONST, [GQLTypeNodeExtension])
 -> GQLTypeNode cat)
-> Result
     GQLError (TypeDefinition cat CONST, [GQLTypeNodeExtension])
-> Result GQLError (GQLTypeNode cat)
forall a b. (a -> b) -> Result GQLError a -> Result GQLError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TypeDefinition cat CONST
 -> [GQLTypeNodeExtension] -> GQLTypeNode cat)
-> (TypeDefinition cat CONST, [GQLTypeNodeExtension])
-> GQLTypeNode cat
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TypeDefinition cat CONST
-> [GQLTypeNodeExtension] -> GQLTypeNode cat
forall (c :: TypeCategory).
TypeDefinition c CONST -> [GQLTypeNodeExtension] -> GQLTypeNode c
GQLTypeNode) (Result GQLError (TypeDefinition cat CONST, [GQLTypeNodeExtension])
 -> Result GQLError (GQLTypeNode cat))
-> (CatType cat (f TYPE a)
    -> Result
         GQLError (TypeDefinition cat CONST, [GQLTypeNodeExtension]))
-> CatType cat (f TYPE a)
-> Result GQLError (GQLTypeNode cat)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UseDeriving gql v
-> CatType cat a
-> Result
     GQLError (TypeDefinition cat CONST, [GQLTypeNodeExtension])
forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (c :: TypeCategory).
DERIVE_TYPE gql a =>
UseDeriving gql args
-> CatType c a
-> GQLResult (TypeDefinition c CONST, [GQLTypeNodeExtension])
deriveTypeDefinition ctx
UseDeriving gql v
ctx (CatType cat a
 -> Result
      GQLError (TypeDefinition cat CONST, [GQLTypeNodeExtension]))
-> (CatType cat (f TYPE a) -> CatType cat a)
-> CatType cat (f TYPE a)
-> Result
     GQLError (TypeDefinition cat CONST, [GQLTypeNodeExtension])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CatType cat (f TYPE a) -> CatType cat a
forall {k1} {k2} {k3} (cat :: TypeCategory) (f :: k1 -> k2 -> k3)
       (k4 :: k1) (a :: k2).
CatType cat (f k4 a) -> CatType cat a
unliftKind
  exploreKindedRefs :: forall {k} (gql :: * -> Constraint) (v :: * -> Constraint)
       (cat :: TypeCategory) (f :: DerivingKind -> * -> k).
(ctx ~ UseDeriving gql v) =>
ctx -> CatType cat (f TYPE a) -> [ScanRef FreeCatType gql]
exploreKindedRefs ctx
ctx CatType cat (f TYPE a)
proxy = Bool -> ctx -> CatType cat a -> [ScanRef FreeCatType gql]
forall (c :: * -> Constraint) a (gql :: * -> Constraint) ctx
       (k :: TypeCategory).
(c a, gql a, UseGQLType ctx gql, Gmap c (Rep a)) =>
Bool -> ctx -> CatType k a -> [ScanRef FreeCatType c]
scanNode Bool
True ctx
ctx (Proxy a -> CatType cat (f TYPE a) -> CatType cat a
forall {k1} {k2} (f :: k1 -> *) (a :: k1) (cat :: TypeCategory)
       (b :: k2).
f a -> CatType cat b -> CatType cat a
mapCat (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a) CatType cat (f TYPE a)
proxy)

instance (DERIVE_TYPE gql a, Gmap gql (Rep a), ctx ~ UseDeriving gql v, GQLDirective a, v a) => DeriveKindedType ctx DIRECTIVE a where
  deriveKindedType :: forall {k} (gql :: * -> Constraint) (v :: * -> Constraint)
       (cat :: TypeCategory) (f :: DerivingKind -> * -> k).
(ctx ~ UseDeriving gql v) =>
ctx -> CatType cat (f DIRECTIVE a) -> GQLResult (GQLTypeNode cat)
deriveKindedType ctx
drv CatType cat (f DIRECTIVE a)
_ = DirectiveDefinition CONST -> GQLTypeNode cat
forall (c :: TypeCategory).
DirectiveDefinition CONST -> GQLTypeNode c
GQLDirectiveNode (DirectiveDefinition CONST -> GQLTypeNode cat)
-> Result GQLError (DirectiveDefinition CONST)
-> Result GQLError (GQLTypeNode cat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UseDeriving gql v
-> CatType IN a
-> GQLResult (TypeDefinition IN CONST, [GQLTypeNodeExtension])
forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (c :: TypeCategory).
DERIVE_TYPE gql a =>
UseDeriving gql args
-> CatType c a
-> GQLResult (TypeDefinition c CONST, [GQLTypeNodeExtension])
deriveTypeDefinition ctx
UseDeriving gql v
drv CatType IN a
proxy GQLResult (TypeDefinition IN CONST, [GQLTypeNodeExtension])
-> ((TypeDefinition IN CONST, [GQLTypeNodeExtension])
    -> Result GQLError (DirectiveDefinition CONST))
-> Result GQLError (DirectiveDefinition CONST)
forall a b.
Result GQLError a -> (a -> Result GQLError b) -> Result GQLError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UseDeriving gql v
-> CatType IN a
-> TypeDefinition IN CONST
-> Result GQLError (DirectiveDefinition CONST)
forall (m :: * -> *) (gql :: * -> Constraint) a
       (val :: * -> Constraint) (f :: * -> *).
(MonadError GQLError m, gql a, GQLDirective a, val a) =>
UseDeriving gql val
-> f a -> TypeDefinition IN CONST -> m (DirectiveDefinition CONST)
deriveDirectiveDefinition ctx
UseDeriving gql v
drv CatType IN a
proxy (TypeDefinition IN CONST
 -> Result GQLError (DirectiveDefinition CONST))
-> ((TypeDefinition IN CONST, [GQLTypeNodeExtension])
    -> TypeDefinition IN CONST)
-> (TypeDefinition IN CONST, [GQLTypeNodeExtension])
-> Result GQLError (DirectiveDefinition CONST)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeDefinition IN CONST, [GQLTypeNodeExtension])
-> TypeDefinition IN CONST
forall a b. (a, b) -> a
fst)
    where
      proxy :: CatType IN a
proxy = Proxy a -> CatType IN a
forall {k} (f :: k -> *) (a :: k). f a -> CatType IN a
inputType (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
  exploreKindedRefs :: forall {k} (gql :: * -> Constraint) (v :: * -> Constraint)
       (cat :: TypeCategory) (f :: DerivingKind -> * -> k).
(ctx ~ UseDeriving gql v) =>
ctx -> CatType cat (f DIRECTIVE a) -> [ScanRef FreeCatType gql]
exploreKindedRefs ctx
ctx CatType cat (f DIRECTIVE a)
proxy
    | Proxy a -> Bool
forall a (f :: * -> *). GQLDirective a => f a -> Bool
forall (f :: * -> *). f a -> Bool
excludeFromSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a) = []
    | Bool
otherwise = Bool -> ctx -> CatType cat a -> [ScanRef FreeCatType gql]
forall (c :: * -> Constraint) a (gql :: * -> Constraint) ctx
       (k :: TypeCategory).
(c a, gql a, UseGQLType ctx gql, Gmap c (Rep a)) =>
Bool -> ctx -> CatType k a -> [ScanRef FreeCatType c]
scanNode Bool
True ctx
ctx (Proxy a -> CatType cat (f DIRECTIVE a) -> CatType cat a
forall {k1} {k2} (f :: k1 -> *) (a :: k1) (cat :: TypeCategory)
       (b :: k2).
f a -> CatType cat b -> CatType cat a
mapCat (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a) CatType cat (f DIRECTIVE a)
proxy)