{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Server.Deriving.Utils.DeriveGType
( DeriveWith (..),
DeriveValueOptions (..),
DeriveTypeOptions (..),
deriveValue,
deriveTypeWith,
)
where
import Data.Morpheus.Server.Deriving.Utils.Kinded
( CategoryValue (..),
)
import Data.Morpheus.Server.Deriving.Utils.Proxy
( conNameProxy,
isRecordProxy,
selNameProxy,
)
import Data.Morpheus.Server.Deriving.Utils.Types
import Data.Morpheus.Server.Types.Internal
( GQLTypeOptions (..),
TypeData (..),
)
import Data.Morpheus.Types.Internal.AST
( TypeName,
TypeRef (..),
)
import GHC.Generics
( C,
Constructor,
D,
Datatype,
Generic (..),
K1 (..),
M1 (..),
Meta,
Rec0,
S,
Selector,
U1 (..),
(:*:) (..),
(:+:) (..),
)
import Relude hiding (undefined)
data DeriveValueOptions kind c v = DeriveValueOptions
{ forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v -> TypeName
__valueTypeName :: TypeName,
forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v -> GQLTypeOptions
__valueGQLOptions :: GQLTypeOptions,
forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v -> forall a. c a => a -> v
__valueApply :: forall a. c a => a -> v,
forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v
-> forall (f :: * -> *) a. c a => f a -> TypeData
__valueGetType :: forall f a. c a => f a -> TypeData
}
data DeriveTypeOptions kind c v = DeriveTypeDefinitionOptions
{ forall {k} {k} (kind :: k) (c :: k -> Constraint) v.
DeriveTypeOptions kind c v -> GQLTypeOptions
__typeGQLOptions :: GQLTypeOptions,
forall {k} {k} (kind :: k) (c :: k -> Constraint) v.
DeriveTypeOptions kind c v
-> forall (f :: k -> *) (a :: k). c a => f a -> v
__typeApply :: forall f a. c a => f a -> v,
forall {k} {k} (kind :: k) (c :: k -> Constraint) v.
DeriveTypeOptions kind c v
-> forall (f :: k -> *) (a :: k). c a => f a -> TypeData
__typeGetType :: forall f a. c a => f a -> TypeData
}
deriveValue ::
(CategoryValue kind, Generic a, DeriveWith constraint value (Rep a)) =>
DeriveValueOptions kind constraint value ->
a ->
DataType value
deriveValue :: forall (kind :: TypeCategory) a (constraint :: * -> Constraint)
value.
(CategoryValue kind, Generic a,
DeriveWith constraint value (Rep a)) =>
DeriveValueOptions kind constraint value -> a -> DataType value
deriveValue DeriveValueOptions kind constraint value
options = forall {k} (c :: * -> Constraint) v (f :: k -> *)
(kind :: TypeCategory) (a :: k).
(DeriveWith c v f, CategoryValue kind) =>
DeriveValueOptions kind c v -> f a -> DataType v
deriveTypeValue DeriveValueOptions kind constraint value
options forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from
deriveTypeWith ::
forall kind c v kinded a.
(CategoryValue kind, DeriveWith c v (Rep a)) =>
DeriveTypeOptions kind c v ->
kinded kind a ->
[ConsRep v]
deriveTypeWith :: forall (kind :: TypeCategory) (c :: * -> Constraint) v
(kinded :: TypeCategory -> * -> *) a.
(CategoryValue kind, DeriveWith c v (Rep a)) =>
DeriveTypeOptions kind c v -> kinded kind a -> [ConsRep v]
deriveTypeWith DeriveTypeOptions kind c v
options kinded kind a
_ = forall {k} (c :: * -> Constraint) v (f :: k -> *)
(kind :: TypeCategory) (proxy :: (k -> *) -> *).
(DeriveWith c v f, CategoryValue kind) =>
DeriveTypeOptions kind c v -> proxy f -> [ConsRep v]
deriveTypeDefinition DeriveTypeOptions kind c v
options (forall {k} (t :: k). Proxy t
Proxy @(Rep a))
class DeriveWith (c :: Type -> Constraint) (v :: Type) f where
deriveTypeValue :: CategoryValue kind => DeriveValueOptions kind c v -> f a -> DataType v
deriveTypeDefinition :: CategoryValue kind => DeriveTypeOptions kind c v -> proxy f -> [ConsRep v]
instance (Datatype d, DeriveWith c v f) => DeriveWith c v (M1 D d f) where
deriveTypeValue :: forall (kind :: TypeCategory) (a :: k).
CategoryValue kind =>
DeriveValueOptions kind c v -> M1 D d f a -> DataType v
deriveTypeValue DeriveValueOptions kind c v
options (M1 f a
src) = (forall {k} (c :: * -> Constraint) v (f :: k -> *)
(kind :: TypeCategory) (a :: k).
(DeriveWith c v f, CategoryValue kind) =>
DeriveValueOptions kind c v -> f a -> DataType v
deriveTypeValue DeriveValueOptions kind c v
options f a
src) {dataTypeName :: TypeName
dataTypeName = forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v -> TypeName
__valueTypeName DeriveValueOptions kind c v
options}
deriveTypeDefinition :: forall (kind :: TypeCategory) (proxy :: (k -> *) -> *).
CategoryValue kind =>
DeriveTypeOptions kind c v -> proxy (M1 D d f) -> [ConsRep v]
deriveTypeDefinition DeriveTypeOptions kind c v
options proxy (M1 D d f)
_ = forall {k} (c :: * -> Constraint) v (f :: k -> *)
(kind :: TypeCategory) (proxy :: (k -> *) -> *).
(DeriveWith c v f, CategoryValue kind) =>
DeriveTypeOptions kind c v -> proxy f -> [ConsRep v]
deriveTypeDefinition DeriveTypeOptions kind c v
options (forall {k} (t :: k). Proxy t
Proxy @f)
instance (DeriveWith c v a, DeriveWith c v b) => DeriveWith c v (a :+: b) where
deriveTypeValue :: forall (kind :: TypeCategory) (a :: k).
CategoryValue kind =>
DeriveValueOptions kind c v -> (:+:) a b a -> DataType v
deriveTypeValue DeriveValueOptions kind c v
f (L1 a a
x) = (forall {k} (c :: * -> Constraint) v (f :: k -> *)
(kind :: TypeCategory) (a :: k).
(DeriveWith c v f, CategoryValue kind) =>
DeriveValueOptions kind c v -> f a -> DataType v
deriveTypeValue DeriveValueOptions kind c v
f a a
x) {tyIsUnion :: Bool
tyIsUnion = Bool
True}
deriveTypeValue DeriveValueOptions kind c v
f (R1 b a
x) = (forall {k} (c :: * -> Constraint) v (f :: k -> *)
(kind :: TypeCategory) (a :: k).
(DeriveWith c v f, CategoryValue kind) =>
DeriveValueOptions kind c v -> f a -> DataType v
deriveTypeValue DeriveValueOptions kind c v
f b a
x) {tyIsUnion :: Bool
tyIsUnion = Bool
True}
deriveTypeDefinition :: forall (kind :: TypeCategory) (proxy :: (k -> *) -> *).
CategoryValue kind =>
DeriveTypeOptions kind c v -> proxy (a :+: b) -> [ConsRep v]
deriveTypeDefinition DeriveTypeOptions kind c v
options proxy (a :+: b)
_ = forall {k} (c :: * -> Constraint) v (f :: k -> *)
(kind :: TypeCategory) (proxy :: (k -> *) -> *).
(DeriveWith c v f, CategoryValue kind) =>
DeriveTypeOptions kind c v -> proxy f -> [ConsRep v]
deriveTypeDefinition DeriveTypeOptions kind c v
options (forall {k} (t :: k). Proxy t
Proxy @a) forall a. Semigroup a => a -> a -> a
<> forall {k} (c :: * -> Constraint) v (f :: k -> *)
(kind :: TypeCategory) (proxy :: (k -> *) -> *).
(DeriveWith c v f, CategoryValue kind) =>
DeriveTypeOptions kind c v -> proxy f -> [ConsRep v]
deriveTypeDefinition DeriveTypeOptions kind c v
options (forall {k} (t :: k). Proxy t
Proxy @b)
instance (DeriveFieldRep con v f, Constructor c) => DeriveWith con v (M1 C c f) where
deriveTypeValue :: forall (kind :: TypeCategory) (a :: k).
CategoryValue kind =>
DeriveValueOptions kind con v -> M1 C c f a -> DataType v
deriveTypeValue DeriveValueOptions kind con v
options (M1 f a
src) =
DataType
{ dataTypeName :: TypeName
dataTypeName = TypeName
"",
tyIsUnion :: Bool
tyIsUnion = Bool
False,
tyCons :: ConsRep v
tyCons = forall (c :: Meta) (f :: Meta -> *) v.
Constructor c =>
GQLTypeOptions -> f c -> [FieldRep v] -> ConsRep v
deriveConsRep (forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v -> GQLTypeOptions
__valueGQLOptions DeriveValueOptions kind con v
options) (forall {k} (t :: k). Proxy t
Proxy @c) (forall {k} (c :: * -> Constraint) v (f :: k -> *)
(kind :: TypeCategory) (a :: k).
(DeriveFieldRep c v f, CategoryValue kind) =>
DeriveValueOptions kind c v -> f a -> [FieldRep v]
toFieldRep DeriveValueOptions kind con v
options f a
src)
}
deriveTypeDefinition :: forall (kind :: TypeCategory) (proxy :: (k -> *) -> *).
CategoryValue kind =>
DeriveTypeOptions kind con v -> proxy (M1 C c f) -> [ConsRep v]
deriveTypeDefinition DeriveTypeOptions kind con v
options proxy (M1 C c f)
_ = [forall (c :: Meta) (f :: Meta -> *) v.
Constructor c =>
GQLTypeOptions -> f c -> [FieldRep v] -> ConsRep v
deriveConsRep (forall {k} {k} (kind :: k) (c :: k -> Constraint) v.
DeriveTypeOptions kind c v -> GQLTypeOptions
__typeGQLOptions DeriveTypeOptions kind con v
options) (forall {k} (t :: k). Proxy t
Proxy @c) (forall {k} (c :: * -> Constraint) v (f :: k -> *)
(kind :: TypeCategory) (proxy :: (k -> *) -> *).
(DeriveFieldRep c v f, CategoryValue kind) =>
DeriveTypeOptions kind c v -> proxy f -> [FieldRep v]
conRep DeriveTypeOptions kind con v
options (forall {k} (t :: k). Proxy t
Proxy @f))]
deriveConsRep ::
Constructor (c :: Meta) =>
GQLTypeOptions ->
f c ->
[FieldRep v] ->
ConsRep v
deriveConsRep :: forall (c :: Meta) (f :: Meta -> *) v.
Constructor c =>
GQLTypeOptions -> f c -> [FieldRep v] -> ConsRep v
deriveConsRep GQLTypeOptions
opt f c
proxy [FieldRep v]
fields =
ConsRep
{ consName :: TypeName
consName = forall (f :: Meta -> *) (c :: Meta).
Constructor c =>
GQLTypeOptions -> f c -> TypeName
conNameProxy GQLTypeOptions
opt f c
proxy,
[FieldRep v]
consFields :: [FieldRep v]
consFields :: [FieldRep v]
consFields
}
where
consFields :: [FieldRep v]
consFields
| forall (f :: Meta -> *) (c :: Meta). Constructor c => f c -> Bool
isRecordProxy f c
proxy = [FieldRep v]
fields
| Bool
otherwise = forall a. [FieldRep a] -> [FieldRep a]
enumerate [FieldRep v]
fields
class DeriveFieldRep (c :: Type -> Constraint) (v :: Type) f where
toFieldRep :: CategoryValue kind => DeriveValueOptions kind c v -> f a -> [FieldRep v]
conRep :: CategoryValue kind => DeriveTypeOptions kind c v -> proxy f -> [FieldRep v]
instance (DeriveFieldRep c v a, DeriveFieldRep c v b) => DeriveFieldRep c v (a :*: b) where
toFieldRep :: forall (kind :: TypeCategory) (a :: k).
CategoryValue kind =>
DeriveValueOptions kind c v -> (:*:) a b a -> [FieldRep v]
toFieldRep DeriveValueOptions kind c v
options (a a
a :*: b a
b) = forall {k} (c :: * -> Constraint) v (f :: k -> *)
(kind :: TypeCategory) (a :: k).
(DeriveFieldRep c v f, CategoryValue kind) =>
DeriveValueOptions kind c v -> f a -> [FieldRep v]
toFieldRep DeriveValueOptions kind c v
options a a
a forall a. Semigroup a => a -> a -> a
<> forall {k} (c :: * -> Constraint) v (f :: k -> *)
(kind :: TypeCategory) (a :: k).
(DeriveFieldRep c v f, CategoryValue kind) =>
DeriveValueOptions kind c v -> f a -> [FieldRep v]
toFieldRep DeriveValueOptions kind c v
options b a
b
conRep :: forall (kind :: TypeCategory) (proxy :: (k -> *) -> *).
CategoryValue kind =>
DeriveTypeOptions kind c v -> proxy (a :*: b) -> [FieldRep v]
conRep DeriveTypeOptions kind c v
options proxy (a :*: b)
_ = forall {k} (c :: * -> Constraint) v (f :: k -> *)
(kind :: TypeCategory) (proxy :: (k -> *) -> *).
(DeriveFieldRep c v f, CategoryValue kind) =>
DeriveTypeOptions kind c v -> proxy f -> [FieldRep v]
conRep DeriveTypeOptions kind c v
options (forall {k} (t :: k). Proxy t
Proxy @a) forall a. Semigroup a => a -> a -> a
<> forall {k} (c :: * -> Constraint) v (f :: k -> *)
(kind :: TypeCategory) (proxy :: (k -> *) -> *).
(DeriveFieldRep c v f, CategoryValue kind) =>
DeriveTypeOptions kind c v -> proxy f -> [FieldRep v]
conRep DeriveTypeOptions kind c v
options (forall {k} (t :: k). Proxy t
Proxy @b)
instance (Selector s, c a) => DeriveFieldRep c v (M1 S s (Rec0 a)) where
toFieldRep :: forall (kind :: TypeCategory) (a :: k).
CategoryValue kind =>
DeriveValueOptions kind c v -> M1 S s (Rec0 a) a -> [FieldRep v]
toFieldRep DeriveValueOptions {TypeName
GQLTypeOptions
forall a. c a => a -> v
forall (f :: * -> *) a. c a => f a -> TypeData
__valueGetType :: forall (f :: * -> *) a. c a => f a -> TypeData
__valueApply :: forall a. c a => a -> v
__valueGQLOptions :: GQLTypeOptions
__valueTypeName :: TypeName
__valueGetType :: forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v
-> forall (f :: * -> *) a. c a => f a -> TypeData
__valueApply :: forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v -> forall a. c a => a -> v
__valueGQLOptions :: forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v -> GQLTypeOptions
__valueTypeName :: forall {k} (kind :: k) (c :: * -> Constraint) v.
DeriveValueOptions kind c v -> TypeName
..} (M1 (K1 a
src)) =
[ FieldRep
{ fieldSelector :: FieldName
fieldSelector = forall (f :: Meta -> *) (s :: Meta).
Selector s =>
GQLTypeOptions -> f s -> FieldName
selNameProxy GQLTypeOptions
__valueGQLOptions (forall {k} (t :: k). Proxy t
Proxy @s),
fieldTypeRef :: TypeRef
fieldTypeRef = TypeName -> TypeWrapper -> TypeRef
TypeRef TypeName
gqlTypeName TypeWrapper
gqlWrappers,
fieldValue :: v
fieldValue = forall a. c a => a -> v
__valueApply a
src
}
]
where
TypeData {TypeName
gqlTypeName :: TypeData -> TypeName
gqlTypeName :: TypeName
gqlTypeName, TypeWrapper
gqlWrappers :: TypeData -> TypeWrapper
gqlWrappers :: TypeWrapper
gqlWrappers} = forall (f :: * -> *) a. c a => f a -> TypeData
__valueGetType (forall {k} (t :: k). Proxy t
Proxy @a)
conRep :: forall (kind :: TypeCategory) (proxy :: (k -> *) -> *).
CategoryValue kind =>
DeriveTypeOptions kind c v
-> proxy (M1 S s (Rec0 a)) -> [FieldRep v]
conRep DeriveTypeDefinitionOptions {GQLTypeOptions
forall (f :: * -> *) a. c a => f a -> v
forall (f :: * -> *) a. c a => f a -> TypeData
__typeGetType :: forall (f :: * -> *) a. c a => f a -> TypeData
__typeApply :: forall (f :: * -> *) a. c a => f a -> v
__typeGQLOptions :: GQLTypeOptions
__typeGetType :: forall {k} {k} (kind :: k) (c :: k -> Constraint) v.
DeriveTypeOptions kind c v
-> forall (f :: k -> *) (a :: k). c a => f a -> TypeData
__typeApply :: forall {k} {k} (kind :: k) (c :: k -> Constraint) v.
DeriveTypeOptions kind c v
-> forall (f :: k -> *) (a :: k). c a => f a -> v
__typeGQLOptions :: forall {k} {k} (kind :: k) (c :: k -> Constraint) v.
DeriveTypeOptions kind c v -> GQLTypeOptions
..} proxy (M1 S s (Rec0 a))
_ =
[ FieldRep
{ fieldSelector :: FieldName
fieldSelector = forall (f :: Meta -> *) (s :: Meta).
Selector s =>
GQLTypeOptions -> f s -> FieldName
selNameProxy GQLTypeOptions
__typeGQLOptions (forall {k} (t :: k). Proxy t
Proxy @s),
fieldTypeRef :: TypeRef
fieldTypeRef = TypeName -> TypeWrapper -> TypeRef
TypeRef TypeName
gqlTypeName TypeWrapper
gqlWrappers,
fieldValue :: v
fieldValue = forall (f :: * -> *) a. c a => f a -> v
__typeApply (forall {k} (t :: k). Proxy t
Proxy @a)
}
]
where
TypeData {TypeName
gqlTypeName :: TypeName
gqlTypeName :: TypeData -> TypeName
gqlTypeName, TypeWrapper
gqlWrappers :: TypeWrapper
gqlWrappers :: TypeData -> TypeWrapper
gqlWrappers} = forall (f :: * -> *) a. c a => f a -> TypeData
__typeGetType (forall {k} (t :: k). Proxy t
Proxy @a)
instance DeriveFieldRep c v U1 where
toFieldRep :: forall (kind :: TypeCategory) (a :: k).
CategoryValue kind =>
DeriveValueOptions kind c v -> U1 a -> [FieldRep v]
toFieldRep DeriveValueOptions kind c v
_ U1 a
_ = []
conRep :: forall (kind :: TypeCategory) (proxy :: (k -> *) -> *).
CategoryValue kind =>
DeriveTypeOptions kind c v -> proxy U1 -> [FieldRep v]
conRep DeriveTypeOptions kind c v
_ proxy U1
_ = []