Pattern synonym names need to be in scope before renaming bindings (#9889)
[ghc.git] / compiler / hsSyn / HsUtils.hs
1 {-
2 (c) The University of Glasgow, 1992-2006
3
4
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 instantiated versions are located elsewhere:
8
9 Parameterised by Module
10 ---------------- -------------
11 RdrName parser/RdrHsSyn
12 Name rename/RnHsSyn
13 Id typecheck/TcHsSyn
14 -}
15
16 {-# LANGUAGE CPP #-}
17 {-# LANGUAGE ScopedTypeVariables #-}
18 {-# LANGUAGE FlexibleContexts #-}
19
20 module HsUtils(
21 -- Terms
22 mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
23 mkSimpleMatch, unguardedGRHSs, unguardedRHS,
24 mkMatchGroup, mkMatchGroupName, mkMatch, mkHsLam, mkHsIf,
25 mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
26 coToHsWrapper, mkHsDictLet, mkHsLams,
27 mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
28 mkLHsPar, mkHsCmdCast,
29
30 nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
31 nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
32 mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
33 toHsType, toHsKind,
34
35 -- Bindings
36 mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind, mkPatSynBind,
37
38 -- Literals
39 mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString,
40
41 -- Patterns
42 mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat,
43 nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
44 nlWildPatName, nlWildPatId, nlTuplePat, mkParPat,
45
46 -- Types
47 mkHsAppTy, userHsTyVarBndrs,
48 nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
49
50 -- Stmts
51 mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkLastStmt,
52 emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,
53 emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,
54
55 -- Template Haskell
56 mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkHsSplice,
57 mkHsQuasiQuote, unqualQuasiQuote,
58
59 -- Flags
60 noRebindableInfo,
61
62 -- Collecting binders
63 collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
64 collectHsIdBinders,
65 collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
66 collectPatBinders, collectPatsBinders,
67 collectLStmtsBinders, collectStmtsBinders,
68 collectLStmtBinders, collectStmtBinders,
69
70 hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynBinders,
71 hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
72
73 -- Collecting implicit binders
74 lStmtsImplicits, hsValBindsImplicits, lPatImplicits
75 ) where
76
77 #include "HsVersions.h"
78
79 import HsDecls
80 import HsBinds
81 import HsExpr
82 import HsPat
83 import HsTypes
84 import HsLit
85 import PlaceHolder
86
87 import TcEvidence
88 import RdrName
89 import Var
90 import TypeRep
91 import TcType
92 import Kind
93 import DataCon
94 import Name
95 import NameSet
96 import BasicTypes
97 import SrcLoc
98 import FastString
99 import Util
100 import Bag
101 import Outputable
102
103 import Data.Either
104 import Data.Function
105 import Data.List
106
107 {-
108 ************************************************************************
109 * *
110 Some useful helpers for constructing syntax
111 * *
112 ************************************************************************
113
114 These functions attempt to construct a not-completely-useless SrcSpan
115 from their components, compared with the nl* functions below which
116 just attach noSrcSpan to everything.
117 -}
118
119 mkHsPar :: LHsExpr id -> LHsExpr id
120 mkHsPar e = L (getLoc e) (HsPar e)
121
122 mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id))
123 mkSimpleMatch pats rhs
124 = L loc $
125 Match pats Nothing (unguardedGRHSs rhs)
126 where
127 loc = case pats of
128 [] -> getLoc rhs
129 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
130
131 unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id))
132 unguardedGRHSs rhs@(L loc _) = GRHSs (unguardedRHS loc rhs) emptyLocalBinds
133
134 unguardedRHS :: SrcSpan -> Located (body id) -> [LGRHS id (Located (body id))]
135 unguardedRHS loc rhs = [L loc (GRHS [] rhs)]
136
137 mkMatchGroup :: Origin -> [LMatch RdrName (Located (body RdrName))]
138 -> MatchGroup RdrName (Located (body RdrName))
139 mkMatchGroup origin matches = MG { mg_alts = matches, mg_arg_tys = []
140 , mg_res_ty = placeHolderType
141 , mg_origin = origin }
142
143 mkMatchGroupName :: Origin -> [LMatch Name (Located (body Name))]
144 -> MatchGroup Name (Located (body Name))
145 mkMatchGroupName origin matches = MG { mg_alts = matches, mg_arg_tys = []
146 , mg_res_ty = placeHolderType
147 , mg_origin = origin }
148
149 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
150 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
151
152 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
153 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
154
155 mkHsLam :: [LPat RdrName] -> LHsExpr RdrName -> LHsExpr RdrName
156 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
157 where
158 matches = mkMatchGroup Generated [mkSimpleMatch pats body]
159
160 mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id
161 mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
162 <.> mkWpLams dicts) expr
163
164 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
165 -- Used for constructing dictionary terms etc, so no locations
166 mkHsConApp data_con tys args
167 = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
168 where
169 mk_app f a = noLoc (HsApp f (noLoc a))
170
171 mkSimpleHsAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id))
172 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
173 mkSimpleHsAlt pat expr
174 = mkSimpleMatch [pat] expr
175
176 nlHsTyApp :: name -> [Type] -> LHsExpr name
177 nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id))
178
179 nlHsTyApps :: name -> [Type] -> [LHsExpr name] -> LHsExpr name
180 nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs
181
182 --------- Adding parens ---------
183 mkLHsPar :: LHsExpr name -> LHsExpr name
184 -- Wrap in parens if hsExprNeedsParens says it needs them
185 -- So 'f x' becomes '(f x)', but '3' stays as '3'
186 mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le)
187 | otherwise = le
188
189 mkParPat :: LPat name -> LPat name
190 mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp)
191 | otherwise = lp
192
193
194 -------------------------------
195 -- These are the bits of syntax that contain rebindable names
196 -- See RnEnv.lookupSyntaxName
197
198 mkHsIntegral :: String -> Integer -> PostTc RdrName Type -> HsOverLit RdrName
199 mkHsFractional :: FractionalLit -> PostTc RdrName Type -> HsOverLit RdrName
200 mkHsIsString :: String -> FastString -> PostTc RdrName Type -> HsOverLit RdrName
201 mkHsDo :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName
202 mkHsComp :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName
203 -> HsExpr RdrName
204
205 mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
206 mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
207
208 mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
209 mkBodyStmt :: Located (bodyR RdrName)
210 -> StmtLR idL RdrName (Located (bodyR RdrName))
211 mkBindStmt :: LPat idL -> Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
212
213 emptyRecStmt :: StmtLR idL RdrName bodyR
214 emptyRecStmtName :: StmtLR Name Name bodyR
215 emptyRecStmtId :: StmtLR Id Id bodyR
216 mkRecStmt :: [LStmtLR idL RdrName bodyR] -> StmtLR idL RdrName bodyR
217
218
219 mkHsIntegral src i = OverLit (HsIntegral src i) noRebindableInfo noSyntaxExpr
220 mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noSyntaxExpr
221 mkHsIsString src s = OverLit (HsIsString src s) noRebindableInfo noSyntaxExpr
222
223 noRebindableInfo :: PlaceHolder
224 noRebindableInfo = PlaceHolder -- Just another placeholder;
225
226 mkHsDo ctxt stmts = HsDo ctxt stmts placeHolderType
227 mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
228 where
229 last_stmt = L (getLoc expr) $ mkLastStmt expr
230
231 mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id
232 mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
233
234 mkNPat lit neg = NPat lit neg noSyntaxExpr
235 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
236
237 mkTransformStmt :: [ExprLStmt idL] -> LHsExpr idR
238 -> StmtLR idL idR (LHsExpr idL)
239 mkTransformByStmt :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
240 -> StmtLR idL idR (LHsExpr idL)
241 mkGroupUsingStmt :: [ExprLStmt idL] -> LHsExpr idR
242 -> StmtLR idL idR (LHsExpr idL)
243 mkGroupByUsingStmt :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
244 -> StmtLR idL idR (LHsExpr idL)
245
246 emptyTransStmt :: StmtLR idL idR (LHsExpr idR)
247 emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form"
248 , trS_stmts = [], trS_bndrs = []
249 , trS_by = Nothing, trS_using = noLoc noSyntaxExpr
250 , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
251 , trS_fmap = noSyntaxExpr }
252 mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u }
253 mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
254 mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u }
255 mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
256
257 mkLastStmt body = LastStmt body noSyntaxExpr
258 mkBodyStmt body = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType
259 mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr
260
261
262 emptyRecStmt' :: forall idL idR body.
263 PostTc idR Type -> StmtLR idL idR body
264 emptyRecStmt' tyVal =
265 RecStmt
266 { recS_stmts = [], recS_later_ids = []
267 , recS_rec_ids = []
268 , recS_ret_fn = noSyntaxExpr
269 , recS_mfix_fn = noSyntaxExpr
270 , recS_bind_fn = noSyntaxExpr, recS_later_rets = []
271 , recS_rec_rets = [], recS_ret_ty = tyVal }
272
273 emptyRecStmt = emptyRecStmt' placeHolderType
274 emptyRecStmtName = emptyRecStmt' placeHolderType
275 emptyRecStmtId = emptyRecStmt' placeHolderTypeTc
276 mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
277
278 -------------------------------
279 --- A useful function for building @OpApps@. The operator is always a
280 -- variable, and we don't know the fixity yet.
281 mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
282 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
283
284 mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
285 mkHsSplice e = HsSplice unqualSplice e
286
287 unqualSplice :: RdrName
288 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
289
290 mkHsSpliceE :: LHsExpr RdrName -> HsExpr RdrName
291 mkHsSpliceE e = HsSpliceE False (mkHsSplice e)
292
293 mkHsSpliceTE :: LHsExpr RdrName -> HsExpr RdrName
294 mkHsSpliceTE e = HsSpliceE True (mkHsSplice e)
295
296 mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
297 mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) placeHolderKind
298
299 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName
300 mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote
301
302 unqualQuasiQuote :: RdrName
303 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
304 -- A name (uniquified later) to
305 -- identify the quasi-quote
306
307 mkHsString :: String -> HsLit
308 mkHsString s = HsString s (mkFastString s)
309
310 -------------
311 userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
312 -- Caller sets location
313 userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]
314
315 {-
316 ************************************************************************
317 * *
318 Constructing syntax with no location info
319 * *
320 ************************************************************************
321 -}
322
323 nlHsVar :: id -> LHsExpr id
324 nlHsVar n = noLoc (HsVar n)
325
326 nlHsLit :: HsLit -> LHsExpr id
327 nlHsLit n = noLoc (HsLit n)
328
329 nlVarPat :: id -> LPat id
330 nlVarPat n = noLoc (VarPat n)
331
332 nlLitPat :: HsLit -> LPat id
333 nlLitPat l = noLoc (LitPat l)
334
335 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
336 nlHsApp f x = noLoc (HsApp f x)
337
338 nlHsIntLit :: Integer -> LHsExpr id
339 nlHsIntLit n = noLoc (HsLit (HsInt (show n) n))
340
341 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
342 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
343
344 nlHsVarApps :: id -> [id] -> LHsExpr id
345 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
346 where
347 mk f a = HsApp (noLoc f) (noLoc a)
348
349 nlConVarPat :: RdrName -> [RdrName] -> LPat RdrName
350 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
351
352 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
353 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
354
355 nlConPat :: RdrName -> [LPat RdrName] -> LPat RdrName
356 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
357
358 nlConPatName :: Name -> [LPat Name] -> LPat Name
359 nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
360
361 nlNullaryConPat :: id -> LPat id
362 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
363
364 nlWildConPat :: DataCon -> LPat RdrName
365 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
366 (PrefixCon (nOfThem (dataConSourceArity con)
367 nlWildPat)))
368
369 nlWildPat :: LPat RdrName
370 nlWildPat = noLoc (WildPat placeHolderType ) -- Pre-typechecking
371
372 nlWildPatName :: LPat Name
373 nlWildPatName = noLoc (WildPat placeHolderType ) -- Pre-typechecking
374
375 nlWildPatId :: LPat Id
376 nlWildPatId = noLoc (WildPat placeHolderTypeTc ) -- Post-typechecking
377
378 nlHsDo :: HsStmtContext Name -> [LStmt RdrName (LHsExpr RdrName)]
379 -> LHsExpr RdrName
380 nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
381
382 nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
383 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
384
385 nlHsLam :: LMatch RdrName (LHsExpr RdrName) -> LHsExpr RdrName
386 nlHsPar :: LHsExpr id -> LHsExpr id
387 nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
388 nlHsCase :: LHsExpr RdrName -> [LMatch RdrName (LHsExpr RdrName)]
389 -> LHsExpr RdrName
390 nlList :: [LHsExpr RdrName] -> LHsExpr RdrName
391
392 nlHsLam match = noLoc (HsLam (mkMatchGroup Generated [match]))
393 nlHsPar e = noLoc (HsPar e)
394 nlHsIf cond true false = noLoc (mkHsIf cond true false)
395 nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches))
396 nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs)
397
398 nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
399 nlHsTyVar :: name -> LHsType name
400 nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
401
402 nlHsAppTy f t = noLoc (HsAppTy f t)
403 nlHsTyVar x = noLoc (HsTyVar x)
404 nlHsFunTy a b = noLoc (HsFunTy a b)
405
406 nlHsTyConApp :: name -> [LHsType name] -> LHsType name
407 nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys
408
409 {-
410 Tuples. All these functions are *pre-typechecker* because they lack
411 types on the tuple.
412 -}
413
414 mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
415 -- Makes a pre-typechecker boxed tuple, deals with 1 case
416 mkLHsTupleExpr [e] = e
417 mkLHsTupleExpr es = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed
418
419 mkLHsVarTuple :: [a] -> LHsExpr a
420 mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids)
421
422 nlTuplePat :: [LPat id] -> Boxity -> LPat id
423 nlTuplePat pats box = noLoc (TuplePat pats box [])
424
425 missingTupArg :: HsTupArg RdrName
426 missingTupArg = Missing placeHolderType
427
428 {-
429 ************************************************************************
430 * *
431 Converting a Type to an HsType RdrName
432 * *
433 ************************************************************************
434
435 This is needed to implement GeneralizedNewtypeDeriving.
436 -}
437
438 toHsType :: Type -> LHsType RdrName
439 toHsType ty
440 | [] <- tvs_only
441 , [] <- theta
442 = to_hs_type tau
443 | otherwise
444 = noLoc $
445 mkExplicitHsForAllTy (map mk_hs_tvb tvs_only)
446 (noLoc $ map toHsType theta)
447 (to_hs_type tau)
448
449 where
450 (tvs, theta, tau) = tcSplitSigmaTy ty
451 tvs_only = filter isTypeVar tvs
452
453 to_hs_type (TyVarTy tv) = nlHsTyVar (getRdrName tv)
454 to_hs_type (AppTy t1 t2) = nlHsAppTy (toHsType t1) (toHsType t2)
455 to_hs_type (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map toHsType args')
456 where
457 args' = filterOut isKind args
458 -- Source-language types have _implicit_ kind arguments,
459 -- so we must remove them here (Trac #8563)
460 to_hs_type (FunTy arg res) = ASSERT( not (isConstraintKind (typeKind arg)) )
461 nlHsFunTy (toHsType arg) (toHsType res)
462 to_hs_type t@(ForAllTy {}) = pprPanic "toHsType" (ppr t)
463 to_hs_type (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy n)
464 to_hs_type (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy s)
465
466 mk_hs_tvb tv = noLoc $ KindedTyVar (getRdrName tv) (toHsKind (tyVarKind tv))
467
468 toHsKind :: Kind -> LHsKind RdrName
469 toHsKind = toHsType
470
471 --------- HsWrappers: type args, dict args, casts ---------
472 mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
473 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
474
475 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
476 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
477 | otherwise = HsWrap co_fn e
478
479 mkHsWrapCo :: TcCoercion -- A Nominal coercion a ~N b
480 -> HsExpr id -> HsExpr id
481 mkHsWrapCo co e = mkHsWrap (coToHsWrapper co) e
482
483 mkHsWrapCoR :: TcCoercion -- A Representational coercion a ~R b
484 -> HsExpr id -> HsExpr id
485 mkHsWrapCoR co e = mkHsWrap (coToHsWrapperR co) e
486
487 mkLHsWrapCo :: TcCoercion -> LHsExpr id -> LHsExpr id
488 mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
489
490 mkHsCmdCast :: TcCoercion -> HsCmd id -> HsCmd id
491 mkHsCmdCast co cmd | isTcReflCo co = cmd
492 | otherwise = HsCmdCast co cmd
493
494 coToHsWrapper :: TcCoercion -> HsWrapper -- A Nominal coercion
495 coToHsWrapper co | isTcReflCo co = idHsWrapper
496 | otherwise = mkWpCast (mkTcSubCo co)
497
498 coToHsWrapperR :: TcCoercion -> HsWrapper -- A Representational coercion
499 coToHsWrapperR co | isTcReflCo co = idHsWrapper
500 | otherwise = mkWpCast co
501
502 mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
503 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
504 | otherwise = CoPat co_fn p ty
505
506 mkHsWrapPatCo :: TcCoercion -> Pat id -> Type -> Pat id
507 mkHsWrapPatCo co pat ty | isTcReflCo co = pat
508 | otherwise = CoPat (mkWpCast co) pat ty
509
510 mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
511 mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
512
513 {-
514 l
515 ************************************************************************
516 * *
517 Bindings; with a location at the top
518 * *
519 ************************************************************************
520 -}
521
522 mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
523 -> HsBind RdrName
524 -- Not infix, with place holders for coercion and free vars
525 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
526 , fun_matches = mkMatchGroup Generated ms
527 , fun_co_fn = idHsWrapper
528 , bind_fvs = placeHolderNames
529 , fun_tick = [] }
530
531 mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)]
532 -> HsBind Name
533 -- In Name-land, with empty bind_fvs
534 mkTopFunBind origin fn ms = FunBind { fun_id = fn, fun_infix = False
535 , fun_matches = mkMatchGroupName origin ms
536 , fun_co_fn = idHsWrapper
537 , bind_fvs = emptyNameSet -- NB: closed
538 -- binding
539 , fun_tick = [] }
540
541 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
542 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
543
544 mkVarBind :: id -> LHsExpr id -> LHsBind id
545 mkVarBind var rhs = L (getLoc rhs) $
546 VarBind { var_id = var, var_rhs = rhs, var_inline = False }
547
548 mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
549 -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName
550 mkPatSynBind name details lpat dir = PatSynBind psb
551 where
552 psb = PSB{ psb_id = name
553 , psb_args = details
554 , psb_def = lpat
555 , psb_dir = dir
556 , psb_fvs = placeHolderNames }
557
558 ------------
559 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
560 -> LHsExpr RdrName -> LHsBind RdrName
561 mk_easy_FunBind loc fun pats expr
562 = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
563
564 ------------
565 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id)
566 mkMatch pats expr binds
567 = noLoc (Match (map paren pats) Nothing
568 (GRHSs (unguardedRHS noSrcSpan expr) binds))
569 where
570 paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
571 | otherwise = lp
572
573 {-
574 ************************************************************************
575 * *
576 Collecting binders
577 * *
578 ************************************************************************
579
580 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
581
582 ...
583 where
584 (x, y) = ...
585 f i j = ...
586 [a, b] = ...
587
588 it should return [x, y, f, a, b] (remember, order important).
589
590 Note [Collect binders only after renaming]
591 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
592 These functions should only be used on HsSyn *after* the renamer,
593 to return a [Name] or [Id]. Before renaming the record punning
594 and wild-card mechanism makes it hard to know what is bound.
595 So these functions should not be applied to (HsSyn RdrName)
596 -}
597
598 ----------------- Bindings --------------------------
599 collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
600 collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
601 -- No pattern synonyms here
602 collectLocalBinders (HsIPBinds _) = []
603 collectLocalBinders EmptyLocalBinds = []
604
605 collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [idL]
606 -- Collect Id binders only, or Ids + pattern synonmys, respectively
607 collectHsIdBinders = collect_hs_val_binders True
608 collectHsValBinders = collect_hs_val_binders False
609
610 collectHsBindBinders :: HsBindLR idL idR -> [idL]
611 -- Collect both Ids and pattern-synonym binders
612 collectHsBindBinders b = collect_bind False b []
613
614 collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
615 collectHsBindsBinders binds = collect_binds False binds []
616
617 collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
618 -- Same as collectHsBindsBinders, but works over a list of bindings
619 collectHsBindListBinders = foldr (collect_bind False . unLoc) []
620
621 collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [idL]
622 collect_hs_val_binders ps (ValBindsIn binds _) = collect_binds ps binds []
623 collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds
624
625 collect_out_binds :: Bool -> [(RecFlag, LHsBinds id)] -> [id]
626 collect_out_binds ps = foldr (collect_binds ps . snd) []
627
628 collect_binds :: Bool -> LHsBindsLR idL idR -> [idL] -> [idL]
629 -- Collect Ids, or Ids + patter synonyms, depending on boolean flag
630 collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds
631
632 collect_bind :: Bool -> HsBindLR idL idR -> [idL] -> [idL]
633 collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc
634 collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc
635 collect_bind _ (VarBind { var_id = f }) acc = f : acc
636 collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
637 -- I don't think we want the binders from the abe_binds
638 -- The only time we collect binders from a typechecked
639 -- binding (hence see AbsBinds) is in zonking in TcHsSyn
640 collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc =
641 if omitPatSyn then acc else ps : acc
642
643 collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
644 -- Used exclusively for the bindings of an instance decl which are all FunBinds
645 collectMethodBinders binds = foldrBag (get . unLoc) [] binds
646 where
647 get (FunBind { fun_id = f }) fs = f : fs
648 get _ fs = fs
649 -- Someone else complains about non-FunBinds
650
651 ----------------- Statements --------------------------
652 collectLStmtsBinders :: [LStmtLR idL idR body] -> [idL]
653 collectLStmtsBinders = concatMap collectLStmtBinders
654
655 collectStmtsBinders :: [StmtLR idL idR body] -> [idL]
656 collectStmtsBinders = concatMap collectStmtBinders
657
658 collectLStmtBinders :: LStmtLR idL idR body -> [idL]
659 collectLStmtBinders = collectStmtBinders . unLoc
660
661 collectStmtBinders :: StmtLR idL idR body -> [idL]
662 -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
663 collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
664 collectStmtBinders (LetStmt binds) = collectLocalBinders binds
665 collectStmtBinders (BodyStmt {}) = []
666 collectStmtBinders (LastStmt {}) = []
667 collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders
668 $ [s | ParStmtBlock ss _ _ <- xs, s <- ss]
669 collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
670 collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
671
672
673 ----------------- Patterns --------------------------
674 collectPatBinders :: LPat a -> [a]
675 collectPatBinders pat = collect_lpat pat []
676
677 collectPatsBinders :: [LPat a] -> [a]
678 collectPatsBinders pats = foldr collect_lpat [] pats
679
680 -------------
681 collect_lpat :: LPat name -> [name] -> [name]
682 collect_lpat (L _ pat) bndrs
683 = go pat
684 where
685 go (VarPat var) = var : bndrs
686 go (WildPat _) = bndrs
687 go (LazyPat pat) = collect_lpat pat bndrs
688 go (BangPat pat) = collect_lpat pat bndrs
689 go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs
690 go (ViewPat _ pat _) = collect_lpat pat bndrs
691 go (ParPat pat) = collect_lpat pat bndrs
692
693 go (ListPat pats _ _) = foldr collect_lpat bndrs pats
694 go (PArrPat pats _) = foldr collect_lpat bndrs pats
695 go (TuplePat pats _ _) = foldr collect_lpat bndrs pats
696
697 go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps)
698 go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps)
699 -- See Note [Dictionary binders in ConPatOut]
700 go (LitPat _) = bndrs
701 go (NPat _ _ _) = bndrs
702 go (NPlusKPat (L _ n) _ _ _) = n : bndrs
703
704 go (SigPatIn pat _) = collect_lpat pat bndrs
705 go (SigPatOut pat _) = collect_lpat pat bndrs
706 go (SplicePat _) = bndrs
707 go (QuasiQuotePat _) = bndrs
708 go (CoPat _ pat _) = go pat
709
710 {-
711 Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
712 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
713 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
714 of a ConPatOut pattern. For most calls it doesn't matter, because
715 it's pre-typechecker and there are no ConPatOuts. But it does matter
716 more in the desugarer; for example, DsUtils.mkSelectorBinds uses
717 collectPatBinders. In a lazy pattern, for example f ~(C x y) = ...,
718 we want to generate bindings for x,y but not for dictionaries bound by
719 C. (The type checker ensures they would not be used.)
720
721 Desugaring of arrow case expressions needs these bindings (see DsArrows
722 and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
723 own pat-binder-collector:
724
725 Here's the problem. Consider
726
727 data T a where
728 C :: Num a => a -> Int -> T a
729
730 f ~(C (n+1) m) = (n,m)
731
732 Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
733 and *also* uses that dictionary to match the (n+1) pattern. Yet, the
734 variables bound by the lazy pattern are n,m, *not* the dictionary d.
735 So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
736 -}
737
738 hsGroupBinders :: HsGroup Name -> [Name]
739 hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
740 hs_instds = inst_decls, hs_fords = foreign_decls })
741 = collectHsValBinders val_decls
742 ++ hsTyClForeignBinders tycl_decls inst_decls foreign_decls
743
744 hsTyClForeignBinders :: [TyClGroup Name] -> [LInstDecl Name]
745 -> [LForeignDecl Name] -> [Name]
746 -- We need to look at instance declarations too,
747 -- because their associated types may bind data constructors
748 hsTyClForeignBinders tycl_decls inst_decls foreign_decls
749 = map unLoc $
750 hsForeignDeclsBinders foreign_decls ++
751 concatMap (concatMap hsLTyClDeclBinders . group_tyclds) tycl_decls ++
752 concatMap hsLInstDeclBinders inst_decls
753
754 -------------------
755 hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
756 -- ^ Returns all the /binding/ names of the decl.
757 -- The first one is guaranteed to be the name of the decl. For record fields
758 -- mentioned in multiple constructors, the SrcLoc will be from the first
759 -- occurrence. We use the equality to filter out duplicate field names.
760 --
761 -- Each returned (Located name) has a SrcSpan for the /whole/ declaration.
762 -- See Note [SrcSpan for binders]
763
764 hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
765 = [L loc name]
766 hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) = [L loc name]
767 hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name
768 , tcdSigs = sigs, tcdATs = ats }))
769 = L loc cls_name :
770 [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
771 [ L mem_loc mem_name | L mem_loc (TypeSig ns _ _) <- sigs, L _ mem_name <- ns ]
772 hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn }))
773 = L loc name : hsDataDefnBinders defn
774
775 -------------------
776 hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name]
777 -- See Note [SrcSpan for binders]
778 hsForeignDeclsBinders foreign_decls
779 = [ L decl_loc n
780 | L decl_loc (ForeignImport (L _ n) _ _ _) <- foreign_decls]
781
782 -------------------
783 hsPatSynBinders :: LHsBindsLR idL idR -> [Located idL]
784 -- Collect pattern-synonym binders only, not Ids
785 -- See Note [SrcSpan for binders]
786 hsPatSynBinders binds = foldrBag addPatSynBndr [] binds
787
788 addPatSynBndr :: LHsBindLR idL idR -> [Located idL] -> [Located idL]
789 -- See Note [SrcSpan for binders]
790 addPatSynBndr bind pss
791 | L bind_loc (PatSynBind (PSB { psb_id = L _ n })) <- bind
792 = L bind_loc n : pss
793 | otherwise
794 = pss
795
796 -------------------
797 hsLInstDeclBinders :: Eq name => LInstDecl name -> [Located name]
798 hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))
799 = concatMap (hsDataFamInstBinders . unLoc) dfis
800 hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
801 = hsDataFamInstBinders fi
802 hsLInstDeclBinders (L _ (TyFamInstD {})) = []
803
804 -------------------
805 -- the SrcLoc returned are for the whole declarations, not just the names
806 hsDataFamInstBinders :: Eq name => DataFamInstDecl name -> [Located name]
807 hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
808 = hsDataDefnBinders defn
809 -- There can't be repeated symbols because only data instances have binders
810
811 -------------------
812 -- the SrcLoc returned are for the whole declarations, not just the names
813 hsDataDefnBinders :: Eq name => HsDataDefn name -> [Located name]
814 hsDataDefnBinders (HsDataDefn { dd_cons = cons })
815 = hsConDeclsBinders cons
816 -- See Note [Binders in family instances]
817
818 -------------------
819 hsConDeclsBinders :: forall name. (Eq name) => [LConDecl name] -> [Located name]
820 -- See hsLTyClDeclBinders for what this does
821 -- The function is boringly complicated because of the records
822 -- And since we only have equality, we have to be a little careful
823 hsConDeclsBinders cons = go id cons
824 where go :: ([Located name] -> [Located name]) -> [LConDecl name] -> [Located name]
825 go _ [] = []
826 go remSeen (r:rs) =
827 -- don't re-mangle the location of field names, because we don't
828 -- have a record of the full location of the field declaration anyway
829 case r of
830 -- remove only the first occurrence of any seen field in order to
831 -- avoid circumventing detection of duplicate fields (#9156)
832 L loc (ConDecl { con_names = names, con_details = RecCon flds }) ->
833 (map (L loc . unLoc) names) ++ r' ++ go remSeen' rs
834 where r' = remSeen (concatMap (cd_fld_names . unLoc) flds)
835 remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc) v | v <- r']
836 L loc (ConDecl { con_names = names }) ->
837 (map (L loc . unLoc) names) ++ go remSeen rs
838
839 {-
840
841 Note [SrcSpan for binders]
842 ~~~~~~~~~~~~~~~~~~~~~~~~~~
843 When extracting the (Located RdrNme) for a binder, at least for the
844 main name (the TyCon of a type declaration etc), we want to give it
845 the @SrcSpan@ of the whole /declaration/, not just the name itself
846 (which is how it appears in the syntax tree). This SrcSpan (for the
847 entire declaration) is used as the SrcSpan for the Name that is
848 finally produced, and hence for error messages. (See Trac #8607.)
849
850 Note [Binders in family instances]
851 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
852 In a type or data family instance declaration, the type
853 constructor is an *occurrence* not a binding site
854 type instance T Int = Int -> Int -- No binders
855 data instance S Bool = S1 | S2 -- Binders are S1,S2
856
857
858 ************************************************************************
859 * *
860 Collecting binders the user did not write
861 * *
862 ************************************************************************
863
864 The job of this family of functions is to run through binding sites and find the set of all Names
865 that were defined "implicitly", without being explicitly written by the user.
866
867 The main purpose is to find names introduced by record wildcards so that we can avoid
868 warning the user when they don't use those names (#4404)
869 -}
870
871 lStmtsImplicits :: [LStmtLR Name idR (Located (body idR))] -> NameSet
872 lStmtsImplicits = hs_lstmts
873 where
874 hs_lstmts :: [LStmtLR Name idR (Located (body idR))] -> NameSet
875 hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet
876
877 hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat
878 hs_stmt (LetStmt binds) = hs_local_binds binds
879 hs_stmt (BodyStmt {}) = emptyNameSet
880 hs_stmt (LastStmt {}) = emptyNameSet
881 hs_stmt (ParStmt xs _ _) = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss]
882 hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
883 hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
884
885 hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds
886 hs_local_binds (HsIPBinds _) = emptyNameSet
887 hs_local_binds EmptyLocalBinds = emptyNameSet
888
889 hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet
890 hsValBindsImplicits (ValBindsOut binds _)
891 = foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds
892 hsValBindsImplicits (ValBindsIn binds _)
893 = lhsBindsImplicits binds
894
895 lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet
896 lhsBindsImplicits = foldBag unionNameSet (lhs_bind . unLoc) emptyNameSet
897 where
898 lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
899 lhs_bind _ = emptyNameSet
900
901 lPatImplicits :: LPat Name -> NameSet
902 lPatImplicits = hs_lpat
903 where
904 hs_lpat (L _ pat) = hs_pat pat
905
906 hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSet` rest) emptyNameSet
907
908 hs_pat (LazyPat pat) = hs_lpat pat
909 hs_pat (BangPat pat) = hs_lpat pat
910 hs_pat (AsPat _ pat) = hs_lpat pat
911 hs_pat (ViewPat _ pat _) = hs_lpat pat
912 hs_pat (ParPat pat) = hs_lpat pat
913 hs_pat (ListPat pats _ _) = hs_lpats pats
914 hs_pat (PArrPat pats _) = hs_lpats pats
915 hs_pat (TuplePat pats _ _) = hs_lpats pats
916
917 hs_pat (SigPatIn pat _) = hs_lpat pat
918 hs_pat (SigPatOut pat _) = hs_lpat pat
919 hs_pat (CoPat _ pat _) = hs_pat pat
920
921 hs_pat (ConPatIn _ ps) = details ps
922 hs_pat (ConPatOut {pat_args=ps}) = details ps
923
924 hs_pat _ = emptyNameSet
925
926 details (PrefixCon ps) = hs_lpats ps
927 details (RecCon fs) = hs_lpats explicit `unionNameSet` mkNameSet (collectPatsBinders implicit)
928 where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat
929 | (i, fld) <- [0..] `zip` rec_flds fs
930 , let pat = hsRecFieldArg
931 (unLoc fld)
932 pat_explicit = maybe True (i<) (rec_dotdot fs)]
933 details (InfixCon p1 p2) = hs_lpat p1 `unionNameSet` hs_lpat p2