{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Server.TH.Declare.Type
( declareType,
)
where
import Data.Morpheus.Internal.TH
( declareTypeRef,
m',
nameSpaceField,
nameSpaceType,
toName,
tyConArgs,
)
import Data.Morpheus.Server.Internal.TH.Types
( ServerDec,
ServerDecContext (..),
ServerTypeDefinition (..),
)
import Data.Morpheus.Types.Internal.AST
( ArgumentsDefinition (..),
ConsD (..),
FieldContent (..),
FieldDefinition (..),
FieldName (..),
TRUE,
TypeKind (..),
TypeName (..),
isOutput,
isOutputObject,
isSubscription,
)
import Data.Morpheus.Types.Internal.Resolving
( SubscriptionField,
)
import Language.Haskell.TH
import Relude hiding (Type)
declareType :: ServerTypeDefinition cat s -> ServerDec [Dec]
declareType :: ServerTypeDefinition cat s -> ServerDec [Dec]
declareType ServerTypeDefinition {tKind :: forall (cat :: TypeCategory) (s :: Stage).
ServerTypeDefinition cat s -> TypeKind
tKind = TypeKind
KindScalar} = [Dec] -> ServerDec [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
declareType
ServerTypeDefinition
{ TypeName
tName :: forall (cat :: TypeCategory) (s :: Stage).
ServerTypeDefinition cat s -> TypeName
tName :: TypeName
tName,
[ConsD cat s]
tCons :: forall (cat :: TypeCategory) (s :: Stage).
ServerTypeDefinition cat s -> [ConsD cat s]
tCons :: [ConsD cat s]
tCons,
TypeKind
tKind :: TypeKind
tKind :: forall (cat :: TypeCategory) (s :: Stage).
ServerTypeDefinition cat s -> TypeKind
tKind
} =
do
[Con]
cons <- TypeKind -> TypeName -> [ConsD cat s] -> ServerDec [Con]
forall (cat :: TypeCategory) (s :: Stage).
TypeKind -> TypeName -> [ConsD cat s] -> ServerDec [Con]
declareCons TypeKind
tKind TypeName
tName [ConsD cat s]
tCons
let vars :: [TyVarBndr]
vars = (String -> TyVarBndr) -> [String] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> TyVarBndr
PlainTV (Name -> TyVarBndr) -> (String -> Name) -> String -> TyVarBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
forall a. ToName a => a -> Name
toName) (TypeKind -> [String]
tyConArgs TypeKind
tKind)
[Dec] -> ServerDec [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ Cxt
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD
[]
(TypeName -> Name
forall a. ToName a => a -> Name
toName TypeName
tName)
[TyVarBndr]
vars
Maybe Kind
forall a. Maybe a
Nothing
[Con]
cons
(TypeKind -> [DerivClause]
derive TypeKind
tKind)
]
derive :: TypeKind -> [DerivClause]
derive :: TypeKind -> [DerivClause]
derive TypeKind
tKind = [[Name] -> DerivClause
deriveClasses (''Generic Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
derivingList)]
where
derivingList :: [Name]
derivingList
| TypeKind -> Bool
isOutput TypeKind
tKind = []
| Bool
otherwise = [''Show]
deriveClasses :: [Name] -> DerivClause
deriveClasses :: [Name] -> DerivClause
deriveClasses [Name]
classNames = Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing ((Name -> Kind) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Kind
ConT [Name]
classNames)
declareCons ::
TypeKind ->
TypeName ->
[ConsD cat s] ->
ServerDec [Con]
declareCons :: TypeKind -> TypeName -> [ConsD cat s] -> ServerDec [Con]
declareCons TypeKind
tKind TypeName
tName = (ConsD cat s -> ReaderT ServerDecContext Identity Con)
-> [ConsD cat s] -> ServerDec [Con]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ConsD cat s -> ReaderT ServerDecContext Identity Con
consR
where
consR :: ConsD cat s -> ReaderT ServerDecContext Identity Con
consR ConsD {TypeName
cName :: forall (cat :: TypeCategory) (s :: Stage). ConsD cat s -> TypeName
cName :: TypeName
cName, [FieldDefinition cat s]
cFields :: forall (cat :: TypeCategory) (s :: Stage).
ConsD cat s -> [FieldDefinition cat s]
cFields :: [FieldDefinition cat s]
cFields} =
Name -> [VarBangType] -> Con
RecC
(Name -> [VarBangType] -> Con)
-> ReaderT ServerDecContext Identity Name
-> ReaderT ServerDecContext Identity ([VarBangType] -> Con)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeKind
-> TypeName -> TypeName -> ReaderT ServerDecContext Identity Name
consName TypeKind
tKind TypeName
tName TypeName
cName
ReaderT ServerDecContext Identity ([VarBangType] -> Con)
-> ReaderT ServerDecContext Identity [VarBangType]
-> ReaderT ServerDecContext Identity Con
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FieldDefinition cat s
-> ReaderT ServerDecContext Identity VarBangType)
-> [FieldDefinition cat s]
-> ReaderT ServerDecContext Identity [VarBangType]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (TypeKind
-> TypeName
-> FieldDefinition cat s
-> ReaderT ServerDecContext Identity VarBangType
forall (cat :: TypeCategory) (s :: Stage).
TypeKind
-> TypeName
-> FieldDefinition cat s
-> ReaderT ServerDecContext Identity VarBangType
declareField TypeKind
tKind TypeName
tName) [FieldDefinition cat s]
cFields
consName :: TypeKind -> TypeName -> TypeName -> ServerDec Name
consName :: TypeKind
-> TypeName -> TypeName -> ReaderT ServerDecContext Identity Name
consName TypeKind
KindEnum (TypeName Text
name) TypeName
conName = do
Bool
namespace' <- (ServerDecContext -> Bool)
-> ReaderT ServerDecContext Identity Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServerDecContext -> Bool
namespace
if Bool
namespace'
then Name -> ReaderT ServerDecContext Identity Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> ReaderT ServerDecContext Identity Name)
-> Name -> ReaderT ServerDecContext Identity Name
forall a b. (a -> b) -> a -> b
$ TypeName -> Name
forall a. ToName a => a -> Name
toName (TypeName -> Name) -> TypeName -> Name
forall a b. (a -> b) -> a -> b
$ [FieldName] -> TypeName -> TypeName
nameSpaceType [Text -> FieldName
FieldName Text
name] TypeName
conName
else Name -> ReaderT ServerDecContext Identity Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeName -> Name
forall a. ToName a => a -> Name
toName TypeName
conName)
consName TypeKind
_ TypeName
_ TypeName
conName = Name -> ReaderT ServerDecContext Identity Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeName -> Name
forall a. ToName a => a -> Name
toName TypeName
conName)
declareField ::
TypeKind ->
TypeName ->
FieldDefinition cat s ->
ServerDec (Name, Bang, Type)
declareField :: TypeKind
-> TypeName
-> FieldDefinition cat s
-> ReaderT ServerDecContext Identity VarBangType
declareField TypeKind
tKind TypeName
tName field :: FieldDefinition cat s
field@FieldDefinition {FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName} = do
Bool
namespace' <- (ServerDecContext -> Bool)
-> ReaderT ServerDecContext Identity Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServerDecContext -> Bool
namespace
VarBangType -> ReaderT ServerDecContext Identity VarBangType
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Bool -> TypeName -> FieldName -> Name
fieldTypeName Bool
namespace' TypeName
tName FieldName
fieldName,
SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness,
TypeKind -> FieldDefinition cat s -> Kind
forall (cat :: TypeCategory) (s :: Stage).
TypeKind -> FieldDefinition cat s -> Kind
renderFieldType TypeKind
tKind FieldDefinition cat s
field
)
renderFieldType ::
TypeKind ->
FieldDefinition cat s ->
Type
renderFieldType :: TypeKind -> FieldDefinition cat s -> Kind
renderFieldType TypeKind
tKind FieldDefinition {Maybe (FieldContent TRUE cat s)
fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldContent :: Maybe (FieldContent TRUE cat s)
fieldContent, TypeRef
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType :: TypeRef
fieldType} =
TypeKind -> Maybe (FieldContent TRUE cat s) -> Kind -> Kind
forall (cat :: TypeCategory) (s :: Stage).
TypeKind -> Maybe (FieldContent TRUE cat s) -> Kind -> Kind
withFieldWrappers TypeKind
tKind Maybe (FieldContent TRUE cat s)
fieldContent (TypeRef -> Kind
declareTypeRef TypeRef
fieldType)
fieldTypeName :: Bool -> TypeName -> FieldName -> Name
fieldTypeName :: Bool -> TypeName -> FieldName -> Name
fieldTypeName Bool
namespace TypeName
tName FieldName
fieldName
| Bool
namespace = FieldName -> Name
forall a. ToName a => a -> Name
toName (TypeName -> FieldName -> FieldName
nameSpaceField TypeName
tName FieldName
fieldName)
| Bool
otherwise = FieldName -> Name
forall a. ToName a => a -> Name
toName FieldName
fieldName
withSubscriptionField :: TypeKind -> Type -> Type
withSubscriptionField :: TypeKind -> Kind -> Kind
withSubscriptionField TypeKind
kind Kind
x
| TypeKind -> Bool
isSubscription TypeKind
kind = Kind -> Kind -> Kind
AppT (Name -> Kind
ConT ''SubscriptionField) Kind
x
| Bool
otherwise = Kind
x
withArgs :: TypeName -> Type -> Type
withArgs :: TypeName -> Kind -> Kind
withArgs TypeName
argsTypename = Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind
AppT Kind
arrowType Kind
argType)
where
argType :: Kind
argType = Name -> Kind
ConT (Name -> Kind) -> Name -> Kind
forall a b. (a -> b) -> a -> b
$ TypeName -> Name
forall a. ToName a => a -> Name
toName TypeName
argsTypename
arrowType :: Kind
arrowType = Name -> Kind
ConT ''Arrow
withMonad :: Type -> Type
withMonad :: Kind -> Kind
withMonad = Kind -> Kind -> Kind
AppT Kind
m'
type Arrow = (->)
withFieldWrappers ::
TypeKind ->
Maybe (FieldContent TRUE cat s) ->
Type ->
Type
withFieldWrappers :: TypeKind -> Maybe (FieldContent TRUE cat s) -> Kind -> Kind
withFieldWrappers TypeKind
kind (Just (FieldArgs ArgumentsDefinition {argumentsTypename :: forall (s :: Stage). ArgumentsDefinition s -> Maybe TypeName
argumentsTypename = Just TypeName
argsTypename})) =
TypeName -> Kind -> Kind
withArgs TypeName
argsTypename
(Kind -> Kind) -> (Kind -> Kind) -> Kind -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeKind -> Kind -> Kind
withSubscriptionField TypeKind
kind
(Kind -> Kind) -> (Kind -> Kind) -> Kind -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Kind
withMonad
withFieldWrappers TypeKind
kind Maybe (FieldContent TRUE cat s)
_
| TypeKind -> Bool
isOutputObject TypeKind
kind =
TypeKind -> Kind -> Kind
withSubscriptionField TypeKind
kind
(Kind -> Kind) -> (Kind -> Kind) -> Kind -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Kind
withMonad
| Bool
otherwise = Kind -> Kind
forall a. a -> a
id