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