{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.Internal.TH.Utils ( kindName, constraintTypeable, typeNameStringE, withPure, mkTypeableConstraints, m', m_, tyConArgs, funDProxy, isParametrizedResolverType, isSubscription, ) where import Data.Morpheus.Internal.TH ( _', apply, funDSimple, toName, vars, ) import Data.Morpheus.Kind ( INTERFACE, SCALAR, TYPE, WRAPPER, ) import Data.Morpheus.Types.Internal.AST ( ANY, OperationType (..), TypeDefinition (..), TypeKind (..), TypeName (..), isResolverType, lookupWith, ) import Data.Text (unpack) import Language.Haskell.TH ( CxtQ, Dec (..), DecQ, Exp (..), ExpQ, Info (..), Lit (..), Name, Q, TyVarBndr, Type (..), cxt, mkName, reify, ) import Relude hiding (Type) m_ :: String m_ :: String m_ = String "m" m' :: Type m' :: Type m' = Name -> Type VarT (String -> Name mkName String m_) isParametrizedResolverType :: TypeName -> [TypeDefinition ANY s] -> Q Bool isParametrizedResolverType :: TypeName -> [TypeDefinition ANY s] -> Q Bool isParametrizedResolverType TypeName "__TypeKind" [TypeDefinition ANY s] _ = Bool -> Q Bool forall (f :: * -> *) a. Applicative f => a -> f a pure Bool False isParametrizedResolverType TypeName "Boolean" [TypeDefinition ANY s] _ = Bool -> Q Bool forall (f :: * -> *) a. Applicative f => a -> f a pure Bool False isParametrizedResolverType TypeName "String" [TypeDefinition ANY s] _ = Bool -> Q Bool forall (f :: * -> *) a. Applicative f => a -> f a pure Bool False isParametrizedResolverType TypeName "Int" [TypeDefinition ANY s] _ = Bool -> Q Bool forall (f :: * -> *) a. Applicative f => a -> f a pure Bool False isParametrizedResolverType TypeName "Float" [TypeDefinition ANY s] _ = Bool -> Q Bool forall (f :: * -> *) a. Applicative f => a -> f a pure Bool False isParametrizedResolverType TypeName key [TypeDefinition ANY s] lib = case (TypeDefinition ANY s -> TypeName) -> TypeName -> [TypeDefinition ANY s] -> Maybe (TypeDefinition ANY s) forall k a. Eq k => (a -> k) -> k -> [a] -> Maybe a lookupWith TypeDefinition ANY s -> TypeName forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName typeName TypeName key [TypeDefinition ANY s] lib of Just TypeDefinition ANY s x -> Bool -> Q Bool forall (f :: * -> *) a. Applicative f => a -> f a pure (TypeDefinition ANY s -> Bool forall t. Strictness t => t -> Bool isResolverType TypeDefinition ANY s x) Maybe (TypeDefinition ANY s) Nothing -> Info -> Bool isParametrizedType (Info -> Bool) -> Q Info -> Q Bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Name -> Q Info reify (TypeName -> Name forall a. ToName a => a -> Name toName TypeName key) isParametrizedType :: Info -> Bool isParametrizedType :: Info -> Bool isParametrizedType (TyConI Dec x) = Bool -> Bool not (Bool -> Bool) -> Bool -> Bool forall a b. (a -> b) -> a -> b $ [TyVarBndr] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null ([TyVarBndr] -> Bool) -> [TyVarBndr] -> Bool forall a b. (a -> b) -> a -> b $ Dec -> [TyVarBndr] getTypeVariables Dec x isParametrizedType Info _ = Bool False getTypeVariables :: Dec -> [TyVarBndr] getTypeVariables :: Dec -> [TyVarBndr] getTypeVariables (DataD Cxt _ Name _ [TyVarBndr] args Maybe Type _ [Con] _ [DerivClause] _) = [TyVarBndr] args getTypeVariables (NewtypeD Cxt _ Name _ [TyVarBndr] args Maybe Type _ Con _ [DerivClause] _) = [TyVarBndr] args getTypeVariables (TySynD Name _ [TyVarBndr] args Type _) = [TyVarBndr] args getTypeVariables Dec _ = [] funDProxy :: [(Name, ExpQ)] -> [DecQ] funDProxy :: [(Name, ExpQ)] -> [DecQ] funDProxy = ((Name, ExpQ) -> DecQ) -> [(Name, ExpQ)] -> [DecQ] forall a b. (a -> b) -> [a] -> [b] map (Name, ExpQ) -> DecQ fun where fun :: (Name, ExpQ) -> DecQ fun (Name name, ExpQ body) = Name -> [PatQ] -> ExpQ -> DecQ funDSimple Name name [PatQ _'] ExpQ body tyConArgs :: TypeKind -> [String] tyConArgs :: TypeKind -> [String] tyConArgs TypeKind kind | TypeKind -> Bool forall t. Strictness t => t -> Bool isResolverType TypeKind kind = [String m_] | Bool otherwise = [] withPure :: Exp -> Exp withPure :: Exp -> Exp withPure = Exp -> Exp -> Exp AppE (Name -> Exp VarE 'pure) typeNameStringE :: TypeName -> Exp typeNameStringE :: TypeName -> Exp typeNameStringE = Lit -> Exp LitE (Lit -> Exp) -> (TypeName -> Lit) -> TypeName -> Exp forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> Lit StringL (String -> Lit) -> (TypeName -> String) -> TypeName -> Lit forall b c a. (b -> c) -> (a -> b) -> a -> c . (Text -> String unpack (Text -> String) -> (TypeName -> Text) -> TypeName -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . TypeName -> Text readTypeName) constraintTypeable :: Type -> Type constraintTypeable :: Type -> Type constraintTypeable Type name = Name -> Cxt -> Type forall a i. (Apply a, ToCon i a) => i -> [a] -> a apply ''Typeable [Type name] mkTypeableConstraints :: [String] -> CxtQ mkTypeableConstraints :: [String] -> CxtQ mkTypeableConstraints [String] args = [PredQ] -> CxtQ cxt ([PredQ] -> CxtQ) -> [PredQ] -> CxtQ forall a b. (a -> b) -> a -> b $ (Type -> PredQ) -> Cxt -> [PredQ] forall a b. (a -> b) -> [a] -> [b] map (Type -> PredQ forall (f :: * -> *) a. Applicative f => a -> f a pure (Type -> PredQ) -> (Type -> Type) -> Type -> PredQ forall b c a. (b -> c) -> (a -> b) -> a -> c . Type -> Type constraintTypeable) ([String] -> Cxt forall a b. ToVar a b => [a] -> [b] vars [String] args) kindName :: TypeKind -> Name kindName :: TypeKind -> Name kindName TypeKind KindScalar = ''SCALAR kindName TypeKind KindList = ''WRAPPER kindName TypeKind KindNonNull = ''WRAPPER kindName TypeKind KindInterface = ''INTERFACE kindName TypeKind _ = ''TYPE isSubscription :: TypeKind -> Bool isSubscription :: TypeKind -> Bool isSubscription (KindObject (Just OperationType Subscription)) = Bool True isSubscription TypeKind _ = Bool False