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)
56 mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
57 mkSimpleMatch pats rhs
59 Match pats Nothing (GRHSs (unguardedRHS rhs) [])
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 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
83 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
85 matches = mkMatchGroup [mkSimpleMatch pats body]
87 mkMatchGroup :: [LMatch id] -> MatchGroup id
88 mkMatchGroup matches = MatchGroup matches placeHolderType
90 mkHsTyLam [] expr = expr
91 mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
93 mkHsDictLam [] expr = expr
94 mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr)
96 mkHsLet :: LHsBinds name -> LHsExpr name -> LHsExpr name
98 | isEmptyLHsBinds binds = expr
99 | otherwise = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr)
101 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
102 -- Used for constructing dictinoary terms etc, so no locations
103 mkHsConApp data_con tys args
104 = foldl mk_app (noLoc (HsVar (dataConWrapId data_con)) `mkHsTyApp` tys) args
106 mk_app f a = noLoc (HsApp f (noLoc a))
108 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
109 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
110 mkSimpleHsAlt pat expr
111 = mkSimpleMatch [pat] expr
113 glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id
114 glueBindsOnGRHSs binds1 (GRHSs grhss binds2)
115 = GRHSs grhss (binds1 : binds2)
117 -------------------------------
118 -- These are the bits of syntax that contain rebindable names
119 -- See RnEnv.lookupSyntaxName
121 mkHsIntegral i = HsIntegral i noSyntaxExpr
122 mkHsFractional f = HsFractional f noSyntaxExpr
123 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
125 mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType
126 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
128 mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType
129 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
130 mkRecStmt stmts = RecStmt stmts [] [] [] emptyLHsBinds
132 -------------------------------
133 --- A useful function for building @OpApps@. The operator is always a
134 -- variable, and we don't know the fixity yet.
135 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
137 mkHsSplice e = HsSplice unqualSplice e
139 unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
140 -- A name (uniquified later) to
141 -- identify the splice
143 mkHsString s = HsString (mkFastString s)
147 %************************************************************************
149 Constructing syntax with no location info
151 %************************************************************************
154 nlHsVar :: id -> LHsExpr id
155 nlHsVar n = noLoc (HsVar n)
157 nlHsLit :: HsLit -> LHsExpr id
158 nlHsLit n = noLoc (HsLit n)
160 nlVarPat :: id -> LPat id
161 nlVarPat n = noLoc (VarPat n)
163 nlLitPat :: HsLit -> LPat id
164 nlLitPat l = noLoc (LitPat l)
166 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
167 nlHsApp f x = noLoc (HsApp f x)
169 nlHsIntLit n = noLoc (HsLit (HsInt n))
171 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
172 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
174 nlHsVarApps :: id -> [id] -> LHsExpr id
175 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
177 mk f a = HsApp (noLoc f) (noLoc a)
179 nlConVarPat :: id -> [id] -> LPat id
180 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
182 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
183 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
185 nlConPat :: id -> [LPat id] -> LPat id
186 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
188 nlNullaryConPat :: id -> LPat id
189 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
191 nlWildConPat :: DataCon -> LPat RdrName
192 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
193 (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
195 nlTuplePat pats box = noLoc (TuplePat pats box)
196 nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
198 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
199 nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
201 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
203 nlHsLam match = noLoc (HsLam (mkMatchGroup [match]))
204 nlHsPar e = noLoc (HsPar e)
205 nlHsIf cond true false = noLoc (HsIf cond true false)
206 nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches))
207 nlTuple exprs box = noLoc (ExplicitTuple exprs box)
208 nlList exprs = noLoc (ExplicitList placeHolderType exprs)
210 nlHsAppTy f t = noLoc (HsAppTy f t)
211 nlHsTyVar x = noLoc (HsTyVar x)
212 nlHsFunTy a b = noLoc (HsFunTy a b)
217 %************************************************************************
219 Bindings; with a location at the top
221 %************************************************************************
224 mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
225 mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyLHsBinds rhs
227 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
228 -> LHsBinds RdrName -> LHsExpr RdrName
231 mk_easy_FunBind loc fun pats binds expr
232 = L loc (FunBind (L loc fun) False{-not infix-}
233 (mkMatchGroup [mk_easy_Match pats binds expr]))
235 mk_easy_Match pats binds expr
236 = mkMatch pats expr [HsBindGroup binds [] Recursive]
237 -- The renamer expects everything in its input to be a
238 -- "recursive" MonoBinds, and it is its job to sort things out
241 mk_FunBind :: SrcSpan
243 -> [([LPat RdrName], LHsExpr RdrName)]
246 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
247 mk_FunBind loc fun pats_and_exprs
248 = L loc (FunBind (L loc fun) False{-not infix-}
249 (mkMatchGroup [mkMatch p e [] | (p,e) <-pats_and_exprs]))
251 mkMatch :: [LPat id] -> LHsExpr id -> [HsBindGroup id] -> LMatch id
252 mkMatch pats expr binds
253 = noLoc (Match (map paren pats) Nothing
255 (GRHSs (unguardedRHS expr) binds))
259 L l _ -> L l (ParPat p)
263 %************************************************************************
265 Collecting binders from HsBindGroups and HsBinds
267 %************************************************************************
269 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
277 it should return [x, y, f, a, b] (remember, order important).
280 collectGroupBinders :: [HsBindGroup name] -> [Located name]
281 collectGroupBinders groups = foldr collect_group [] groups
283 collect_group (HsBindGroup bag sigs is_rec) acc
284 = foldrBag (collectAcc . unLoc) acc bag
285 collect_group (HsIPBinds _) acc = acc
288 collectAcc :: HsBind name -> [Located name] -> [Located name]
289 collectAcc (PatBind pat _ _) acc = collectLocatedPatBinders pat ++ acc
290 collectAcc (FunBind f _ _) acc = f : acc
291 collectAcc (VarBind f _) acc = noLoc f : acc
292 collectAcc (AbsBinds _ _ dbinds _ binds) acc
293 = [noLoc dp | (_,dp,_) <- dbinds] ++ acc
294 -- ++ foldr collectAcc acc binds
295 -- I don't think we want the binders from the nested binds
296 -- The only time we collect binders from a typechecked
297 -- binding (hence see AbsBinds) is in zonking in TcHsSyn
299 collectHsBindBinders :: Bag (LHsBind name) -> [name]
300 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
302 collectHsBindLocatedBinders :: Bag (LHsBind name) -> [Located name]
303 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
307 %************************************************************************
309 Getting pattern signatures out of bindings
311 %************************************************************************
313 Get all the pattern type signatures out of a bunch of bindings
316 collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name]
317 collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds)
319 collectSigTysFromHsBind :: LHsBind name -> [LHsType name]
320 collectSigTysFromHsBind bind
324 = collectSigTysFromPat pat
325 go (FunBind f _ (MatchGroup ms _))
326 = [sig | L _ (Match [] (Just sig) _) <- ms]
327 -- A binding like x :: a = f y
328 -- is parsed as FunMonoBind, but for this purpose we
329 -- want to treat it as a pattern binding
332 %************************************************************************
334 Getting binders from statements
336 %************************************************************************
339 collectLStmtsBinders :: [LStmt id] -> [Located id]
340 collectLStmtsBinders = concatMap collectLStmtBinders
342 collectStmtsBinders :: [Stmt id] -> [Located id]
343 collectStmtsBinders = concatMap collectStmtBinders
345 collectLStmtBinders :: LStmt id -> [Located id]
346 collectLStmtBinders = collectStmtBinders . unLoc
348 collectStmtBinders :: Stmt id -> [Located id]
349 -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
350 collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
351 collectStmtBinders (LetStmt binds) = collectGroupBinders binds
352 collectStmtBinders (ExprStmt _ _ _) = []
353 collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
354 collectStmtBinders other = panic "collectStmtBinders"
358 %************************************************************************
360 %* Gathering stuff out of patterns
362 %************************************************************************
364 This function @collectPatBinders@ works with the ``collectBinders''
365 functions for @HsBinds@, etc. The order in which the binders are
366 collected is important; see @HsBinds.lhs@.
368 It collects the bounds *value* variables in renamed patterns; type variables
372 collectPatBinders :: LPat a -> [a]
373 collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
375 collectLocatedPatBinders :: LPat a -> [Located a]
376 collectLocatedPatBinders pat = collectl pat []
378 collectPatsBinders :: [LPat a] -> [a]
379 collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
381 collectLocatedPatsBinders :: [LPat a] -> [Located a]
382 collectLocatedPatsBinders pats = foldr collectl [] pats
384 ---------------------
385 collectl (L l pat) bndrs
388 go (VarPat var) = L l var : bndrs
389 go (VarPatOut var bs) = L l var : collectHsBindLocatedBinders bs
391 go (WildPat _) = bndrs
392 go (LazyPat pat) = collectl pat bndrs
393 go (AsPat a pat) = a : collectl pat bndrs
394 go (ParPat pat) = collectl pat bndrs
396 go (ListPat pats _) = foldr collectl bndrs pats
397 go (PArrPat pats _) = foldr collectl bndrs pats
398 go (TuplePat pats _) = foldr collectl bndrs pats
400 go (ConPatIn c ps) = foldr collectl bndrs (hsConArgs ps)
401 go (ConPatOut c _ ds bs ps _) = map noLoc ds
402 ++ collectHsBindLocatedBinders bs
403 ++ foldr collectl bndrs (hsConArgs ps)
404 go (LitPat _) = bndrs
405 go (NPat _ _ _ _) = bndrs
406 go (NPlusKPat n _ _ _) = n : bndrs
408 go (SigPatIn pat _) = collectl pat bndrs
409 go (SigPatOut pat _) = collectl pat bndrs
410 go (TypePat ty) = bndrs
411 go (DictPat ids1 ids2) = map noLoc ids1 ++ map noLoc ids2
416 collectSigTysFromPats :: [InPat name] -> [LHsType name]
417 collectSigTysFromPats pats = foldr collect_lpat [] pats
419 collectSigTysFromPat :: InPat name -> [LHsType name]
420 collectSigTysFromPat pat = collect_lpat pat []
422 collect_lpat pat acc = collect_pat (unLoc pat) acc
424 collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc)
425 collect_pat (TypePat ty) acc = ty:acc
427 collect_pat (LazyPat pat) acc = collect_lpat pat acc
428 collect_pat (AsPat a pat) acc = collect_lpat pat acc
429 collect_pat (ParPat pat) acc = collect_lpat pat acc
430 collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats
431 collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats
432 collect_pat (TuplePat pats _) acc = foldr collect_lpat acc pats
433 collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps)
434 collect_pat other acc = acc -- Literals, vars, wildcard