{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Morpheus.Server.TH.Declare.Channels
( deriveChannels,
)
where
import Data.Morpheus.Internal.TH
( _',
apply,
destructRecord,
funDSimple,
m',
mkFieldsE,
)
import Data.Morpheus.Server.Deriving.Channels
( ExploreChannels (..),
GetChannel (..),
)
import Data.Morpheus.Server.Internal.TH.Types
( ServerTypeDefinition (..),
)
import Data.Morpheus.Server.Internal.TH.Utils
( e',
)
import Data.Morpheus.Types.Internal.AST
( ConsD (..),
FieldDefinition (..),
FieldName,
SUBSCRIPTION,
Selection,
TRUE,
TypeName (..),
VALID,
isSubscription,
)
import Data.Morpheus.Types.Internal.Resolving
( Channel,
Resolver,
ResolverState,
)
import Data.Semigroup ((<>))
import Language.Haskell.TH
mkEntry ::
GetChannel e a =>
FieldName ->
a ->
( FieldName,
Selection VALID -> ResolverState (Channel e)
)
mkEntry name field = (name, getChannel field)
mkType :: TypeName -> Type
mkType tName = apply tName [apply ''Resolver [ConT ''SUBSCRIPTION, e', m']]
mkTypeClass :: TypeName -> Type
mkTypeClass tName = apply ''ExploreChannels [ConT ''TRUE, mkType tName, e']
exploreChannelsD :: TypeName -> [FieldDefinition cat s] -> DecQ
exploreChannelsD tName fields = funDSimple 'exploreChannels args body
where
args = [_', destructRecord tName fields]
body = pure (mkFieldsE 'mkEntry fields)
deriveChannels :: ServerTypeDefinition cat s -> Q [Dec]
deriveChannels ServerTypeDefinition {tName, tCons = [ConsD {cFields}], tKind}
| isSubscription tKind =
pure <$> instanceD context typeDef funDefs
where
context = cxt []
typeDef = pure (mkTypeClass tName)
funDefs = [exploreChannelsD tName cFields]
deriveChannels _ = pure []