{-# 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.Generic.GRep
( GRep (..),
GRepFun (..),
GRepCons (..),
GRepField (..),
GRepValue (..),
GRepType (..),
deriveValue,
deriveType,
)
where
import Data.List (partition)
import Data.Morpheus.Generic.Proxy
( conNameP,
isRecordP,
selNameP,
)
import Data.Morpheus.Types.Internal.AST
( FieldName,
TypeName,
TypeRef (..),
TypeWrapper,
packName,
)
import Data.Text (pack)
import GHC.Generics
( C,
Constructor,
D,
Datatype,
Generic (..),
K1 (..),
M1 (..),
Meta,
Rec0,
S,
Selector,
U1 (..),
(:*:) (..),
(:+:) (..),
)
import Relude hiding (undefined)
data GRepFun gql fun f result = GRepFun
{ grepFun :: forall a. (fun a) => f a -> result,
grepTypename :: forall proxy a. (gql a) => proxy a -> TypeName,
grepWrappers :: forall proxy a. (gql a) => proxy a -> TypeWrapper
}
deriveValue ::
(Generic a, GRep gql constraint value (Rep a), gql a) =>
GRepFun gql constraint Identity value ->
a ->
GRepValue value
deriveValue options value
| null cons = GRepValueEnum typename (consName cons)
| isUnion = case (isUnionRef typename cons, consFields cons) of
(True, [GRepField {..}]) -> GRepValueUnionRef (typeConName fieldTypeRef) fieldValue
_ -> GRepValueUnion typename (consName cons) (consFields cons)
| otherwise = GRepValueObject typename (consFields cons)
where
(isUnion, cons) = deriveTypeValue options (from value)
typename = grepTypename options (Identity value)
toRep :: f a -> Proxy (Rep a)
toRep _ = Proxy
deriveType ::
forall kind gql c v kinded m a.
(GRep gql c (m v) (Rep a), Monad m, gql a) =>
GRepFun gql c Proxy (m v) ->
kinded kind a ->
m (GRepType v)
deriveType ctx x = toType <$> unpackMonad (deriveTypeDefinition ctx (toRep x))
where
toType cons | all null cons = GRepTypeEnum (consName <$> cons)
toType [GRepCons {consFields}] = GRepTypeObject consFields
toType cons = GRepTypeUnion unionRef unionCons
where
unionRef = toVer <$> concatMap consFields unionRefRep
where
toVer GRepField {..} = (typeConName fieldTypeRef, fieldValue)
--
(unionRefRep, unionCons) = partition (isUnionRef typename) cons
typename = grepTypename ctx x
-- GENERIC UNION
class GRep (gql :: Type -> Constraint) (c :: Type -> Constraint) (v :: Type) f where
deriveTypeValue :: GRepFun gql c Identity v -> f a -> (Bool, GRepCons v)
deriveTypeDefinition :: GRepFun gql c Proxy v -> proxy f -> [GRepCons v]
instance (Datatype d, GRep gql c v f) => GRep gql c v (M1 D d f) where
deriveTypeValue options (M1 src) = deriveTypeValue options src
deriveTypeDefinition options _ = deriveTypeDefinition options (Proxy @f)
-- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT'
instance (GRep gql c v a, GRep gql c v b) => GRep gql c v (a :+: b) where
deriveTypeValue f (L1 x) = (True, snd (deriveTypeValue f x))
deriveTypeValue f (R1 x) = (True, snd (deriveTypeValue f x))
deriveTypeDefinition options _ = deriveTypeDefinition options (Proxy @a) <> deriveTypeDefinition options (Proxy @b)
instance (DeriveFieldRep gql con v f, Constructor c) => GRep gql con v (M1 C c f) where
deriveTypeValue options (M1 src) = (False, deriveConsRep (Proxy @c) (toFieldRep options src))
deriveTypeDefinition options _ = [deriveConsRep (Proxy @c) (conRep options (Proxy @f))]
deriveConsRep ::
(Constructor (c :: Meta)) =>
f c ->
[GRepField v] ->
GRepCons v
deriveConsRep proxy fields = GRepCons {..}
where
consName = conNameP proxy
consFields
| isRecordP proxy = fields
| otherwise = enumerate fields
class DeriveFieldRep (gql :: Type -> Constraint) (c :: Type -> Constraint) (v :: Type) f where
toFieldRep :: GRepFun gql c Identity v -> f a -> [GRepField v]
conRep :: GRepFun gql c Proxy v -> proxy f -> [GRepField v]
scanRec :: GRepFun gql c Proxy v -> proxy f -> [v]
instance (DeriveFieldRep gql c v a, DeriveFieldRep gql c v b) => DeriveFieldRep gql c v (a :*: b) where
toFieldRep options (a :*: b) = toFieldRep options a <> toFieldRep options b
conRep options _ = conRep options (Proxy @a) <> conRep options (Proxy @b)
scanRec ctx _ = scanRec ctx (Proxy @a) <> scanRec ctx (Proxy @b)
instance (Selector s, gql a, c a) => DeriveFieldRep gql c v (M1 S s (Rec0 a)) where
toFieldRep GRepFun {..} (M1 (K1 src)) =
[ GRepField
{ fieldSelector = selNameP (Proxy @s),
fieldTypeRef = TypeRef (grepTypename (Proxy @a)) (grepWrappers (Proxy @a)),
fieldValue = grepFun (Identity src)
}
]
conRep GRepFun {..} _ =
[ GRepField
{ fieldSelector = selNameP (Proxy @s),
fieldTypeRef = TypeRef (grepTypename (Proxy @a)) (grepWrappers (Proxy @a)),
fieldValue = grepFun (Proxy @a)
}
]
scanRec GRepFun {..} _ = [grepFun (Proxy @a)]
instance DeriveFieldRep gql c v U1 where
toFieldRep _ _ = []
conRep _ _ = []
scanRec _ _ = []
data GRepType v
= GRepTypeEnum [TypeName]
| GRepTypeObject [GRepField v]
| GRepTypeUnion
{ variantRefs :: [(TypeName, v)],
inlineVariants :: [GRepCons v]
}
instance Foldable GRepType where
foldr _ res GRepTypeEnum {} = res
foldr f res (GRepTypeObject fields) = foldr f res (map fieldValue fields)
foldr f res GRepTypeUnion {inlineVariants, variantRefs} = foldr f res (concatMap toList inlineVariants <> map snd variantRefs)
data GRepValue v
= GRepValueUnionRef
{ unionRefTypeName :: TypeName,
unionRefValue :: v
}
| GRepValueUnion
{ unionTypeName :: TypeName,
unionVariantName :: TypeName,
unionFields :: [GRepField v]
}
| GRepValueObject
{ objectTypeName :: TypeName,
objectFields :: [GRepField v]
}
| GRepValueEnum
{ enumTypeName :: TypeName,
enumVariantName :: TypeName
}
deriving (Functor)
data GRepCons (a :: Type) = GRepCons
{ consName :: TypeName,
consFields :: [GRepField a]
}
deriving (Functor)
instance Foldable GRepCons where
foldMap f GRepCons {..} = foldMap f (map fieldValue consFields)
data GRepField (a :: Type) = GRepField
{ fieldSelector :: FieldName,
fieldTypeRef :: TypeRef,
fieldValue :: a
}
deriving (Functor)
-- setFieldNames :: Power Int Text -> Power { _1 :: Int, _2 :: Text }
enumerate :: [GRepField a] -> [GRepField a]
enumerate = zipWith setFieldName ([0 ..] :: [Int])
where
setFieldName i field = field {fieldSelector = packName $ "_" <> pack (show i)}
isUnionRef :: TypeName -> GRepCons k -> Bool
isUnionRef baseName GRepCons {consName, consFields = [fieldRep]} =
consName == baseName <> typeConName (fieldTypeRef fieldRep)
isUnionRef _ _ = False
unpackMonad :: (Monad m) => [GRepCons (m a)] -> m [GRepCons a]
unpackMonad = traverse unpackMonadFromCons
unpackMonadFromField :: (Monad m) => GRepField (m a) -> m (GRepField a)
unpackMonadFromField GRepField {..} = do
cont <- fieldValue
pure (GRepField {fieldValue = cont, ..})
unpackMonadFromCons :: (Monad m) => GRepCons (m a) -> m (GRepCons a)
unpackMonadFromCons GRepCons {..} = GRepCons consName <$> traverse unpackMonadFromField consFields