{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.TH.Declare.Type ( declareType, ) where import Data.Morpheus.CodeGen.Internal.AST ( DerivingClass (..), FIELD_TYPE_WRAPPER (..), ServerConstructorDefinition (..), ServerFieldDefinition (..), ServerTypeDefinition (..), unpackName, ) import Data.Morpheus.CodeGen.Internal.TH ( apply, declareTypeRef, toCon, toName, wrappedType, ) import Data.Morpheus.Server.TH.Utils ( m', m_, renderTypeVars, ) import Data.Morpheus.Types ( Arg, SubscriptionField, TypeGuard, ) import Data.Morpheus.Types.Internal.AST ( TypeKind (..), ) import qualified Data.Text as T import Language.Haskell.TH import Relude hiding (Type) declareType :: ServerTypeDefinition -> [Dec] declareType :: ServerTypeDefinition -> [Dec] declareType (ServerInterfaceDefinition TypeName name TypeName interfaceName TypeName unionName) = [ Name -> [TyVarBndr] -> Type -> Dec TySynD (TypeName -> Name forall a. ToName a => a -> Name toName TypeName name) #if MIN_VERSION_template_haskell(2,17,0) [PlainTV m_ ()] #else [Name -> TyVarBndr PlainTV Name m_] #endif (Name -> [Type] -> Type forall a i. (Apply a, ToCon i a) => i -> [a] -> a apply ''TypeGuard [TypeName -> [Type] -> Type forall a i. (Apply a, ToCon i a) => i -> [a] -> a apply TypeName interfaceName [Type m'], TypeName -> [Type] -> Type forall a i. (Apply a, ToCon i a) => i -> [a] -> a apply TypeName unionName [Type m']]) ] declareType ServerTypeDefinition {tKind :: ServerTypeDefinition -> TypeKind tKind = TypeKind KindScalar} = [] declareType ServerTypeDefinition { Text tName :: ServerTypeDefinition -> Text tName :: Text tName, [ServerConstructorDefinition] tCons :: ServerTypeDefinition -> [ServerConstructorDefinition] tCons :: [ServerConstructorDefinition] tCons, [DerivingClass] derives :: ServerTypeDefinition -> [DerivingClass] derives :: [DerivingClass] derives, [Text] typeParameters :: ServerTypeDefinition -> [Text] typeParameters :: [Text] typeParameters } = [[Type] -> Name -> [TyVarBndr] -> Maybe Type -> [Con] -> [DerivClause] -> Dec DataD [] (Text -> Name forall a. ToName a => a -> Name toName Text tName) [TyVarBndr] vars Maybe Type forall a. Maybe a Nothing [Con] cons [DerivClause derivingClause]] where derivingClause :: DerivClause derivingClause = Maybe DerivStrategy -> [Type] -> DerivClause DerivClause Maybe DerivStrategy forall a. Maybe a Nothing ((DerivingClass -> Type) -> [DerivingClass] -> [Type] forall a b. (a -> b) -> [a] -> [b] map (Name -> Type ConT (Name -> Type) -> (DerivingClass -> Name) -> DerivingClass -> Type forall b c a. (b -> c) -> (a -> b) -> a -> c . DerivingClass -> Name genName) [DerivingClass] derives) cons :: [Con] cons = (ServerConstructorDefinition -> Con) -> [ServerConstructorDefinition] -> [Con] forall a b. (a -> b) -> [a] -> [b] map ServerConstructorDefinition -> Con declareCons [ServerConstructorDefinition] tCons #if MIN_VERSION_template_haskell(2,17,0) vars = map (flip PlainTV ()) (renderTypeVars typeParameters) #else vars :: [TyVarBndr] vars = (Name -> TyVarBndr) -> [Name] -> [TyVarBndr] forall a b. (a -> b) -> [a] -> [b] map Name -> TyVarBndr PlainTV ([Text] -> [Name] renderTypeVars [Text] typeParameters) #endif genName :: DerivingClass -> Name genName :: DerivingClass -> Name genName DerivingClass GENERIC = ''Generic genName DerivingClass SHOW = ''Show declareCons :: ServerConstructorDefinition -> Con declareCons :: ServerConstructorDefinition -> Con declareCons ServerConstructorDefinition {TypeName constructorName :: ServerConstructorDefinition -> TypeName constructorName :: TypeName constructorName, [ServerFieldDefinition] constructorFields :: ServerConstructorDefinition -> [ServerFieldDefinition] constructorFields :: [ServerFieldDefinition] constructorFields} = Name -> [VarBangType] -> Con RecC (TypeName -> Name forall a. ToName a => a -> Name toName TypeName constructorName) ((ServerFieldDefinition -> VarBangType) -> [ServerFieldDefinition] -> [VarBangType] forall a b. (a -> b) -> [a] -> [b] map ServerFieldDefinition -> VarBangType declareField [ServerFieldDefinition] constructorFields) declareField :: ServerFieldDefinition -> (Name, Bang, Type) declareField :: ServerFieldDefinition -> VarBangType declareField ServerFieldDefinition { FieldName fieldName :: ServerFieldDefinition -> FieldName fieldName :: FieldName fieldName, Text fieldType :: ServerFieldDefinition -> Text fieldType :: Text fieldType, [FIELD_TYPE_WRAPPER] wrappers :: ServerFieldDefinition -> [FIELD_TYPE_WRAPPER] wrappers :: [FIELD_TYPE_WRAPPER] wrappers } = ( FieldName -> Name forall a. ToName a => a -> Name toName FieldName fieldName, SourceUnpackedness -> SourceStrictness -> Bang Bang SourceUnpackedness NoSourceUnpackedness SourceStrictness NoSourceStrictness, (FIELD_TYPE_WRAPPER -> Type -> Type) -> Type -> [FIELD_TYPE_WRAPPER] -> Type forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr FIELD_TYPE_WRAPPER -> Type -> Type applyWrapper (Text -> Type forall a b. ToCon a b => a -> b toCon Text fieldType) [FIELD_TYPE_WRAPPER] wrappers ) applyWrapper :: FIELD_TYPE_WRAPPER -> Type -> Type applyWrapper :: FIELD_TYPE_WRAPPER -> Type -> Type applyWrapper FIELD_TYPE_WRAPPER PARAMETRIZED = (Type -> Type -> Type `AppT` Type m') applyWrapper FIELD_TYPE_WRAPPER MONAD = Type -> Type -> Type AppT Type m' applyWrapper FIELD_TYPE_WRAPPER SUBSCRIPTION = Type -> Type -> Type AppT (Name -> Type ConT ''SubscriptionField) applyWrapper (ARG TypeName typeName) = Type -> Name -> Type -> Type InfixT (Name -> Type ConT (TypeName -> Name forall a. ToName a => a -> Name toName TypeName typeName)) ''Function applyWrapper (GQL_WRAPPER TypeWrapper wrappers) = TypeWrapper -> Type -> Type wrappedType TypeWrapper wrappers applyWrapper (TAGGED_ARG FieldName fieldName TypeRef typeRef) = Type -> Name -> Type -> Type InfixT Type arg ''Function where arg :: Type arg = Type -> Type -> Type AppT ( Type -> Type -> Type AppT (Name -> Type ConT ''Arg) (TyLit -> Type LitT (TyLit -> Type) -> TyLit -> Type forall a b. (a -> b) -> a -> b $ String -> TyLit StrTyLit (String -> TyLit) -> String -> TyLit forall a b. (a -> b) -> a -> b $ Text -> String T.unpack (Text -> String) -> Text -> String forall a b. (a -> b) -> a -> b $ FieldName -> Text forall a (t :: NAME). NamePacking a => Name t -> a unpackName FieldName fieldName) ) ((TypeName -> Type) -> TypeRef -> Type declareTypeRef TypeName -> Type forall a b. ToCon a b => a -> b toCon TypeRef typeRef) type Function = (->)