Here's some functions I found myself needing when I wrote Template Greencard which I think would be useful additions to the TH libraries. The names could probably be a bit better and, in some cases, putting a function in the Q monad (i.e., lift the args and result) might be helpful. -- Functions for building types --| mkIOTy alpha = [| IO alpha |] mkIOTy :: Typ -> Typ mkIOTy ty = ConTyp (ConNameTag "GHC.IOBase:IO") `AppTyp` ty --| mkArrows [t1,...tm] rty = [| t1 -> ... -> tm -> rty |] mkArrows :: [Typ] -> Typ -> Typ mkArrows as r = foldr (\ a as -> tapply (ConTyp ArrowTag) [a,as]) r as --| mkTupleTy [t1, ... tm] = [| (t1, ... tm) |] mkTupleTy :: [Typ] -> Typ mkTupleTy [] = htype_Void mkTupleTy [ty] = ty mkTupleTy tys = tapply (ConTyp (TupleTag (length tys))) tys --| tapply tc [t1,...tm] = [| tc t1 ... tm |] tapply :: Typ -> [Typ] -> Typ tapply f [] = f tapply f (a:as) = tapply (AppTyp f a) as -- Functions for taking types apart --| unarrow [| t1 -> ... tm -> rty |] = ([t1, ... tm], rty) unarrow :: Typ -> ([Typ],Typ) unarrow (AppTyp (AppTyp (ConTyp ArrowTag) ty1) ty2) = let (as,r) = unarrow ty2 in (ty1:as,r) unarrow ty = ([],ty) --| unIO [| IO ty |] = (True, ty) unIO :: Typ -> (Bool,Typ) unIO (AppTyp (ConTyp (ConNameTag "GHC.IOBase:IO")) ty) = (True, ty) unIO ty = (False, ty) --| untuple [| (ty1,...tm) |] = [ty1,..tm] untuple :: Typ -> [Typ] untuple ty = case split ty of (ConTyp (TupleTag n), tys) -> tys (ConTyp (ConNameTag "GHC.Base:()"),[]) -> [] _ -> [ty] -- Functions for building expressions and patterns --| simpleLet v e body = [| let v = e in body |] simpleLet :: Var -> Q Exp -> Q Exp -> Q Exp simpleLet v e body = letE [val (VarPat v) (normal e) []] body --| mkPTuple [p1,...pm] = [| (p1,...pm() |] mkPTuple :: [Pat] -> Pat mkPTuple [p] = p mkPTuple ps = TupPat ps -- Reifications of common types -- (The important thing here is that they are not in the Q monad -- so I can refer to them in guards.) htype_Ptr :: HType htype_Ptr = ConTyp (ConNameTag "GHC.Ptr:Ptr") htype_FunPtr :: HType htype_FunPtr = ConTyp (ConNameTag "GHC.Ptr:FunPtr") htype_StablePtr :: HType htype_StablePtr = ConTyp (ConNameTag "GHC.Stable:StablePtr") htype_Void :: HType htype_Void = ConTyp (ConNameTag "GHC.Base:()")