{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Server.Deriving.Kinded.Type
( DeriveKindedType (..),
DERIVE_TYPE,
deriveInterfaceDefinition,
deriveScalarDefinition,
deriveTypeGuardUnions,
)
where
import Data.Morpheus.Server.Deriving.Internal.Schema.Type
( deriveInterfaceDefinition,
deriveScalarDefinition,
deriveTypeDefinition,
deriveTypeGuardUnions,
)
import Data.Morpheus.Server.Deriving.Utils.GRep
( GRep,
)
import Data.Morpheus.Server.Deriving.Utils.Kinded
( CatType,
catMap,
unliftKind,
)
import Data.Morpheus.Server.Deriving.Utils.Use
( UseDeriving (..),
UseGQLType (..),
)
import Data.Morpheus.Server.Types.Kind
( DerivingKind,
SCALAR,
TYPE,
WRAPPER,
)
import Data.Morpheus.Server.Types.SchemaT
( SchemaT,
)
import Data.Morpheus.Types.GQLScalar
( DecodeScalar (..),
scalarValidator,
)
import Data.Morpheus.Types.Internal.AST
( ArgumentsDefinition,
CONST,
TypeCategory,
TypeDefinition (..),
)
import GHC.Generics
import Relude
type DERIVE_TYPE gql c a = (gql a, GRep gql gql (SchemaT c (Maybe (ArgumentsDefinition CONST))) (Rep a))
class DeriveKindedType gql val (cat :: TypeCategory) (kind :: DerivingKind) a where
deriveKindedType :: UseDeriving gql val -> CatType cat (f kind a) -> SchemaT cat (TypeDefinition cat CONST)
instance (gql a) => DeriveKindedType gql val cat WRAPPER (f a) where
deriveKindedType :: forall {k} (f :: DerivingKind -> k -> k).
UseDeriving gql val
-> CatType cat (f WRAPPER (f a))
-> SchemaT cat (TypeDefinition cat CONST)
deriveKindedType UseDeriving {UseValue val
UseGQLType gql
forall (f :: * -> *) a. gql a => f a -> GDirectiveUsages gql val
dirGQL :: forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val -> UseGQLType gql
dirArgs :: forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val -> UseValue val
__directives :: forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val
-> forall (f :: * -> *) a. gql a => f a -> GDirectiveUsages gql val
dirGQL :: UseGQLType gql
dirArgs :: UseValue val
__directives :: forall (f :: * -> *) a. gql a => f a -> GDirectiveUsages gql val
..} = forall (gql :: * -> Constraint).
UseGQLType gql
-> forall (c :: TypeCategory) a.
gql a =>
CatType c a -> SchemaT c (TypeDefinition c CONST)
useDeriveType UseGQLType gql
dirGQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} (f :: k1 -> *) (a :: k1) (cat :: TypeCategory)
(b :: k2).
f a -> CatType cat b -> CatType cat a
catMap (forall {k} (t :: k). Proxy t
Proxy @a)
instance (DecodeScalar a, gql a) => DeriveKindedType gql val cat SCALAR a where
deriveKindedType :: forall {k} (f :: DerivingKind -> * -> k).
UseDeriving gql val
-> CatType cat (f SCALAR a)
-> SchemaT cat (TypeDefinition cat CONST)
deriveKindedType UseDeriving gql val
drv = forall (gql :: * -> Constraint) a (cat :: TypeCategory)
(args :: * -> Constraint) (kind :: TypeCategory).
gql a =>
(CatType cat a -> ScalarDefinition)
-> UseDeriving gql args
-> CatType cat a
-> SchemaT kind (TypeDefinition cat CONST)
deriveScalarDefinition forall (f :: * -> *) a. DecodeScalar a => f a -> ScalarDefinition
scalarValidator UseDeriving gql val
drv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} {k3} (cat :: TypeCategory) (f :: k1 -> k2 -> k3)
(k4 :: k1) (a :: k2).
CatType cat (f k4 a) -> CatType cat a
unliftKind
instance DERIVE_TYPE gql cat a => DeriveKindedType gql val cat TYPE a where
deriveKindedType :: forall {k} (f :: DerivingKind -> * -> k).
UseDeriving gql val
-> CatType cat (f TYPE a) -> SchemaT cat (TypeDefinition cat CONST)
deriveKindedType UseDeriving gql val
drv = forall (gql :: * -> Constraint) a (c :: TypeCategory)
(args :: * -> Constraint).
(gql a,
GRep
gql gql (SchemaT c (Maybe (ArgumentsDefinition CONST))) (Rep a)) =>
UseDeriving gql args
-> CatType c a -> SchemaT c (TypeDefinition c CONST)
deriveTypeDefinition UseDeriving gql val
drv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} {k3} (cat :: TypeCategory) (f :: k1 -> k2 -> k3)
(k4 :: k1) (a :: k2).
CatType cat (f k4 a) -> CatType cat a
unliftKind