{-# 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 = (Text -> Name) -> [Text] -> [Name] forall a b. (a -> b) -> [a] -> [b] map (String -> Name mkName (String -> Name) -> (Text -> String) -> Text -> Name forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> String T.unpack) 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 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 forall a (t :: NAME). NamePacking a => Name t -> a unpackName) constraintTypeable :: Type -> Q Type constraintTypeable :: Type -> Q Type constraintTypeable Type name = Type -> Q Type forall (f :: * -> *) a. Applicative f => a -> f a pure (Type -> Q Type) -> Type -> Q Type forall a b. (a -> b) -> a -> b $ Name -> [Type] -> Type forall a i. (Apply a, ToCon i a) => i -> [a] -> a apply ''Typeable [Type name] mkTypeableConstraints :: [Name] -> CxtQ mkTypeableConstraints :: [Name] -> CxtQ mkTypeableConstraints = [Q Type] -> CxtQ cxt ([Q Type] -> CxtQ) -> ([Name] -> [Q Type]) -> [Name] -> CxtQ forall b c a. (b -> c) -> (a -> b) -> a -> c . (Type -> Q Type) -> [Type] -> [Q Type] forall a b. (a -> b) -> [a] -> [b] map Type -> Q Type constraintTypeable ([Type] -> [Q Type]) -> ([Name] -> [Type]) -> [Name] -> [Q Type] forall b c a. (b -> c) -> (a -> b) -> a -> c . [Name] -> [Type] forall a b. ToVar a b => [a] -> [b] vars