{-# 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 (forall a. ToName a => a -> Name toName TypeName name) #if MIN_VERSION_template_haskell(2,17,0) [forall flag. Name -> flag -> TyVarBndr flag PlainTV Name m_ ()] #else [PlainTV m_] #endif (forall a i. (Apply a, ToCon i a) => i -> [a] -> a apply ''TypeGuard [forall a i. (Apply a, ToCon i a) => i -> [a] -> a apply TypeName interfaceName [Type m'], 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 [] (forall a. ToName a => a -> Name toName Text tName) [TyVarBndr ()] vars forall a. Maybe a Nothing [Con] cons [DerivClause derivingClause]] where derivingClause :: DerivClause derivingClause = Maybe DerivStrategy -> [Type] -> DerivClause DerivClause forall a. Maybe a Nothing (forall a b. (a -> b) -> [a] -> [b] map (Name -> Type ConT forall b c a. (b -> c) -> (a -> b) -> a -> c . DerivingClass -> Name genName) [DerivingClass] derives) cons :: [Con] cons = forall a b. (a -> b) -> [a] -> [b] map ServerConstructorDefinition -> Con declareCons [ServerConstructorDefinition] tCons #if MIN_VERSION_template_haskell(2,17,0) vars :: [TyVarBndr ()] vars = forall a b. (a -> b) -> [a] -> [b] map (forall a b c. (a -> b -> c) -> b -> a -> c flip forall flag. Name -> flag -> TyVarBndr flag PlainTV ()) ([Text] -> [Name] renderTypeVars [Text] typeParameters) #else vars = map PlainTV (renderTypeVars 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 (forall a. ToName a => a -> Name toName TypeName constructorName) (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 } = ( forall a. ToName a => a -> Name toName FieldName fieldName, SourceUnpackedness -> SourceStrictness -> Bang Bang SourceUnpackedness NoSourceUnpackedness SourceStrictness NoSourceStrictness, forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr FIELD_TYPE_WRAPPER -> Type -> Type applyWrapper (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 (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 forall a b. (a -> b) -> a -> b $ String -> TyLit StrTyLit forall a b. (a -> b) -> a -> b $ Text -> String T.unpack forall a b. (a -> b) -> a -> b $ forall a (t :: NAME). NamePacking a => Name t -> a unpackName FieldName fieldName) ) ((TypeName -> Type) -> TypeRef -> Type declareTypeRef forall a b. ToCon a b => a -> b toCon TypeRef typeRef) type Function = (->)