{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# 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.GRep
( GRep (..),
RepContext (..),
ConsRep (..),
FieldRep (..),
TypeRep (..),
deriveValue,
deriveTypeWith,
isEmptyConstraint,
isUnionRef,
unpackMonad,
)
where
import Data.Morpheus.Server.Deriving.Utils.Proxy
( conNameProxy,
isRecordProxy,
selNameProxy,
)
import Data.Morpheus.Server.Types.Internal
( TypeData (..),
)
import Data.Morpheus.Types.Internal.AST
( FieldName,
TypeName,
TypeRef (..),
packName,
)
import qualified Data.Text as T
import GHC.Generics
( C,
Constructor,
D,
Datatype,
Generic (..),
K1 (..),
M1 (..),
Meta,
Rec0,
S,
Selector,
U1 (..),
(:*:) (..),
(:+:) (..),
)
import Relude hiding (undefined)
data RepContext gql fun f result = RepContext
{ forall {k} {k} (gql :: k -> Constraint) (fun :: k -> Constraint)
(f :: k -> *) result.
RepContext gql fun f result
-> forall (a :: k). fun a => f a -> result
optApply :: forall a. fun a => f a -> result,
forall {k} {k} (gql :: k -> Constraint) (fun :: k -> Constraint)
(f :: k -> *) result.
RepContext gql fun f result
-> forall (proxy :: k -> *) (a :: k). gql a => proxy a -> TypeData
optTypeData :: forall proxy a. gql a => proxy a -> TypeData
}
deriveValue ::
(Generic a, GRep gql constraint value (Rep a), gql a) =>
RepContext gql constraint Identity value ->
a ->
TypeRep value
deriveValue :: forall a (gql :: * -> Constraint) (constraint :: * -> Constraint)
value.
(Generic a, GRep gql constraint value (Rep a), gql a) =>
RepContext gql constraint Identity value -> a -> TypeRep value
deriveValue RepContext gql constraint Identity value
options a
value = (forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
(f :: k -> *) (a :: k).
GRep gql c v f =>
RepContext gql c Identity v -> f a -> TypeRep v
deriveTypeValue RepContext gql constraint Identity value
options (forall a x. Generic a => a -> Rep a x
from a
value)) {TypeName
dataTypeName :: TypeName
dataTypeName :: TypeName
dataTypeName}
where
dataTypeName :: TypeName
dataTypeName = TypeData -> TypeName
gqlTypeName (forall {k} {k} (gql :: k -> Constraint) (fun :: k -> Constraint)
(f :: k -> *) result.
RepContext gql fun f result
-> forall (proxy :: k -> *) (a :: k). gql a => proxy a -> TypeData
optTypeData RepContext gql constraint Identity value
options (forall a. a -> Identity a
Identity a
value))
deriveTypeWith ::
forall kind gql c v kinded a.
(GRep gql c v (Rep a)) =>
RepContext gql c Proxy v ->
kinded kind a ->
[ConsRep v]
deriveTypeWith :: forall {k} (kind :: k) (gql :: * -> Constraint)
(c :: * -> Constraint) v (kinded :: k -> * -> *) a.
GRep gql c v (Rep a) =>
RepContext gql c Proxy v -> kinded kind a -> [ConsRep v]
deriveTypeWith RepContext gql c Proxy v
options kinded kind a
_ = forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
(f :: k -> *) (proxy :: (k -> *) -> *).
GRep gql c v f =>
RepContext gql c Proxy v -> proxy f -> [ConsRep v]
deriveTypeDefinition RepContext gql c Proxy v
options (forall {k} (t :: k). Proxy t
Proxy @(Rep a))
class GRep (gql :: Type -> Constraint) (c :: Type -> Constraint) (v :: Type) f where
deriveTypeValue :: RepContext gql c Identity v -> f a -> TypeRep v
deriveTypeDefinition :: RepContext gql c Proxy v -> proxy f -> [ConsRep v]
instance (Datatype d, GRep gql c v f) => GRep gql c v (M1 D d f) where
deriveTypeValue :: forall (a :: k).
RepContext gql c Identity v -> M1 D d f a -> TypeRep v
deriveTypeValue RepContext gql c Identity v
options (M1 f a
src) = forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
(f :: k -> *) (a :: k).
GRep gql c v f =>
RepContext gql c Identity v -> f a -> TypeRep v
deriveTypeValue RepContext gql c Identity v
options f a
src
deriveTypeDefinition :: forall (proxy :: (k -> *) -> *).
RepContext gql c Proxy v -> proxy (M1 D d f) -> [ConsRep v]
deriveTypeDefinition RepContext gql c Proxy v
options proxy (M1 D d f)
_ = forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
(f :: k -> *) (proxy :: (k -> *) -> *).
GRep gql c v f =>
RepContext gql c Proxy v -> proxy f -> [ConsRep v]
deriveTypeDefinition RepContext gql c Proxy v
options (forall {k} (t :: k). Proxy t
Proxy @f)
instance (GRep gql c v a, GRep gql c v b) => GRep gql c v (a :+: b) where
deriveTypeValue :: forall (a :: k).
RepContext gql c Identity v -> (:+:) a b a -> TypeRep v
deriveTypeValue RepContext gql c Identity v
f (L1 a a
x) = (forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
(f :: k -> *) (a :: k).
GRep gql c v f =>
RepContext gql c Identity v -> f a -> TypeRep v
deriveTypeValue RepContext gql c Identity v
f a a
x) {tyIsUnion :: Bool
tyIsUnion = Bool
True}
deriveTypeValue RepContext gql c Identity v
f (R1 b a
x) = (forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
(f :: k -> *) (a :: k).
GRep gql c v f =>
RepContext gql c Identity v -> f a -> TypeRep v
deriveTypeValue RepContext gql c Identity v
f b a
x) {tyIsUnion :: Bool
tyIsUnion = Bool
True}
deriveTypeDefinition :: forall (proxy :: (k -> *) -> *).
RepContext gql c Proxy v -> proxy (a :+: b) -> [ConsRep v]
deriveTypeDefinition RepContext gql c Proxy v
options proxy (a :+: b)
_ = forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
(f :: k -> *) (proxy :: (k -> *) -> *).
GRep gql c v f =>
RepContext gql c Proxy v -> proxy f -> [ConsRep v]
deriveTypeDefinition RepContext gql c Proxy v
options (forall {k} (t :: k). Proxy t
Proxy @a) forall a. Semigroup a => a -> a -> a
<> forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
(f :: k -> *) (proxy :: (k -> *) -> *).
GRep gql c v f =>
RepContext gql c Proxy v -> proxy f -> [ConsRep v]
deriveTypeDefinition RepContext gql c Proxy v
options (forall {k} (t :: k). Proxy t
Proxy @b)
instance (DeriveFieldRep gql con v f, Constructor c) => GRep gql con v (M1 C c f) where
deriveTypeValue :: forall (a :: k).
RepContext gql con Identity v -> M1 C c f a -> TypeRep v
deriveTypeValue RepContext gql con Identity v
options (M1 f a
src) =
TypeRep
{ dataTypeName :: TypeName
dataTypeName = TypeName
"",
tyIsUnion :: Bool
tyIsUnion = Bool
False,
tyCons :: ConsRep v
tyCons = forall (c :: Meta) (f :: Meta -> *) v.
Constructor c =>
f c -> [FieldRep v] -> ConsRep v
deriveConsRep (forall {k} (t :: k). Proxy t
Proxy @c) (forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
(f :: k -> *) (a :: k).
DeriveFieldRep gql c v f =>
RepContext gql c Identity v -> f a -> [FieldRep v]
toFieldRep RepContext gql con Identity v
options f a
src)
}
deriveTypeDefinition :: forall (proxy :: (k -> *) -> *).
RepContext gql con Proxy v -> proxy (M1 C c f) -> [ConsRep v]
deriveTypeDefinition RepContext gql con Proxy v
options proxy (M1 C c f)
_ = [forall (c :: Meta) (f :: Meta -> *) v.
Constructor c =>
f c -> [FieldRep v] -> ConsRep v
deriveConsRep (forall {k} (t :: k). Proxy t
Proxy @c) (forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
(f :: k -> *) (proxy :: (k -> *) -> *).
DeriveFieldRep gql c v f =>
RepContext gql c Proxy v -> proxy f -> [FieldRep v]
conRep RepContext gql con Proxy v
options (forall {k} (t :: k). Proxy t
Proxy @f))]
deriveConsRep ::
Constructor (c :: Meta) =>
f c ->
[FieldRep v] ->
ConsRep v
deriveConsRep :: forall (c :: Meta) (f :: Meta -> *) v.
Constructor c =>
f c -> [FieldRep v] -> ConsRep v
deriveConsRep f c
proxy [FieldRep v]
fields = ConsRep {[FieldRep v]
TypeName
consFields :: [FieldRep v]
consName :: TypeName
consFields :: [FieldRep v]
consName :: TypeName
..}
where
consName :: TypeName
consName = forall (f :: Meta -> *) (c :: Meta).
Constructor c =>
f c -> TypeName
conNameProxy f c
proxy
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 (gql :: Type -> Constraint) (c :: Type -> Constraint) (v :: Type) f where
toFieldRep :: RepContext gql c Identity v -> f a -> [FieldRep v]
conRep :: RepContext gql c Proxy v -> proxy f -> [FieldRep v]
instance (DeriveFieldRep gql c v a, DeriveFieldRep gql c v b) => DeriveFieldRep gql c v (a :*: b) where
toFieldRep :: forall (a :: k).
RepContext gql c Identity v -> (:*:) a b a -> [FieldRep v]
toFieldRep RepContext gql c Identity v
options (a a
a :*: b a
b) = forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
(f :: k -> *) (a :: k).
DeriveFieldRep gql c v f =>
RepContext gql c Identity v -> f a -> [FieldRep v]
toFieldRep RepContext gql c Identity v
options a a
a forall a. Semigroup a => a -> a -> a
<> forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
(f :: k -> *) (a :: k).
DeriveFieldRep gql c v f =>
RepContext gql c Identity v -> f a -> [FieldRep v]
toFieldRep RepContext gql c Identity v
options b a
b
conRep :: forall (proxy :: (k -> *) -> *).
RepContext gql c Proxy v -> proxy (a :*: b) -> [FieldRep v]
conRep RepContext gql c Proxy v
options proxy (a :*: b)
_ = forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
(f :: k -> *) (proxy :: (k -> *) -> *).
DeriveFieldRep gql c v f =>
RepContext gql c Proxy v -> proxy f -> [FieldRep v]
conRep RepContext gql c Proxy v
options (forall {k} (t :: k). Proxy t
Proxy @a) forall a. Semigroup a => a -> a -> a
<> forall {k} (gql :: * -> Constraint) (c :: * -> Constraint) v
(f :: k -> *) (proxy :: (k -> *) -> *).
DeriveFieldRep gql c v f =>
RepContext gql c Proxy v -> proxy f -> [FieldRep v]
conRep RepContext gql c Proxy v
options (forall {k} (t :: k). Proxy t
Proxy @b)
instance (Selector s, gql a, c a) => DeriveFieldRep gql c v (M1 S s (Rec0 a)) where
toFieldRep :: forall (a :: k).
RepContext gql c Identity v -> M1 S s (Rec0 a) a -> [FieldRep v]
toFieldRep RepContext {forall a. c a => Identity a -> v
forall (proxy :: * -> *) a. gql a => proxy a -> TypeData
optTypeData :: forall (proxy :: * -> *) a. gql a => proxy a -> TypeData
optApply :: forall a. c a => Identity a -> v
optTypeData :: forall {k} {k} (gql :: k -> Constraint) (fun :: k -> Constraint)
(f :: k -> *) result.
RepContext gql fun f result
-> forall (proxy :: k -> *) (a :: k). gql a => proxy a -> TypeData
optApply :: forall {k} {k} (gql :: k -> Constraint) (fun :: k -> Constraint)
(f :: k -> *) result.
RepContext gql fun f result
-> forall (a :: k). fun a => f a -> result
..} (M1 (K1 a
src)) =
[ FieldRep
{ fieldSelector :: FieldName
fieldSelector = forall (f :: Meta -> *) (s :: Meta). Selector s => f s -> FieldName
selNameProxy (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 => Identity a -> v
optApply (forall a. a -> Identity a
Identity a
src)
}
]
where
TypeData {TypeName
gqlTypeName :: TypeName
gqlTypeName :: TypeData -> TypeName
gqlTypeName, TypeWrapper
gqlWrappers :: TypeData -> TypeWrapper
gqlWrappers :: TypeWrapper
gqlWrappers} = forall (proxy :: * -> *) a. gql a => proxy a -> TypeData
optTypeData (forall {k} (t :: k). Proxy t
Proxy @a)
conRep :: forall (proxy :: (k -> *) -> *).
RepContext gql c Proxy v -> proxy (M1 S s (Rec0 a)) -> [FieldRep v]
conRep RepContext {forall a. c a => Proxy a -> v
forall (proxy :: * -> *) a. gql a => proxy a -> TypeData
optTypeData :: forall (proxy :: * -> *) a. gql a => proxy a -> TypeData
optApply :: forall a. c a => Proxy a -> v
optTypeData :: forall {k} {k} (gql :: k -> Constraint) (fun :: k -> Constraint)
(f :: k -> *) result.
RepContext gql fun f result
-> forall (proxy :: k -> *) (a :: k). gql a => proxy a -> TypeData
optApply :: forall {k} {k} (gql :: k -> Constraint) (fun :: k -> Constraint)
(f :: k -> *) result.
RepContext gql fun f result
-> forall (a :: k). fun a => f a -> result
..} proxy (M1 S s (Rec0 a))
_ =
[ FieldRep
{ fieldSelector :: FieldName
fieldSelector = forall (f :: Meta -> *) (s :: Meta). Selector s => f s -> FieldName
selNameProxy (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 => Proxy a -> v
optApply (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 (proxy :: * -> *) a. gql a => proxy a -> TypeData
optTypeData (forall {k} (t :: k). Proxy t
Proxy @a)
instance DeriveFieldRep gql c v U1 where
toFieldRep :: forall (a :: k).
RepContext gql c Identity v -> U1 a -> [FieldRep v]
toFieldRep RepContext gql c Identity v
_ U1 a
_ = []
conRep :: forall (proxy :: (k -> *) -> *).
RepContext gql c Proxy v -> proxy U1 -> [FieldRep v]
conRep RepContext gql c Proxy v
_ proxy U1
_ = []
data TypeRep (v :: Type) = TypeRep
{ forall v. TypeRep v -> TypeName
dataTypeName :: TypeName,
forall v. TypeRep v -> Bool
tyIsUnion :: Bool,
forall v. TypeRep v -> ConsRep v
tyCons :: ConsRep v
}
deriving (forall a b. a -> TypeRep b -> TypeRep a
forall a b. (a -> b) -> TypeRep a -> TypeRep b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> TypeRep b -> TypeRep a
$c<$ :: forall a b. a -> TypeRep b -> TypeRep a
fmap :: forall a b. (a -> b) -> TypeRep a -> TypeRep b
$cfmap :: forall a b. (a -> b) -> TypeRep a -> TypeRep b
Functor)
data ConsRep (v :: Type) = ConsRep
{ forall v. ConsRep v -> TypeName
consName :: TypeName,
forall v. ConsRep v -> [FieldRep v]
consFields :: [FieldRep v]
}
deriving (forall a b. a -> ConsRep b -> ConsRep a
forall a b. (a -> b) -> ConsRep a -> ConsRep b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ConsRep b -> ConsRep a
$c<$ :: forall a b. a -> ConsRep b -> ConsRep a
fmap :: forall a b. (a -> b) -> ConsRep a -> ConsRep b
$cfmap :: forall a b. (a -> b) -> ConsRep a -> ConsRep b
Functor)
data FieldRep (a :: Type) = FieldRep
{ forall a. FieldRep a -> FieldName
fieldSelector :: FieldName,
forall a. FieldRep a -> TypeRef
fieldTypeRef :: TypeRef,
forall a. FieldRep a -> a
fieldValue :: a
}
deriving (forall a b. a -> FieldRep b -> FieldRep a
forall a b. (a -> b) -> FieldRep a -> FieldRep b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> FieldRep b -> FieldRep a
$c<$ :: forall a b. a -> FieldRep b -> FieldRep a
fmap :: forall a b. (a -> b) -> FieldRep a -> FieldRep b
$cfmap :: forall a b. (a -> b) -> FieldRep a -> FieldRep b
Functor)
enumerate :: [FieldRep a] -> [FieldRep a]
enumerate :: forall a. [FieldRep a] -> [FieldRep a]
enumerate = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a} {a}. Show a => a -> FieldRep a -> FieldRep a
setFieldName ([Int
0 ..] :: [Int])
where
setFieldName :: a -> FieldRep a -> FieldRep a
setFieldName a
i FieldRep a
field = FieldRep a
field {fieldSelector :: FieldName
fieldSelector = forall a (t :: NAME). NamePacking a => a -> Name t
packName forall a b. (a -> b) -> a -> b
$ Text
"_" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall b a. (Show a, IsString b) => a -> b
show a
i)}
isEmptyConstraint :: ConsRep a -> Bool
isEmptyConstraint :: forall a. ConsRep a -> Bool
isEmptyConstraint ConsRep {consFields :: forall v. ConsRep v -> [FieldRep v]
consFields = []} = Bool
True
isEmptyConstraint ConsRep a
_ = Bool
False
isUnionRef :: TypeName -> ConsRep k -> Bool
isUnionRef :: forall k. TypeName -> ConsRep k -> Bool
isUnionRef TypeName
baseName ConsRep {TypeName
consName :: TypeName
consName :: forall v. ConsRep v -> TypeName
consName, consFields :: forall v. ConsRep v -> [FieldRep v]
consFields = [FieldRep k
fieldRep]} =
TypeName
consName forall a. Eq a => a -> a -> Bool
== TypeName
baseName forall a. Semigroup a => a -> a -> a
<> TypeRef -> TypeName
typeConName (forall a. FieldRep a -> TypeRef
fieldTypeRef FieldRep k
fieldRep)
isUnionRef TypeName
_ ConsRep k
_ = Bool
False
unpackMonad :: Monad m => [ConsRep (m a)] -> m [ConsRep a]
unpackMonad :: forall (m :: * -> *) a. Monad m => [ConsRep (m a)] -> m [ConsRep a]
unpackMonad = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) a. Monad m => ConsRep (m a) -> m (ConsRep a)
unpackMonadFromCons
unpackMonadFromField :: Monad m => FieldRep (m a) -> m (FieldRep a)
unpackMonadFromField :: forall (m :: * -> *) a. Monad m => FieldRep (m a) -> m (FieldRep a)
unpackMonadFromField FieldRep {m a
TypeRef
FieldName
fieldValue :: m a
fieldTypeRef :: TypeRef
fieldSelector :: FieldName
fieldValue :: forall a. FieldRep a -> a
fieldTypeRef :: forall a. FieldRep a -> TypeRef
fieldSelector :: forall a. FieldRep a -> FieldName
..} = do
a
cont <- m a
fieldValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldRep {fieldValue :: a
fieldValue = a
cont, TypeRef
FieldName
fieldTypeRef :: TypeRef
fieldSelector :: FieldName
fieldTypeRef :: TypeRef
fieldSelector :: FieldName
..})
unpackMonadFromCons :: Monad m => ConsRep (m a) -> m (ConsRep a)
unpackMonadFromCons :: forall (m :: * -> *) a. Monad m => ConsRep (m a) -> m (ConsRep a)
unpackMonadFromCons ConsRep {[FieldRep (m a)]
TypeName
consFields :: [FieldRep (m a)]
consName :: TypeName
consFields :: forall v. ConsRep v -> [FieldRep v]
consName :: forall v. ConsRep v -> TypeName
..} = forall v. TypeName -> [FieldRep v] -> ConsRep v
ConsRep TypeName
consName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) a. Monad m => FieldRep (m a) -> m (FieldRep a)
unpackMonadFromField [FieldRep (m a)]
consFields