2 % (c) The University of Glasgow, 1992-2006
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
16 {-# OPTIONS_GHC -w #-}
17 -- The above warning supression flag is a temporary kludge.
18 -- While working on this module you are encouraged to remove it and fix
19 -- any warnings in the module. See
20 -- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
25 #include "HsVersions.h"
47 %************************************************************************
49 Some useful helpers for constructing syntax
51 %************************************************************************
53 These functions attempt to construct a not-completely-useless SrcSpan
54 from their components, compared with the nl* functions below which
55 just attach noSrcSpan to everything.
58 mkHsPar :: LHsExpr id -> LHsExpr id
59 mkHsPar e = L (getLoc e) (HsPar e)
61 mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
62 mkSimpleMatch pats rhs
64 Match pats Nothing (unguardedGRHSs rhs)
68 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
70 unguardedGRHSs :: LHsExpr id -> GRHSs id
71 unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds
73 unguardedRHS :: LHsExpr id -> [LGRHS id]
74 unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
76 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
77 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
79 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
80 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
82 nlHsTyApp :: name -> [Type] -> LHsExpr name
83 nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id))
85 mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
86 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
88 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
89 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
90 | otherwise = HsWrap co_fn e
92 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
93 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
95 matches = mkMatchGroup [mkSimpleMatch pats body]
97 mkMatchGroup :: [LMatch id] -> MatchGroup id
98 mkMatchGroup matches = MatchGroup matches placeHolderType
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 dictionary terms etc, so no locations
111 mkHsConApp data_con tys args
112 = foldl mk_app (nlHsTyApp (dataConWrapId data_con) 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 mkHsIsString s = HsIsString s noSyntaxExpr
128 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
130 mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType
131 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
133 mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType
134 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
135 mkRecStmt stmts = RecStmt stmts [] [] [] emptyLHsBinds
137 -------------------------------
138 --- A useful function for building @OpApps@. The operator is always a
139 -- variable, and we don't know the fixity yet.
140 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
142 mkHsSplice e = HsSplice unqualSplice e
144 unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice"))
145 -- A name (uniquified later) to
146 -- identify the splice
148 mkHsString s = HsString (mkFastString s)
151 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
152 userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
156 %************************************************************************
158 Constructing syntax with no location info
160 %************************************************************************
163 nlHsVar :: id -> LHsExpr id
164 nlHsVar n = noLoc (HsVar n)
166 nlHsLit :: HsLit -> LHsExpr id
167 nlHsLit n = noLoc (HsLit n)
169 nlVarPat :: id -> LPat id
170 nlVarPat n = noLoc (VarPat n)
172 nlLitPat :: HsLit -> LPat id
173 nlLitPat l = noLoc (LitPat l)
175 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
176 nlHsApp f x = noLoc (HsApp f x)
178 nlHsIntLit n = noLoc (HsLit (HsInt n))
180 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
181 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
183 nlHsVarApps :: id -> [id] -> LHsExpr id
184 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
186 mk f a = HsApp (noLoc f) (noLoc a)
188 nlConVarPat :: id -> [id] -> LPat id
189 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
191 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
192 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
194 nlConPat :: id -> [LPat id] -> LPat id
195 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
197 nlNullaryConPat :: id -> LPat id
198 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
200 nlWildConPat :: DataCon -> LPat RdrName
201 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
202 (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
204 nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
205 nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
207 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
208 nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
210 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
212 nlHsLam match = noLoc (HsLam (mkMatchGroup [match]))
213 nlHsPar e = noLoc (HsPar e)
214 nlHsIf cond true false = noLoc (HsIf cond true false)
215 nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches))
216 nlTuple exprs box = noLoc (ExplicitTuple exprs box)
217 nlList exprs = noLoc (ExplicitList placeHolderType exprs)
219 nlHsAppTy f t = noLoc (HsAppTy f t)
220 nlHsTyVar x = noLoc (HsTyVar x)
221 nlHsFunTy a b = noLoc (HsFunTy a b)
223 nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys
228 %************************************************************************
230 Bindings; with a location at the top
232 %************************************************************************
235 mkFunBind :: Located id -> [LMatch id] -> HsBind id
236 -- Not infix, with place holders for coercion and free vars
237 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
238 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames,
242 mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
243 mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
246 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
247 -> LHsExpr RdrName -> LHsBind RdrName
249 mk_easy_FunBind loc fun pats expr
250 = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
253 mk_FunBind :: SrcSpan -> RdrName
254 -> [([LPat RdrName], LHsExpr RdrName)]
257 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
258 mk_FunBind loc fun pats_and_exprs
259 = L loc $ mkFunBind (L loc fun) matches
261 matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
264 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
265 mkMatch pats expr binds
266 = noLoc (Match (map paren pats) Nothing
267 (GRHSs (unguardedRHS expr) binds))
271 L l _ -> L l (ParPat p)
275 %************************************************************************
277 Collecting binders from HsBindGroups and HsBinds
279 %************************************************************************
281 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
289 it should return [x, y, f, a, b] (remember, order important).
292 collectLocalBinders :: HsLocalBinds name -> [Located name]
293 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
294 collectLocalBinders (HsIPBinds _) = []
295 collectLocalBinders EmptyLocalBinds = []
297 collectHsValBinders :: HsValBinds name -> [Located name]
298 collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds
299 collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds
301 collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
303 collectAcc :: HsBind name -> [Located name] -> [Located name]
304 collectAcc (PatBind { pat_lhs = p }) acc = collectLocatedPatBinders p ++ acc
305 collectAcc (FunBind { fun_id = f }) acc = f : acc
306 collectAcc (VarBind { var_id = f }) acc = noLoc f : acc
307 collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = binds }) acc
308 = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc
309 -- ++ foldr collectAcc acc binds
310 -- I don't think we want the binders from the nested binds
311 -- The only time we collect binders from a typechecked
312 -- binding (hence see AbsBinds) is in zonking in TcHsSyn
314 collectHsBindBinders :: LHsBinds name -> [name]
315 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
317 collectHsBindLocatedBinders :: LHsBinds name -> [Located name]
318 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
322 %************************************************************************
324 Getting binders from statements
326 %************************************************************************
329 collectLStmtsBinders :: OutputableBndr id => [LStmt id] -> [Located id]
330 collectLStmtsBinders = concatMap collectLStmtBinders
332 collectStmtsBinders :: OutputableBndr id => [Stmt id] -> [Located id]
333 collectStmtsBinders = concatMap collectStmtBinders
335 collectLStmtBinders :: OutputableBndr id => LStmt id -> [Located id]
336 collectLStmtBinders = collectStmtBinders . unLoc
338 collectStmtBinders :: OutputableBndr id => Stmt id -> [Located id]
339 -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
340 collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
341 collectStmtBinders (LetStmt binds) = collectLocalBinders binds
342 collectStmtBinders (ExprStmt _ _ _) = []
343 collectStmtBinders (ParStmt xs) = collectLStmtsBinders
345 collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
346 collectStmtBinders s = pprPanic "collectStmtBinders" (ppr s)
350 %************************************************************************
352 %* Gathering stuff out of patterns
354 %************************************************************************
356 This function @collectPatBinders@ works with the ``collectBinders''
357 functions for @HsBinds@, etc. The order in which the binders are
358 collected is important; see @HsBinds.lhs@.
360 It collects the bounds *value* variables in renamed patterns; type variables
364 collectPatBinders :: LPat a -> [a]
365 collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
367 collectLocatedPatBinders :: LPat a -> [Located a]
368 collectLocatedPatBinders pat = collectl pat []
370 collectPatsBinders :: [LPat a] -> [a]
371 collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
373 collectLocatedPatsBinders :: [LPat a] -> [Located a]
374 collectLocatedPatsBinders pats = foldr collectl [] pats
376 ---------------------
377 collectl (L l pat) bndrs
380 go (VarPat var) = L l var : bndrs
381 go (VarPatOut var bs) = L l var : collectHsBindLocatedBinders bs
383 go (WildPat _) = bndrs
384 go (LazyPat pat) = collectl pat bndrs
385 go (BangPat pat) = collectl pat bndrs
386 go (AsPat a pat) = a : collectl pat bndrs
387 go (ParPat pat) = collectl pat bndrs
389 go (ListPat pats _) = foldr collectl bndrs pats
390 go (PArrPat pats _) = foldr collectl bndrs pats
391 go (TuplePat pats _ _) = foldr collectl bndrs pats
393 go (ConPatIn c ps) = foldr collectl bndrs (hsConPatArgs ps)
394 go (ConPatOut {pat_args=ps}) = foldr collectl bndrs (hsConPatArgs ps)
395 -- See Note [Dictionary binders in ConPatOut]
396 go (LitPat _) = bndrs
397 go (NPat _ _ _ _) = bndrs
398 go (NPlusKPat n _ _ _) = n : bndrs
400 go (SigPatIn pat _) = collectl pat bndrs
401 go (SigPatOut pat _) = collectl pat bndrs
402 go (TypePat ty) = bndrs
403 go (CoPat _ pat ty) = collectl (noLoc pat) bndrs
406 Note [Dictionary binders in ConPatOut]
407 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
408 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
409 of a ConPatOut pattern. For most calls it doesn't matter, because
410 it's pre-typechecker and there are no ConPatOuts. But it does matter
411 more in the desugarer; for example, DsUtils.mkSelectorBinds uses
412 collectPatBinders. In a lazy pattern, for example f ~(C x y) = ...,
413 we want to generate bindings for x,y but not for dictionaries bound by
414 C. (The type checker ensures they would not be used.)
417 collectSigTysFromPats :: [InPat name] -> [LHsType name]
418 collectSigTysFromPats pats = foldr collect_lpat [] pats
420 collectSigTysFromPat :: InPat name -> [LHsType name]
421 collectSigTysFromPat pat = collect_lpat pat []
423 collect_lpat pat acc = collect_pat (unLoc pat) acc
425 collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc)
426 collect_pat (TypePat ty) acc = ty:acc
428 collect_pat (LazyPat pat) acc = collect_lpat pat acc
429 collect_pat (BangPat pat) acc = collect_lpat pat acc
430 collect_pat (AsPat a pat) acc = collect_lpat pat acc
431 collect_pat (ParPat pat) acc = collect_lpat pat acc
432 collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats
433 collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats
434 collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats
435 collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConPatArgs ps)
436 collect_pat other acc = acc -- Literals, vars, wildcard