{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.TH.Utils ( constraintTypeable, typeNameStringE, withPure, mkTypeableConstraints, m', m_, funDProxy, ServerDec, renderTypeVars, ) where import Data.Morpheus.CodeGen.Internal.AST ( CodeGenConfig, ) import Data.Morpheus.CodeGen.Internal.TH ( apply, funDSimple, vars, _', ) import Data.Morpheus.Types.Internal.AST ( TypeName, unpackName, ) import Data.Text (unpack) import qualified Data.Text as T import Language.Haskell.TH ( CxtQ, DecQ, Exp (..), ExpQ, Lit (..), Name, Q, Type (..), cxt, mkName, ) import Relude hiding (Type) type ServerDec = ReaderT CodeGenConfig Q m_ :: Name m_ :: Name m_ = String -> Name mkName String "m" m' :: Type m' :: Type m' = Name -> Type VarT Name m_ renderTypeVars :: [Text] -> [Name] renderTypeVars :: [Text] -> [Name] renderTypeVars = forall a b. (a -> b) -> [a] -> [b] map (String -> Name mkName forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> String T.unpack) funDProxy :: [(Name, ExpQ)] -> [DecQ] funDProxy :: [(Name, ExpQ)] -> [DecQ] funDProxy = 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> Lit StringL forall b c a. (b -> c) -> (a -> b) -> a -> c . (Text -> String unpack forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a (t :: NAME). NamePacking a => Name t -> a unpackName) constraintTypeable :: Type -> Q Type constraintTypeable :: Type -> Q Type constraintTypeable Type name = forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall a i. (Apply a, ToCon i a) => i -> [a] -> a apply ''Typeable [Type name] mkTypeableConstraints :: [Name] -> CxtQ mkTypeableConstraints :: [Name] -> CxtQ mkTypeableConstraints = forall (m :: * -> *). Quote m => [m Type] -> m [Type] cxt forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map Type -> Q Type constraintTypeable forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. ToVar a b => [a] -> [b] vars