{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.Internal.TH.Utils ( kindName, constraintTypeable, typeNameStringE, withPure, o', e', mkTypeableConstraints, ) where import Data.Morpheus.Internal.TH ( apply, toName, vars, ) import Data.Morpheus.Kind ( ENUM, INPUT, INTERFACE, OUTPUT, SCALAR, WRAPPER, ) import Data.Morpheus.Types.Internal.AST ( TypeKind (..), TypeName (..), ) import Data.Text (unpack) import Data.Typeable (Typeable) import Language.Haskell.TH ( CxtQ, Exp (..), Lit (..), Name, Type (..), cxt, ) import Prelude ( ($), (.), String, map, pure, ) o' :: Type o' :: Type o' = Name -> Type VarT (Name -> Type) -> Name -> Type forall a b. (a -> b) -> a -> b $ TypeName -> Name forall a. ToName a => a -> Name toName (TypeName "operation" :: TypeName) e' :: Type e' :: Type e' = Name -> Type VarT (Name -> Type) -> Name -> Type forall a b. (a -> b) -> a -> b $ TypeName -> Name forall a. ToName a => a -> Name toName (TypeName "encodeEvent" :: TypeName) 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 -> [Type] -> 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) -> [Type] -> [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] -> [Type] forall a b. ToVar a b => [a] -> [b] vars [String] args) kindName :: TypeKind -> Name kindName :: TypeKind -> Name kindName KindObject {} = ''OUTPUT kindName TypeKind KindScalar = ''SCALAR kindName TypeKind KindEnum = ''ENUM kindName TypeKind KindUnion = ''OUTPUT kindName TypeKind KindInputObject = ''INPUT kindName TypeKind KindList = ''WRAPPER kindName TypeKind KindNonNull = ''WRAPPER kindName TypeKind KindInputUnion = ''INPUT kindName TypeKind KindInterface = ''INTERFACE