2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5 Collects a variety of helper functions that
6 construct or analyse HsSyn
11 #include "HsVersions.h"
19 import RdrName ( RdrName, getRdrName, mkRdrUnqual )
22 import DataCon ( DataCon, dataConWrapId, dataConSourceArity )
23 import BasicTypes ( RecFlag(..) )
24 import OccName ( mkVarOcc )
27 import FastString ( mkFastString )
29 import Util ( nOfThem )
34 %************************************************************************
36 Some useful helpers for constructing expressions
38 %************************************************************************
42 mkHsPar :: LHsExpr id -> LHsExpr id
43 mkHsPar e = L (getLoc e) (HsPar e)
45 mkSimpleMatch :: [LPat id] -> LHsExpr id -> Type -> LMatch id
46 mkSimpleMatch pats rhs rhs_ty
47 = addCLoc (head pats) rhs $
48 Match pats Nothing (GRHSs (unguardedRHS rhs) [] rhs_ty)
50 unguardedRHS :: LHsExpr id -> [LGRHS id]
51 unguardedRHS rhs@(L loc _) = [L loc (GRHS [L loc (ResultStmt rhs)])]
53 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
54 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
56 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
57 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
59 mkHsTyApp :: LHsExpr name -> [Type] -> LHsExpr name
60 mkHsTyApp expr [] = expr
61 mkHsTyApp expr tys = L (getLoc expr) (TyApp expr tys)
63 mkHsDictApp expr [] = expr
64 mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
66 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
67 mkHsLam pats body = mkHsPar (L (getLoc match) (HsLam match))
69 match = mkSimpleMatch pats body placeHolderType
71 mkHsTyLam [] expr = expr
72 mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
74 mkHsDictLam [] expr = expr
75 mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr)
77 mkHsLet :: Bag (LHsBind name) -> LHsExpr name -> LHsExpr name
79 | isEmptyBag binds = expr
80 | otherwise = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr)
82 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
83 -- Used for constructing dictinoary terms etc, so no locations
84 mkHsConApp data_con tys args
85 = foldl mk_app (noLoc (HsVar (dataConWrapId data_con)) `mkHsTyApp` tys) args
87 mk_app f a = noLoc (HsApp f (noLoc a))
89 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
90 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
91 mkSimpleHsAlt pat expr
92 = mkSimpleMatch [pat] expr placeHolderType
94 glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id
95 glueBindsOnGRHSs binds1 (GRHSs grhss binds2 ty)
96 = GRHSs grhss (binds1 : binds2) ty
98 -- These are the bits of syntax that contain rebindable names
99 -- See RnEnv.lookupSyntaxName
101 mkHsIntegral i = HsIntegral i placeHolderName
102 mkHsFractional f = HsFractional f placeHolderName
103 mkNPlusKPat n k = NPlusKPatIn n k placeHolderName
104 mkHsDo ctxt stmts = HsDo ctxt stmts [] placeHolderType
106 --- A useful function for building @OpApps@. The operator is always a
107 -- variable, and we don't know the fixity yet.
108 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
110 mkHsSplice e = HsSplice unqualSplice e
112 unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
113 -- A name (uniquified later) to
114 -- identify the splice
116 mkHsString s = HsString (mkFastString s)
120 %************************************************************************
122 These ones do not pin on useful locations
123 Used mainly for generated code
125 %************************************************************************
129 nlHsVar :: id -> LHsExpr id
130 nlHsVar n = noLoc (HsVar n)
132 nlHsLit :: HsLit -> LHsExpr id
133 nlHsLit n = noLoc (HsLit n)
135 nlVarPat :: id -> LPat id
136 nlVarPat n = noLoc (VarPat n)
138 nlLitPat :: HsLit -> LPat id
139 nlLitPat l = noLoc (LitPat l)
141 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
142 nlHsApp f x = noLoc (HsApp f x)
144 nlHsIntLit n = noLoc (HsLit (HsInt n))
146 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
147 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
149 nlHsVarApps :: id -> [id] -> LHsExpr id
150 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
152 mk f a = HsApp (noLoc f) (noLoc a)
154 nlConVarPat :: id -> [id] -> LPat id
155 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
157 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
158 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
160 nlConPat :: id -> [LPat id] -> LPat id
161 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
163 nlNullaryConPat :: id -> LPat id
164 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
166 nlWildConPat :: DataCon -> LPat RdrName
167 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
168 (PrefixCon (nOfThem (dataConSourceArity con) wildPat)))
170 nlTuplePat pats box = noLoc (TuplePat pats box)
171 wildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
173 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id
174 nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
176 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
178 nlHsLam match = noLoc (HsLam match)
179 nlHsPar e = noLoc (HsPar e)
180 nlHsIf cond true false = noLoc (HsIf cond true false)
181 nlHsCase expr matches = noLoc (HsCase expr matches)
182 nlTuple exprs box = noLoc (ExplicitTuple exprs box)
183 nlList exprs = noLoc (ExplicitList placeHolderType exprs)
185 nlHsAppTy f t = noLoc (HsAppTy f t)
186 nlHsTyVar x = noLoc (HsTyVar x)
187 nlHsFunTy a b = noLoc (HsFunTy a b)
189 nlExprStmt expr = noLoc (ExprStmt expr placeHolderType)
190 nlBindStmt pat expr = noLoc (BindStmt pat expr)
191 nlLetStmt binds = noLoc (LetStmt binds)
192 nlResultStmt expr = noLoc (ResultStmt expr)
193 nlParStmt stuff = noLoc (ParStmt stuff)
198 %************************************************************************
200 Bindings; with a location at the top
202 %************************************************************************
205 mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
206 mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyBag rhs
208 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
209 -> LHsBinds RdrName -> LHsExpr RdrName
212 mk_easy_FunBind loc fun pats binds expr
213 = L loc (FunBind (L loc fun) False{-not infix-}
214 [mk_easy_Match pats binds expr])
216 mk_easy_Match pats binds expr
217 = mkMatch pats expr [HsBindGroup binds [] Recursive]
218 -- The renamer expects everything in its input to be a
219 -- "recursive" MonoBinds, and it is its job to sort things out
222 mk_FunBind :: SrcSpan
224 -> [([LPat RdrName], LHsExpr RdrName)]
227 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
228 mk_FunBind loc fun pats_and_exprs
229 = L loc (FunBind (L loc fun) False{-not infix-}
230 [mkMatch p e [] | (p,e) <-pats_and_exprs])
232 mkMatch :: [LPat id] -> LHsExpr id -> [HsBindGroup id] -> LMatch id
233 mkMatch pats expr binds
234 = noLoc (Match (map paren pats) Nothing
235 (GRHSs (unguardedRHS expr) binds placeHolderType))
239 L l _ -> L l (ParPat p)