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 OccName ( mkVarOccFS )
32 import BasicTypes ( RecFlag(..) )
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)
56 mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
57 mkSimpleMatch pats rhs
59 Match pats Nothing (GRHSs (unguardedRHS rhs) emptyLocalBinds)
63 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
65 unguardedRHS :: LHsExpr id -> [LGRHS id]
66 unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
68 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
69 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
71 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
72 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
74 mkHsTyApp :: LHsExpr name -> [Type] -> LHsExpr name
75 mkHsTyApp expr [] = expr
76 mkHsTyApp expr tys = L (getLoc expr) (TyApp expr tys)
78 mkHsDictApp :: LHsExpr name -> [name] -> LHsExpr name
79 mkHsDictApp expr [] = expr
80 mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
82 mkHsCoerce :: ExprCoFn -> HsExpr id -> HsExpr id
83 mkHsCoerce co_fn e | isIdCoercion co_fn = e
84 | otherwise = HsCoerce co_fn e
86 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
87 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
89 matches = mkMatchGroup [mkSimpleMatch pats body]
91 mkMatchGroup :: [LMatch id] -> MatchGroup id
92 mkMatchGroup matches = MatchGroup matches placeHolderType
94 mkHsTyLam [] expr = expr
95 mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
97 mkHsDictLam [] expr = expr
98 mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr)
100 mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id
101 -- Used for the dictionary bindings gotten from TcSimplify
102 -- We make them recursive to be on the safe side
103 mkHsDictLet binds expr
104 | isEmptyLHsBinds binds = expr
105 | otherwise = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
107 val_binds = ValBindsOut [(Recursive, binds)] []
109 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
110 -- Used for constructing dictinoary terms etc, so no locations
111 mkHsConApp data_con tys args
112 = foldl mk_app (noLoc (HsVar (dataConWrapId data_con)) `mkHsTyApp` tys) args
114 mk_app f a = noLoc (HsApp f (noLoc a))
116 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
117 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
118 mkSimpleHsAlt pat expr
119 = mkSimpleMatch [pat] expr
121 -------------------------------
122 -- These are the bits of syntax that contain rebindable names
123 -- See RnEnv.lookupSyntaxName
125 mkHsIntegral i = HsIntegral i noSyntaxExpr
126 mkHsFractional f = HsFractional f noSyntaxExpr
127 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
129 mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType
130 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
132 mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType
133 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
134 mkRecStmt stmts = RecStmt stmts [] [] [] emptyLHsBinds
136 -------------------------------
137 --- A useful function for building @OpApps@. The operator is always a
138 -- variable, and we don't know the fixity yet.
139 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
141 mkHsSplice e = HsSplice unqualSplice e
143 unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice"))
144 -- A name (uniquified later) to
145 -- identify the splice
147 mkHsString s = HsString (mkFastString s)
150 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
151 userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
155 %************************************************************************
157 Constructing syntax with no location info
159 %************************************************************************
162 nlHsVar :: id -> LHsExpr id
163 nlHsVar n = noLoc (HsVar n)
165 nlHsLit :: HsLit -> LHsExpr id
166 nlHsLit n = noLoc (HsLit n)
168 nlVarPat :: id -> LPat id
169 nlVarPat n = noLoc (VarPat n)
171 nlLitPat :: HsLit -> LPat id
172 nlLitPat l = noLoc (LitPat l)
174 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
175 nlHsApp f x = noLoc (HsApp f x)
177 nlHsIntLit n = noLoc (HsLit (HsInt n))
179 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
180 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
182 nlHsVarApps :: id -> [id] -> LHsExpr id
183 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
185 mk f a = HsApp (noLoc f) (noLoc a)
187 nlConVarPat :: id -> [id] -> LPat id
188 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
190 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
191 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
193 nlConPat :: id -> [LPat id] -> LPat id
194 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
196 nlNullaryConPat :: id -> LPat id
197 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
199 nlWildConPat :: DataCon -> LPat RdrName
200 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
201 (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
203 nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
204 nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
206 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
207 nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
209 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
211 nlHsLam match = noLoc (HsLam (mkMatchGroup [match]))
212 nlHsPar e = noLoc (HsPar e)
213 nlHsIf cond true false = noLoc (HsIf cond true false)
214 nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches))
215 nlTuple exprs box = noLoc (ExplicitTuple exprs box)
216 nlList exprs = noLoc (ExplicitList placeHolderType exprs)
218 nlHsAppTy f t = noLoc (HsAppTy f t)
219 nlHsTyVar x = noLoc (HsTyVar x)
220 nlHsFunTy a b = noLoc (HsFunTy a b)
225 %************************************************************************
227 Bindings; with a location at the top
229 %************************************************************************
232 mkFunBind :: Located id -> [LMatch id] -> HsBind id
233 -- Not infix, with place holders for coercion and free vars
234 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
235 fun_co_fn = idCoercion, bind_fvs = placeHolderNames }
238 mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
239 mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
242 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
243 -> LHsExpr RdrName -> LHsBind RdrName
245 mk_easy_FunBind loc fun pats expr
246 = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
249 mk_FunBind :: SrcSpan -> RdrName
250 -> [([LPat RdrName], LHsExpr RdrName)]
253 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
254 mk_FunBind loc fun pats_and_exprs
255 = L loc $ mkFunBind (L loc fun) matches
257 matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
260 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
261 mkMatch pats expr binds
262 = noLoc (Match (map paren pats) Nothing
263 (GRHSs (unguardedRHS expr) binds))
267 L l _ -> L l (ParPat p)
271 %************************************************************************
273 Collecting binders from HsBindGroups and HsBinds
275 %************************************************************************
277 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
285 it should return [x, y, f, a, b] (remember, order important).
288 collectLocalBinders :: HsLocalBinds name -> [Located name]
289 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
290 collectLocalBinders (HsIPBinds _) = []
291 collectLocalBinders EmptyLocalBinds = []
293 collectHsValBinders :: HsValBinds name -> [Located name]
294 collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds
295 collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds
297 collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
299 collectAcc :: HsBind name -> [Located name] -> [Located name]
300 collectAcc (PatBind { pat_lhs = p }) acc = collectLocatedPatBinders p ++ acc
301 collectAcc (FunBind { fun_id = f }) acc = f : acc
302 collectAcc (VarBind { var_id = f }) acc = noLoc f : acc
303 collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = binds }) acc
304 = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc
305 -- ++ foldr collectAcc acc binds
306 -- I don't think we want the binders from the nested binds
307 -- The only time we collect binders from a typechecked
308 -- binding (hence see AbsBinds) is in zonking in TcHsSyn
310 collectHsBindBinders :: LHsBinds name -> [name]
311 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
313 collectHsBindLocatedBinders :: LHsBinds name -> [Located name]
314 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
318 %************************************************************************
320 Getting binders from statements
322 %************************************************************************
325 collectLStmtsBinders :: [LStmt id] -> [Located id]
326 collectLStmtsBinders = concatMap collectLStmtBinders
328 collectStmtsBinders :: [Stmt id] -> [Located id]
329 collectStmtsBinders = concatMap collectStmtBinders
331 collectLStmtBinders :: LStmt id -> [Located id]
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) = collectLocalBinders binds
338 collectStmtBinders (ExprStmt _ _ _) = []
339 collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
340 collectStmtBinders other = panic "collectStmtBinders"
344 %************************************************************************
346 %* Gathering stuff out of patterns
348 %************************************************************************
350 This function @collectPatBinders@ works with the ``collectBinders''
351 functions for @HsBinds@, etc. The order in which the binders are
352 collected is important; see @HsBinds.lhs@.
354 It collects the bounds *value* variables in renamed patterns; type variables
358 collectPatBinders :: LPat a -> [a]
359 collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
361 collectLocatedPatBinders :: LPat a -> [Located a]
362 collectLocatedPatBinders pat = collectl pat []
364 collectPatsBinders :: [LPat a] -> [a]
365 collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
367 collectLocatedPatsBinders :: [LPat a] -> [Located a]
368 collectLocatedPatsBinders pats = foldr collectl [] pats
370 ---------------------
371 collectl (L l pat) bndrs
374 go (VarPat var) = L l var : bndrs
375 go (VarPatOut var bs) = L l var : collectHsBindLocatedBinders bs
377 go (WildPat _) = bndrs
378 go (LazyPat pat) = collectl pat bndrs
379 go (BangPat pat) = collectl pat bndrs
380 go (AsPat a pat) = a : collectl pat bndrs
381 go (ParPat pat) = collectl pat bndrs
383 go (ListPat pats _) = foldr collectl bndrs pats
384 go (PArrPat pats _) = foldr collectl bndrs pats
385 go (TuplePat pats _ _) = foldr collectl bndrs pats
387 go (ConPatIn c ps) = foldr collectl bndrs (hsConArgs ps)
388 go (ConPatOut c _ ds bs ps _) = map noLoc ds
389 ++ collectHsBindLocatedBinders bs
390 ++ foldr collectl bndrs (hsConArgs ps)
391 go (LitPat _) = bndrs
392 go (NPat _ _ _ _) = bndrs
393 go (NPlusKPat n _ _ _) = n : bndrs
395 go (SigPatIn pat _) = collectl pat bndrs
396 go (SigPatOut pat _) = collectl pat bndrs
397 go (TypePat ty) = bndrs
398 go (DictPat ids1 ids2) = map noLoc ids1 ++ map noLoc ids2
403 collectSigTysFromPats :: [InPat name] -> [LHsType name]
404 collectSigTysFromPats pats = foldr collect_lpat [] pats
406 collectSigTysFromPat :: InPat name -> [LHsType name]
407 collectSigTysFromPat pat = collect_lpat pat []
409 collect_lpat pat acc = collect_pat (unLoc pat) acc
411 collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc)
412 collect_pat (TypePat ty) acc = ty:acc
414 collect_pat (LazyPat pat) acc = collect_lpat pat acc
415 collect_pat (BangPat pat) acc = collect_lpat pat acc
416 collect_pat (AsPat a pat) acc = collect_lpat pat acc
417 collect_pat (ParPat pat) acc = collect_lpat pat acc
418 collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats
419 collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats
420 collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats
421 collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps)
422 collect_pat other acc = acc -- Literals, vars, wildcard