2 % (c) The University of Glasgow, 1992-2003
5 Here we collect a variety of helper functions that construct or
6 analyse HsSyn. All these functions deal with generic HsSyn; functions
7 which deal with the intantiated versions are located elsewhere:
9 Parameterised by Module
10 ---------------- -------------
11 RdrName parser/RdrHsSyn
18 #include "HsVersions.h"
26 import RdrName ( RdrName, getRdrName, mkRdrUnqual )
29 import DataCon ( DataCon, dataConWrapId, dataConSourceArity )
30 import BasicTypes ( RecFlag(..) )
31 import OccName ( mkVarOcc )
34 import FastString ( mkFastString )
36 import Util ( nOfThem )
41 %************************************************************************
43 Some useful helpers for constructing syntax
45 %************************************************************************
47 These functions attempt to construct a not-completely-useless SrcSpan
48 from their components, compared with the nl* functions below which
49 just attach noSrcSpan to everything.
52 mkHsPar :: LHsExpr id -> LHsExpr id
53 mkHsPar e = L (getLoc e) (HsPar e)
55 mkSimpleMatch :: [LPat id] -> LHsExpr id -> Type -> LMatch id
56 mkSimpleMatch pats rhs rhs_ty
57 = addCLoc (head pats) rhs $
58 Match pats Nothing (GRHSs (unguardedRHS rhs) [] rhs_ty)
60 unguardedRHS :: LHsExpr id -> [LGRHS id]
61 unguardedRHS rhs@(L loc _) = [L loc (GRHS [L loc (ResultStmt rhs)])]
63 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
64 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
66 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
67 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
69 mkHsTyApp :: LHsExpr name -> [Type] -> LHsExpr name
70 mkHsTyApp expr [] = expr
71 mkHsTyApp expr tys = L (getLoc expr) (TyApp expr tys)
73 mkHsDictApp expr [] = expr
74 mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
76 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
77 mkHsLam pats body = mkHsPar (L (getLoc match) (HsLam match))
79 match = mkSimpleMatch pats body placeHolderType
81 mkHsTyLam [] expr = expr
82 mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
84 mkHsDictLam [] expr = expr
85 mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr)
87 mkHsLet :: Bag (LHsBind name) -> LHsExpr name -> LHsExpr name
89 | isEmptyBag binds = expr
90 | otherwise = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr)
92 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
93 -- Used for constructing dictinoary terms etc, so no locations
94 mkHsConApp data_con tys args
95 = foldl mk_app (noLoc (HsVar (dataConWrapId data_con)) `mkHsTyApp` tys) args
97 mk_app f a = noLoc (HsApp f (noLoc a))
99 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
100 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
101 mkSimpleHsAlt pat expr
102 = mkSimpleMatch [pat] expr placeHolderType
104 glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id
105 glueBindsOnGRHSs binds1 (GRHSs grhss binds2 ty)
106 = GRHSs grhss (binds1 : binds2) ty
108 -- These are the bits of syntax that contain rebindable names
109 -- See RnEnv.lookupSyntaxName
111 mkHsIntegral i = HsIntegral i placeHolderName
112 mkHsFractional f = HsFractional f placeHolderName
113 mkNPlusKPat n k = NPlusKPatIn n k placeHolderName
114 mkHsDo ctxt stmts = HsDo ctxt stmts [] placeHolderType
116 --- A useful function for building @OpApps@. The operator is always a
117 -- variable, and we don't know the fixity yet.
118 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
120 mkHsSplice e = HsSplice unqualSplice e
122 unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
123 -- A name (uniquified later) to
124 -- identify the splice
126 mkHsString s = HsString (mkFastString s)
130 %************************************************************************
132 Constructing syntax with no location info
134 %************************************************************************
137 nlHsVar :: id -> LHsExpr id
138 nlHsVar n = noLoc (HsVar n)
140 nlHsLit :: HsLit -> LHsExpr id
141 nlHsLit n = noLoc (HsLit n)
143 nlVarPat :: id -> LPat id
144 nlVarPat n = noLoc (VarPat n)
146 nlLitPat :: HsLit -> LPat id
147 nlLitPat l = noLoc (LitPat l)
149 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
150 nlHsApp f x = noLoc (HsApp f x)
152 nlHsIntLit n = noLoc (HsLit (HsInt n))
154 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
155 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
157 nlHsVarApps :: id -> [id] -> LHsExpr id
158 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
160 mk f a = HsApp (noLoc f) (noLoc a)
162 nlConVarPat :: id -> [id] -> LPat id
163 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
165 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
166 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
168 nlConPat :: id -> [LPat id] -> LPat id
169 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
171 nlNullaryConPat :: id -> LPat id
172 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
174 nlWildConPat :: DataCon -> LPat RdrName
175 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
176 (PrefixCon (nOfThem (dataConSourceArity con) wildPat)))
178 nlTuplePat pats box = noLoc (TuplePat pats box)
179 wildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
181 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id
182 nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
184 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
186 nlHsLam match = noLoc (HsLam match)
187 nlHsPar e = noLoc (HsPar e)
188 nlHsIf cond true false = noLoc (HsIf cond true false)
189 nlHsCase expr matches = noLoc (HsCase expr matches)
190 nlTuple exprs box = noLoc (ExplicitTuple exprs box)
191 nlList exprs = noLoc (ExplicitList placeHolderType exprs)
193 nlHsAppTy f t = noLoc (HsAppTy f t)
194 nlHsTyVar x = noLoc (HsTyVar x)
195 nlHsFunTy a b = noLoc (HsFunTy a b)
197 nlExprStmt expr = noLoc (ExprStmt expr placeHolderType)
198 nlBindStmt pat expr = noLoc (BindStmt pat expr)
199 nlLetStmt binds = noLoc (LetStmt binds)
200 nlResultStmt expr = noLoc (ResultStmt expr)
201 nlParStmt stuff = noLoc (ParStmt stuff)
206 %************************************************************************
208 Bindings; with a location at the top
210 %************************************************************************
213 mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
214 mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyBag rhs
216 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
217 -> LHsBinds RdrName -> LHsExpr RdrName
220 mk_easy_FunBind loc fun pats binds expr
221 = L loc (FunBind (L loc fun) False{-not infix-}
222 [mk_easy_Match pats binds expr])
224 mk_easy_Match pats binds expr
225 = mkMatch pats expr [HsBindGroup binds [] Recursive]
226 -- The renamer expects everything in its input to be a
227 -- "recursive" MonoBinds, and it is its job to sort things out
230 mk_FunBind :: SrcSpan
232 -> [([LPat RdrName], LHsExpr RdrName)]
235 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
236 mk_FunBind loc fun pats_and_exprs
237 = L loc (FunBind (L loc fun) False{-not infix-}
238 [mkMatch p e [] | (p,e) <-pats_and_exprs])
240 mkMatch :: [LPat id] -> LHsExpr id -> [HsBindGroup id] -> LMatch id
241 mkMatch pats expr binds
242 = noLoc (Match (map paren pats) Nothing
243 (GRHSs (unguardedRHS expr) binds placeHolderType))
247 L l _ -> L l (ParPat p)
251 %************************************************************************
253 Collecting binders from HsBindGroups and HsBinds
255 %************************************************************************
257 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
265 it should return [x, y, f, a, b] (remember, order important).
268 collectGroupBinders :: [HsBindGroup name] -> [Located name]
269 collectGroupBinders groups = foldr collect_group [] groups
271 collect_group (HsBindGroup bag sigs is_rec) acc
272 = foldrBag (collectAcc . unLoc) acc bag
273 collect_group (HsIPBinds _) acc = acc
276 collectAcc :: HsBind name -> [Located name] -> [Located name]
277 collectAcc (PatBind pat _) acc = collectLocatedPatBinders pat ++ acc
278 collectAcc (FunBind f _ _) acc = f : acc
279 collectAcc (VarBind f _) acc = noLoc f : acc
280 collectAcc (AbsBinds _ _ dbinds _ binds) acc
281 = [noLoc dp | (_,dp,_) <- dbinds] ++ acc
282 -- ++ foldr collectAcc acc binds
283 -- I don't think we want the binders from the nested binds
284 -- The only time we collect binders from a typechecked
285 -- binding (hence see AbsBinds) is in zonking in TcHsSyn
287 collectHsBindBinders :: Bag (LHsBind name) -> [name]
288 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
290 collectHsBindLocatedBinders :: Bag (LHsBind name) -> [Located name]
291 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
295 %************************************************************************
297 Getting pattern signatures out of bindings
299 %************************************************************************
301 Get all the pattern type signatures out of a bunch of bindings
304 collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name]
305 collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds)
307 collectSigTysFromHsBind :: LHsBind name -> [LHsType name]
308 collectSigTysFromHsBind bind
311 go (PatBind pat _) = collectSigTysFromPat pat
312 go (FunBind f _ ms) = go_matches (map unLoc ms)
314 -- A binding like x :: a = f y
315 -- is parsed as FunMonoBind, but for this purpose we
316 -- want to treat it as a pattern binding
318 go_matches (Match [] (Just sig) _ : matches) = sig : go_matches matches
319 go_matches (match : matches) = go_matches matches
322 %************************************************************************
324 Getting binders from statements
326 %************************************************************************
329 collectStmtsBinders :: [LStmt id] -> [Located id]
330 collectStmtsBinders = concatMap collectLStmtBinders
332 collectLStmtBinders = collectStmtBinders . unLoc
334 collectStmtBinders :: Stmt id -> [Located id]
335 -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
336 collectStmtBinders (BindStmt pat _) = collectLocatedPatBinders pat
337 collectStmtBinders (LetStmt binds) = collectGroupBinders binds
338 collectStmtBinders (ExprStmt _ _) = []
339 collectStmtBinders (ResultStmt _) = []
340 collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss
341 collectStmtBinders other = panic "collectStmtBinders"