[Template-haskell] Useful TH library functions

[Alastair Reid]

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:()")