Add Template Haskell support for overloaded labels
[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 GhcPs/RdrName parser/RdrHsSyn
12 GhcRn/Name rename/RnHsSyn
13 GhcTc/Id typecheck/TcHsSyn
14 -}
15
16 {-# LANGUAGE CPP #-}
17 {-# LANGUAGE ScopedTypeVariables #-}
18 {-# LANGUAGE FlexibleContexts #-}
19 {-# LANGUAGE TypeFamilies #-}
20
21 module HsUtils(
22 -- Terms
23 mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypeOut, mkHsCaseAlt,
24 mkSimpleMatch, unguardedGRHSs, unguardedRHS,
25 mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
26 mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
27 mkHsDictLet, mkHsLams,
28 mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
29 mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
30
31 nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon,
32 nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
33 nlHsIntLit, nlHsVarApps,
34 nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
35 mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
36 typeToLHsType,
37
38 -- * Constructing general big tuples
39 -- $big_tuples
40 mkChunkified, chunkify,
41
42 -- Bindings
43 mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
44 mkPatSynBind,
45 isInfixFunBind,
46
47 -- Literals
48 mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,
49
50 -- Patterns
51 mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
52 nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
53 nlWildPatName, nlWildPatId, nlTuplePat, mkParPat, nlParPat,
54 mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
55
56 -- Types
57 mkHsAppTy, mkHsAppTys, userHsTyVarBndrs, userHsLTyVarBndrs,
58 mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv,
59 nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,
60
61 -- Stmts
62 mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt,
63 mkLastStmt,
64 emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,
65 emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,
66
67 -- Template Haskell
68 mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkUntypedSplice,
69 mkHsQuasiQuote, unqualQuasiQuote,
70
71 -- Flags
72 noRebindableInfo,
73
74 -- Collecting binders
75 isUnliftedHsBind, isBangedBind,
76
77 collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
78 collectHsIdBinders,
79 collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
80 collectPatBinders, collectPatsBinders,
81 collectLStmtsBinders, collectStmtsBinders,
82 collectLStmtBinders, collectStmtBinders,
83
84 hsLTyClDeclBinders, hsTyClForeignBinders,
85 hsPatSynSelectors, getPatSynBinds,
86 hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
87 hsDataDefnBinders,
88
89 -- Collecting implicit binders
90 lStmtsImplicits, hsValBindsImplicits, lPatImplicits
91 ) where
92
93 #include "HsVersions.h"
94
95 import HsDecls
96 import HsBinds
97 import HsExpr
98 import HsPat
99 import HsTypes
100 import HsLit
101 import PlaceHolder
102 import HsExtension
103
104 import TcEvidence
105 import RdrName
106 import Var
107 import TyCoRep
108 import Type ( filterOutInvisibleTypes )
109 import TysWiredIn ( unitTy )
110 import TcType
111 import DataCon
112 import ConLike
113 import Id
114 import Name
115 import NameSet
116 import NameEnv
117 import BasicTypes
118 import SrcLoc
119 import FastString
120 import Util
121 import Bag
122 import Outputable
123 import Constants
124
125 import Data.Either
126 import Data.Function
127 import Data.List
128
129 {-
130 ************************************************************************
131 * *
132 Some useful helpers for constructing syntax
133 * *
134 ************************************************************************
135
136 These functions attempt to construct a not-completely-useless SrcSpan
137 from their components, compared with the nl* functions below which
138 just attach noSrcSpan to everything.
139 -}
140
141 mkHsPar :: LHsExpr id -> LHsExpr id
142 mkHsPar e = L (getLoc e) (HsPar e)
143
144 mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP id))
145 -> [LPat id] -> Located (body id)
146 -> LMatch id (Located (body id))
147 mkSimpleMatch ctxt pats rhs
148 = L loc $
149 Match ctxt pats Nothing (unguardedGRHSs rhs)
150 where
151 loc = case pats of
152 [] -> getLoc rhs
153 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
154
155 unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id))
156 unguardedGRHSs rhs@(L loc _)
157 = GRHSs (unguardedRHS loc rhs) (noLoc emptyLocalBinds)
158
159 unguardedRHS :: SrcSpan -> Located (body id) -> [LGRHS id (Located (body id))]
160 unguardedRHS loc rhs = [L loc (GRHS [] rhs)]
161
162 mkMatchGroup :: (PostTc name Type ~ PlaceHolder)
163 => Origin -> [LMatch name (Located (body name))]
164 -> MatchGroup name (Located (body name))
165 mkMatchGroup origin matches = MG { mg_alts = mkLocatedList matches
166 , mg_arg_tys = []
167 , mg_res_ty = placeHolderType
168 , mg_origin = origin }
169
170 mkLocatedList :: [Located a] -> Located [Located a]
171 mkLocatedList [] = noLoc []
172 mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms
173
174 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
175 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
176
177 mkHsAppType :: LHsExpr name -> LHsWcType name -> LHsExpr name
178 mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType e t)
179
180 mkHsAppTypeOut :: LHsExpr GhcTc -> LHsWcType GhcRn -> LHsExpr GhcTc
181 mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppTypeOut e t)
182
183 mkHsLam :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
184 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
185 where
186 matches = mkMatchGroup Generated
187 [mkSimpleMatch LambdaExpr pats body]
188
189 mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
190 mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
191 <.> mkWpLams dicts) expr
192
193 -- |A simple case alternative with a single pattern, no binds, no guards;
194 -- pre-typechecking
195 mkHsCaseAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id))
196 mkHsCaseAlt pat expr
197 = mkSimpleMatch CaseAlt [pat] expr
198
199 nlHsTyApp :: IdP name -> [Type] -> LHsExpr name
200 nlHsTyApp fun_id tys = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id)))
201
202 nlHsTyApps :: IdP name -> [Type] -> [LHsExpr name] -> LHsExpr name
203 nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs
204
205 --------- Adding parens ---------
206 mkLHsPar :: LHsExpr name -> LHsExpr name
207 -- Wrap in parens if hsExprNeedsParens says it needs them
208 -- So 'f x' becomes '(f x)', but '3' stays as '3'
209 mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le)
210 | otherwise = le
211
212 mkParPat :: LPat name -> LPat name
213 mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp)
214 | otherwise = lp
215
216 nlParPat :: LPat name -> LPat name
217 nlParPat p = noLoc (ParPat p)
218
219 -------------------------------
220 -- These are the bits of syntax that contain rebindable names
221 -- See RnEnv.lookupSyntaxName
222
223 mkHsIntegral :: IntegralLit -> PostTc GhcPs Type
224 -> HsOverLit GhcPs
225 mkHsFractional :: FractionalLit -> PostTc GhcPs Type -> HsOverLit GhcPs
226 mkHsIsString :: SourceText -> FastString -> PostTc GhcPs Type
227 -> HsOverLit GhcPs
228 mkHsDo :: HsStmtContext Name -> [ExprLStmt GhcPs] -> HsExpr GhcPs
229 mkHsComp :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
230 -> HsExpr GhcPs
231
232 mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs)
233 -> Pat GhcPs
234 mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs
235
236 mkLastStmt :: SourceTextX idR
237 => Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
238 mkBodyStmt :: Located (bodyR GhcPs)
239 -> StmtLR idL GhcPs (Located (bodyR GhcPs))
240 mkBindStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
241 => LPat idL -> Located (bodyR idR)
242 -> StmtLR idL idR (Located (bodyR idR))
243 mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc)
244 -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc))
245
246 emptyRecStmt :: StmtLR idL GhcPs bodyR
247 emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR
248 emptyRecStmtId :: StmtLR GhcTc GhcTc bodyR
249 mkRecStmt :: [LStmtLR idL GhcPs bodyR] -> StmtLR idL GhcPs bodyR
250
251
252 mkHsIntegral i = OverLit (HsIntegral i) noRebindableInfo noExpr
253 mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noExpr
254 mkHsIsString src s = OverLit (HsIsString src s) noRebindableInfo noExpr
255
256 noRebindableInfo :: PlaceHolder
257 noRebindableInfo = PlaceHolder -- Just another placeholder;
258
259 mkHsDo ctxt stmts = HsDo ctxt (mkLocatedList stmts) placeHolderType
260 mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
261 where
262 last_stmt = L (getLoc expr) $ mkLastStmt expr
263
264 mkHsIf :: SourceTextX p => LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
265 mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
266
267 mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType
268 mkNPlusKPat id lit = NPlusKPat id lit (unLoc lit) noSyntaxExpr noSyntaxExpr placeHolderType
269
270 mkTransformStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
271 => [ExprLStmt idL] -> LHsExpr idR
272 -> StmtLR idL idR (LHsExpr idL)
273 mkTransformByStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
274 => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
275 -> StmtLR idL idR (LHsExpr idL)
276 mkGroupUsingStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
277 => [ExprLStmt idL] -> LHsExpr idR
278 -> StmtLR idL idR (LHsExpr idL)
279 mkGroupByUsingStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
280 => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
281 -> StmtLR idL idR (LHsExpr idL)
282
283 emptyTransStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
284 => StmtLR idL idR (LHsExpr idR)
285 emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form"
286 , trS_stmts = [], trS_bndrs = []
287 , trS_by = Nothing, trS_using = noLoc noExpr
288 , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
289 , trS_bind_arg_ty = PlaceHolder
290 , trS_fmap = noExpr }
291 mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u }
292 mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
293 mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u }
294 mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
295
296 mkLastStmt body = LastStmt body False noSyntaxExpr
297 mkBodyStmt body = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType
298 mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr PlaceHolder
299 mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy
300 -- don't use placeHolderTypeTc above, because that panics during zonking
301
302 emptyRecStmt' :: forall idL idR body. SourceTextX idR =>
303 PostTc idR Type -> StmtLR idL idR body
304 emptyRecStmt' tyVal =
305 RecStmt
306 { recS_stmts = [], recS_later_ids = []
307 , recS_rec_ids = []
308 , recS_ret_fn = noSyntaxExpr
309 , recS_mfix_fn = noSyntaxExpr
310 , recS_bind_fn = noSyntaxExpr, recS_bind_ty = tyVal
311 , recS_later_rets = []
312 , recS_rec_rets = [], recS_ret_ty = tyVal }
313
314 emptyRecStmt = emptyRecStmt' placeHolderType
315 emptyRecStmtName = emptyRecStmt' placeHolderType
316 emptyRecStmtId = emptyRecStmt' unitTy -- a panic might trigger during zonking
317 mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
318
319 -------------------------------
320 --- A useful function for building @OpApps@. The operator is always a
321 -- variable, and we don't know the fixity yet.
322 mkHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> HsExpr id
323 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op)))
324 (error "mkOpApp:fixity") e2
325
326 unqualSplice :: RdrName
327 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
328
329 mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
330 mkUntypedSplice hasParen e = HsUntypedSplice hasParen unqualSplice e
331
332 mkHsSpliceE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs
333 mkHsSpliceE hasParen e = HsSpliceE (mkUntypedSplice hasParen e)
334
335 mkHsSpliceTE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs
336 mkHsSpliceTE hasParen e = HsSpliceE (HsTypedSplice hasParen unqualSplice e)
337
338 mkHsSpliceTy :: SpliceDecoration -> LHsExpr GhcPs -> HsType GhcPs
339 mkHsSpliceTy hasParen e
340 = HsSpliceTy (HsUntypedSplice hasParen unqualSplice e) placeHolderKind
341
342 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs
343 mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote
344
345 unqualQuasiQuote :: RdrName
346 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
347 -- A name (uniquified later) to
348 -- identify the quasi-quote
349
350 mkHsString :: SourceTextX p => String -> HsLit p
351 mkHsString s = HsString noSourceText (mkFastString s)
352
353 mkHsStringPrimLit :: SourceTextX p => FastString -> HsLit p
354 mkHsStringPrimLit fs
355 = HsStringPrim noSourceText (fastStringToByteString fs)
356
357 -------------
358 userHsLTyVarBndrs :: SrcSpan -> [Located (IdP name)] -> [LHsTyVarBndr name]
359 -- Caller sets location
360 userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]
361
362 userHsTyVarBndrs :: SrcSpan -> [IdP name] -> [LHsTyVarBndr name]
363 -- Caller sets location
364 userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]
365
366
367 {-
368 ************************************************************************
369 * *
370 Constructing syntax with no location info
371 * *
372 ************************************************************************
373 -}
374
375 nlHsVar :: IdP id -> LHsExpr id
376 nlHsVar n = noLoc (HsVar (noLoc n))
377
378 -- NB: Only for LHsExpr **Id**
379 nlHsDataCon :: DataCon -> LHsExpr GhcTc
380 nlHsDataCon con = noLoc (HsConLikeOut (RealDataCon con))
381
382 nlHsLit :: HsLit p -> LHsExpr p
383 nlHsLit n = noLoc (HsLit n)
384
385 nlHsIntLit :: HasDefaultX p => Integer -> LHsExpr p
386 nlHsIntLit n = noLoc (HsLit (HsInt def (mkIntegralLit n)))
387
388 nlVarPat :: IdP id -> LPat id
389 nlVarPat n = noLoc (VarPat (noLoc n))
390
391 nlLitPat :: HsLit p -> LPat p
392 nlLitPat l = noLoc (LitPat l)
393
394 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
395 nlHsApp f x = noLoc (HsApp f (mkLHsPar x))
396
397 nlHsSyntaxApps :: SyntaxExpr id -> [LHsExpr id] -> LHsExpr id
398 nlHsSyntaxApps (SyntaxExpr { syn_expr = fun
399 , syn_arg_wraps = arg_wraps
400 , syn_res_wrap = res_wrap }) args
401 | [] <- arg_wraps -- in the noSyntaxExpr case
402 = ASSERT( isIdHsWrapper res_wrap )
403 foldl nlHsApp (noLoc fun) args
404
405 | otherwise
406 = mkLHsWrap res_wrap (foldl nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"
407 mkLHsWrap arg_wraps args))
408
409 nlHsApps :: IdP id -> [LHsExpr id] -> LHsExpr id
410 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
411
412 nlHsVarApps :: IdP id -> [IdP id] -> LHsExpr id
413 nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs))
414 where
415 mk f a = HsApp (noLoc f) (noLoc a)
416
417 nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs
418 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
419
420 nlConVarPatName :: Name -> [Name] -> LPat GhcRn
421 nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)
422
423 nlInfixConPat :: IdP id -> LPat id -> LPat id -> LPat id
424 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
425
426 nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs
427 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
428
429 nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn
430 nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
431
432 nlNullaryConPat :: IdP id -> LPat id
433 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
434
435 nlWildConPat :: DataCon -> LPat GhcPs
436 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
437 (PrefixCon (nOfThem (dataConSourceArity con)
438 nlWildPat)))
439
440 nlWildPat :: LPat GhcPs
441 nlWildPat = noLoc (WildPat placeHolderType ) -- Pre-typechecking
442
443 nlWildPatName :: LPat GhcRn
444 nlWildPatName = noLoc (WildPat placeHolderType ) -- Pre-typechecking
445
446 nlWildPatId :: LPat GhcTc
447 nlWildPatId = noLoc (WildPat placeHolderTypeTc ) -- Post-typechecking
448
449 nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)]
450 -> LHsExpr GhcPs
451 nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
452
453 nlHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> LHsExpr id
454 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
455
456 nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
457 nlHsPar :: LHsExpr id -> LHsExpr id
458 nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
459 nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]
460 -> LHsExpr GhcPs
461 nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs
462
463 nlHsLam match = noLoc (HsLam (mkMatchGroup Generated [match]))
464 nlHsPar e = noLoc (HsPar e)
465
466 -- Note [Rebindable nlHsIf]
467 -- nlHsIf should generate if-expressions which are NOT subject to
468 -- RebindableSyntax, so the first field of HsIf is Nothing. (#12080)
469 nlHsIf cond true false = noLoc (HsIf Nothing cond true false)
470
471 nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches))
472 nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs)
473
474 nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
475 nlHsTyVar :: IdP name -> LHsType name
476 nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
477 nlHsParTy :: LHsType name -> LHsType name
478
479 nlHsAppTy f t = noLoc (HsAppTy f t)
480 nlHsTyVar x = noLoc (HsTyVar NotPromoted (noLoc x))
481 nlHsFunTy a b = noLoc (HsFunTy a b)
482 nlHsParTy t = noLoc (HsParTy t)
483
484 nlHsTyConApp :: IdP name -> [LHsType name] -> LHsType name
485 nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys
486
487 {-
488 Tuples. All these functions are *pre-typechecker* because they lack
489 types on the tuple.
490 -}
491
492 mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
493 -- Makes a pre-typechecker boxed tuple, deals with 1 case
494 mkLHsTupleExpr [e] = e
495 mkLHsTupleExpr es = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed
496
497 mkLHsVarTuple :: [IdP a] -> LHsExpr a
498 mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids)
499
500 nlTuplePat :: [LPat id] -> Boxity -> LPat id
501 nlTuplePat pats box = noLoc (TuplePat pats box [])
502
503 missingTupArg :: HsTupArg GhcPs
504 missingTupArg = Missing placeHolderType
505
506 mkLHsPatTup :: [LPat id] -> LPat id
507 mkLHsPatTup [] = noLoc $ TuplePat [] Boxed []
508 mkLHsPatTup [lpat] = lpat
509 mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat lpats Boxed []
510
511 -- The Big equivalents for the source tuple expressions
512 mkBigLHsVarTup :: [IdP id] -> LHsExpr id
513 mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
514
515 mkBigLHsTup :: [LHsExpr id] -> LHsExpr id
516 mkBigLHsTup = mkChunkified mkLHsTupleExpr
517
518 -- The Big equivalents for the source tuple patterns
519 mkBigLHsVarPatTup :: [IdP id] -> LPat id
520 mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
521
522 mkBigLHsPatTup :: [LPat id] -> LPat id
523 mkBigLHsPatTup = mkChunkified mkLHsPatTup
524
525 -- $big_tuples
526 -- #big_tuples#
527 --
528 -- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but
529 -- we might concievably want to build such a massive tuple as part of the
530 -- output of a desugaring stage (notably that for list comprehensions).
531 --
532 -- We call tuples above this size \"big tuples\", and emulate them by
533 -- creating and pattern matching on >nested< tuples that are expressible
534 -- by GHC.
535 --
536 -- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects)
537 -- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any
538 -- construction to be big.
539 --
540 -- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector'
541 -- and 'mkTupleCase' functions to do all your work with tuples you should be
542 -- fine, and not have to worry about the arity limitation at all.
543
544 -- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon
545 mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'
546 -> [a] -- ^ Possible \"big\" list of things to construct from
547 -> a -- ^ Constructed thing made possible by recursive decomposition
548 mkChunkified small_tuple as = mk_big_tuple (chunkify as)
549 where
550 -- Each sub-list is short enough to fit in a tuple
551 mk_big_tuple [as] = small_tuple as
552 mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
553
554 chunkify :: [a] -> [[a]]
555 -- ^ Split a list into lists that are small enough to have a corresponding
556 -- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE'
557 -- But there may be more than 'mAX_TUPLE_SIZE' sub-lists
558 chunkify xs
559 | n_xs <= mAX_TUPLE_SIZE = [xs]
560 | otherwise = split xs
561 where
562 n_xs = length xs
563 split [] = []
564 split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
565
566 {-
567 ************************************************************************
568 * *
569 LHsSigType and LHsSigWcType
570 * *
571 ********************************************************************* -}
572
573 mkLHsSigType :: LHsType GhcPs -> LHsSigType GhcPs
574 mkLHsSigType ty = mkHsImplicitBndrs ty
575
576 mkLHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs
577 mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty)
578
579 mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([Located Name], a))
580 -> [LSig GhcRn]
581 -> NameEnv a
582 mkHsSigEnv get_info sigs
583 = mkNameEnv (mk_pairs ordinary_sigs)
584 `extendNameEnvList` (mk_pairs gen_dm_sigs)
585 -- The subtlety is this: in a class decl with a
586 -- default-method signature as well as a method signature
587 -- we want the latter to win (Trac #12533)
588 -- class C x where
589 -- op :: forall a . x a -> x a
590 -- default op :: forall b . x b -> x b
591 -- op x = ...(e :: b -> b)...
592 -- The scoped type variables of the 'default op', namely 'b',
593 -- scope over the code for op. The 'forall a' does not!
594 -- This applies both in the renamer and typechecker, both
595 -- of which use this function
596 where
597 (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs
598 is_gen_dm_sig (L _ (ClassOpSig True _ _)) = True
599 is_gen_dm_sig _ = False
600
601 mk_pairs :: [LSig GhcRn] -> [(Name, a)]
602 mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs
603 , L _ n <- ns ]
604
605 mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs]
606 -- Convert TypeSig to ClassOpSig
607 -- The former is what is parsed, but the latter is
608 -- what we need in class/instance declarations
609 mkClassOpSigs sigs
610 = map fiddle sigs
611 where
612 fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty))
613 fiddle sig = sig
614
615 typeToLHsType :: Type -> LHsType GhcPs
616 -- ^ Converting a Type to an HsType RdrName
617 -- This is needed to implement GeneralizedNewtypeDeriving.
618 --
619 -- Note that we use 'getRdrName' extensively, which
620 -- generates Exact RdrNames rather than strings.
621 typeToLHsType ty
622 = go ty
623 where
624 go :: Type -> LHsType GhcPs
625 go ty@(FunTy arg _)
626 | isPredTy arg
627 , (theta, tau) <- tcSplitPhiTy ty
628 = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
629 , hst_body = go tau })
630 go (FunTy arg res) = nlHsFunTy (go arg) (go res)
631 go ty@(ForAllTy {})
632 | (tvs, tau) <- tcSplitForAllTys ty
633 = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs
634 , hst_body = go tau })
635 go (TyVarTy tv) = nlHsTyVar (getRdrName tv)
636 go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2)
637 go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy noSourceText n)
638 go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy noSourceText s)
639 go (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map go args')
640 where
641 args' = filterOutInvisibleTypes tc args
642 go (CastTy ty _) = go ty
643 go (CoercionTy co) = pprPanic "toLHsSigWcType" (ppr co)
644
645 -- Source-language types have _invisible_ kind arguments,
646 -- so we must remove them here (Trac #8563)
647
648 go_tv :: TyVar -> LHsTyVarBndr GhcPs
649 go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
650 (go (tyVarKind tv))
651
652
653 {- *********************************************************************
654 * *
655 --------- HsWrappers: type args, dict args, casts ---------
656 * *
657 ********************************************************************* -}
658
659 mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
660 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
661
662 -- Avoid (HsWrap co (HsWrap co' _)).
663 -- See Note [Detecting forced eta expansion] in DsExpr
664 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
665 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
666 mkHsWrap co_fn (HsWrap co_fn' e) = mkHsWrap (co_fn <.> co_fn') e
667 mkHsWrap co_fn e = HsWrap co_fn e
668
669 mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b
670 -> HsExpr id -> HsExpr id
671 mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
672
673 mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b
674 -> HsExpr id -> HsExpr id
675 mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
676
677 mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id
678 mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
679
680 mkHsCmdWrap :: HsWrapper -> HsCmd id -> HsCmd id
681 mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
682 | otherwise = HsCmdWrap w cmd
683
684 mkLHsCmdWrap :: HsWrapper -> LHsCmd id -> LHsCmd id
685 mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
686
687 mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
688 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
689 | otherwise = CoPat co_fn p ty
690
691 mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id
692 mkHsWrapPatCo co pat ty | isTcReflCo co = pat
693 | otherwise = CoPat (mkWpCastN co) pat ty
694
695 mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
696 mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
697
698 {-
699 l
700 ************************************************************************
701 * *
702 Bindings; with a location at the top
703 * *
704 ************************************************************************
705 -}
706
707 mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
708 -> HsBind GhcPs
709 -- Not infix, with place holders for coercion and free vars
710 mkFunBind fn ms = FunBind { fun_id = fn
711 , fun_matches = mkMatchGroup Generated ms
712 , fun_co_fn = idHsWrapper
713 , bind_fvs = placeHolderNames
714 , fun_tick = [] }
715
716 mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]
717 -> HsBind GhcRn
718 -- In Name-land, with empty bind_fvs
719 mkTopFunBind origin fn ms = FunBind { fun_id = fn
720 , fun_matches = mkMatchGroup origin ms
721 , fun_co_fn = idHsWrapper
722 , bind_fvs = emptyNameSet -- NB: closed
723 -- binding
724 , fun_tick = [] }
725
726 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
727 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
728
729 mkVarBind :: IdP p -> LHsExpr p -> LHsBind p
730 mkVarBind var rhs = L (getLoc rhs) $
731 VarBind { var_id = var, var_rhs = rhs, var_inline = False }
732
733 mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
734 -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs
735 mkPatSynBind name details lpat dir = PatSynBind psb
736 where
737 psb = PSB{ psb_id = name
738 , psb_args = details
739 , psb_def = lpat
740 , psb_dir = dir
741 , psb_fvs = placeHolderNames }
742
743 -- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
744 -- considered infix.
745 isInfixFunBind :: HsBindLR id1 id2 -> Bool
746 isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _)
747 = any (isInfixMatch . unLoc) (unLoc matches)
748 isInfixFunBind _ = False
749
750
751 ------------
752 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
753 -> LHsExpr GhcPs -> LHsBind GhcPs
754 mk_easy_FunBind loc fun pats expr
755 = L loc $ mkFunBind (L loc fun)
756 [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr
757 (noLoc emptyLocalBinds)]
758
759 -- | Make a prefix, non-strict function 'HsMatchContext'
760 mkPrefixFunRhs :: Located id -> HsMatchContext id
761 mkPrefixFunRhs n = FunRhs n Prefix NoSrcStrict
762
763 ------------
764 mkMatch :: HsMatchContext (NameOrRdrName (IdP p)) -> [LPat p] -> LHsExpr p
765 -> Located (HsLocalBinds p) -> LMatch p (LHsExpr p)
766 mkMatch ctxt pats expr lbinds
767 = noLoc (Match ctxt (map paren pats) Nothing
768 (GRHSs (unguardedRHS noSrcSpan expr) lbinds))
769 where
770 paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
771 | otherwise = lp
772
773 {-
774 ************************************************************************
775 * *
776 Collecting binders
777 * *
778 ************************************************************************
779
780 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
781
782 ...
783 where
784 (x, y) = ...
785 f i j = ...
786 [a, b] = ...
787
788 it should return [x, y, f, a, b] (remember, order important).
789
790 Note [Collect binders only after renaming]
791 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
792 These functions should only be used on HsSyn *after* the renamer,
793 to return a [Name] or [Id]. Before renaming the record punning
794 and wild-card mechanism makes it hard to know what is bound.
795 So these functions should not be applied to (HsSyn RdrName)
796
797 Note [Unlifted id check in isHsUnliftedBind]
798 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
799 Suppose there is a binding with the type (Num a => (# a, a #)). Is this a
800 strict binding that should be disallowed at the top level? At first glance,
801 no, because it's a function. But consider how this is desugared via
802 AbsBinds:
803
804 -- x :: Num a => (# a, a #)
805 x = (# 3, 4 #)
806
807 becomes
808
809 x = \ $dictNum ->
810 let x_mono = (# fromInteger $dictNum 3, fromInteger $dictNum 4 #) in
811 x_mono
812
813 Note that the inner let is strict. And thus if we have a bunch of mutually
814 recursive bindings of this form, we could end up in trouble. This was shown
815 up in #9140.
816
817 But if there is a type signature on x, everything changes because of the
818 desugaring used by AbsBindsSig:
819
820 x :: Num a => (# a, a #)
821 x = (# 3, 4 #)
822
823 becomes
824
825 x = \ $dictNum -> (# fromInteger $dictNum 3, fromInteger $dictNum 4 #)
826
827 No strictness anymore! The bottom line here is that, for inferred types, we
828 care about the strictness of the type after the =>. For checked types
829 (AbsBindsSig), we care about the overall strictness.
830
831 This matters. If we don't separate out the AbsBindsSig case, then GHC runs into
832 a problem when compiling
833
834 undefined :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a
835
836 Looking only after the =>, we cannot tell if this is strict or not. (GHC panics
837 if you try.) Looking at the whole type, on the other hand, tells you that this
838 is a lifted function type, with no trouble at all.
839
840 -}
841
842 ----------------- Bindings --------------------------
843
844 -- | Should we treat this as an unlifted bind? This will be true for any
845 -- bind that binds an unlifted variable, but we must be careful around
846 -- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage
847 -- information, see Note [Strict binds check] is DsBinds.
848 isUnliftedHsBind :: HsBind GhcTc -> Bool -- works only over typechecked binds
849 isUnliftedHsBind (AbsBindsSig { abs_sig_export = id })
850 = isUnliftedType (idType id)
851 isUnliftedHsBind bind
852 = any is_unlifted_id (collectHsBindBinders bind)
853 where
854 is_unlifted_id id
855 = case tcSplitSigmaTy (idType id) of
856 (_, _, tau) -> isUnliftedType tau
857 -- For the is_unlifted check, we need to look inside polymorphism
858 -- and overloading. E.g. x = (# 1, True #)
859 -- would get type forall a. Num a => (# a, Bool #)
860 -- and we want to reject that. See Trac #9140
861
862 -- | Is a binding a strict variable bind (e.g. @!x = ...@)?
863 isBangedBind :: HsBind GhcTc -> Bool
864 isBangedBind b | isBangedPatBind b = True
865 isBangedBind (FunBind {fun_matches = matches})
866 | [L _ match] <- unLoc $ mg_alts matches
867 , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
868 = True
869 isBangedBind _ = False
870
871 collectLocalBinders :: HsLocalBindsLR idL idR -> [IdP idL]
872 collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
873 -- No pattern synonyms here
874 collectLocalBinders (HsIPBinds _) = []
875 collectLocalBinders EmptyLocalBinds = []
876
877 collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [IdP idL]
878 -- Collect Id binders only, or Ids + pattern synonyms, respectively
879 collectHsIdBinders = collect_hs_val_binders True
880 collectHsValBinders = collect_hs_val_binders False
881
882 collectHsBindBinders :: HsBindLR idL idR -> [IdP idL]
883 -- Collect both Ids and pattern-synonym binders
884 collectHsBindBinders b = collect_bind False b []
885
886 collectHsBindsBinders :: LHsBindsLR idL idR -> [IdP idL]
887 collectHsBindsBinders binds = collect_binds False binds []
888
889 collectHsBindListBinders :: [LHsBindLR idL idR] -> [IdP idL]
890 -- Same as collectHsBindsBinders, but works over a list of bindings
891 collectHsBindListBinders = foldr (collect_bind False . unLoc) []
892
893 collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [IdP idL]
894 collect_hs_val_binders ps (ValBindsIn binds _) = collect_binds ps binds []
895 collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds
896
897 collect_out_binds :: Bool -> [(RecFlag, LHsBinds p)] -> [IdP p]
898 collect_out_binds ps = foldr (collect_binds ps . snd) []
899
900 collect_binds :: Bool -> LHsBindsLR idL idR -> [IdP idL] -> [IdP idL]
901 -- Collect Ids, or Ids + pattern synonyms, depending on boolean flag
902 collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds
903
904 collect_bind :: Bool -> HsBindLR idL idR -> [IdP idL] -> [IdP idL]
905 collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc
906 collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc
907 collect_bind _ (VarBind { var_id = f }) acc = f : acc
908 collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
909 -- I don't think we want the binders from the abe_binds
910 -- The only time we collect binders from a typechecked
911 -- binding (hence see AbsBinds) is in zonking in TcHsSyn
912 collect_bind _ (AbsBindsSig { abs_sig_export = poly }) acc = poly : acc
913 collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc
914 | omitPatSyn = acc
915 | otherwise = ps : acc
916
917 collectMethodBinders :: LHsBindsLR GhcPs idR -> [Located RdrName]
918 -- Used exclusively for the bindings of an instance decl which are all FunBinds
919 collectMethodBinders binds = foldrBag (get . unLoc) [] binds
920 where
921 get (FunBind { fun_id = f }) fs = f : fs
922 get _ fs = fs
923 -- Someone else complains about non-FunBinds
924
925 ----------------- Statements --------------------------
926 collectLStmtsBinders :: [LStmtLR idL idR body] -> [IdP idL]
927 collectLStmtsBinders = concatMap collectLStmtBinders
928
929 collectStmtsBinders :: [StmtLR idL idR body] -> [IdP idL]
930 collectStmtsBinders = concatMap collectStmtBinders
931
932 collectLStmtBinders :: LStmtLR idL idR body -> [IdP idL]
933 collectLStmtBinders = collectStmtBinders . unLoc
934
935 collectStmtBinders :: StmtLR idL idR body -> [IdP idL]
936 -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
937 collectStmtBinders (BindStmt pat _ _ _ _)= collectPatBinders pat
938 collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds
939 collectStmtBinders (BodyStmt {}) = []
940 collectStmtBinders (LastStmt {}) = []
941 collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
942 $ [s | ParStmtBlock ss _ _ <- xs, s <- ss]
943 collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
944 collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
945 collectStmtBinders ApplicativeStmt{} = []
946
947
948 ----------------- Patterns --------------------------
949 collectPatBinders :: LPat a -> [IdP a]
950 collectPatBinders pat = collect_lpat pat []
951
952 collectPatsBinders :: [LPat a] -> [IdP a]
953 collectPatsBinders pats = foldr collect_lpat [] pats
954
955 -------------
956 collect_lpat :: LPat pass -> [IdP pass] -> [IdP pass]
957 collect_lpat (L _ pat) bndrs
958 = go pat
959 where
960 go (VarPat (L _ var)) = var : bndrs
961 go (WildPat _) = bndrs
962 go (LazyPat pat) = collect_lpat pat bndrs
963 go (BangPat pat) = collect_lpat pat bndrs
964 go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs
965 go (ViewPat _ pat _) = collect_lpat pat bndrs
966 go (ParPat pat) = collect_lpat pat bndrs
967
968 go (ListPat pats _ _) = foldr collect_lpat bndrs pats
969 go (PArrPat pats _) = foldr collect_lpat bndrs pats
970 go (TuplePat pats _ _) = foldr collect_lpat bndrs pats
971 go (SumPat pat _ _ _) = collect_lpat pat bndrs
972
973 go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps)
974 go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps)
975 -- See Note [Dictionary binders in ConPatOut]
976 go (LitPat _) = bndrs
977 go (NPat {}) = bndrs
978 go (NPlusKPat (L _ n) _ _ _ _ _)= n : bndrs
979
980 go (SigPatIn pat _) = collect_lpat pat bndrs
981 go (SigPatOut pat _) = collect_lpat pat bndrs
982
983 go (SplicePat (HsSpliced _ (HsSplicedPat pat)))
984 = go pat
985 go (SplicePat _) = bndrs
986 go (CoPat _ pat _) = go pat
987
988 {-
989 Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
990 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
991 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
992 of a ConPatOut pattern. For most calls it doesn't matter, because
993 it's pre-typechecker and there are no ConPatOuts. But it does matter
994 more in the desugarer; for example, DsUtils.mkSelectorBinds uses
995 collectPatBinders. In a lazy pattern, for example f ~(C x y) = ...,
996 we want to generate bindings for x,y but not for dictionaries bound by
997 C. (The type checker ensures they would not be used.)
998
999 Desugaring of arrow case expressions needs these bindings (see DsArrows
1000 and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
1001 own pat-binder-collector:
1002
1003 Here's the problem. Consider
1004
1005 data T a where
1006 C :: Num a => a -> Int -> T a
1007
1008 f ~(C (n+1) m) = (n,m)
1009
1010 Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
1011 and *also* uses that dictionary to match the (n+1) pattern. Yet, the
1012 variables bound by the lazy pattern are n,m, *not* the dictionary d.
1013 So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
1014 -}
1015
1016 hsGroupBinders :: HsGroup GhcRn -> [Name]
1017 hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
1018 hs_fords = foreign_decls })
1019 = collectHsValBinders val_decls
1020 ++ hsTyClForeignBinders tycl_decls foreign_decls
1021
1022 hsTyClForeignBinders :: [TyClGroup GhcRn]
1023 -> [LForeignDecl GhcRn]
1024 -> [Name]
1025 -- We need to look at instance declarations too,
1026 -- because their associated types may bind data constructors
1027 hsTyClForeignBinders tycl_decls foreign_decls
1028 = map unLoc (hsForeignDeclsBinders foreign_decls)
1029 ++ getSelectorNames
1030 (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls
1031 `mappend`
1032 foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)
1033 where
1034 getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name]
1035 getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs
1036
1037 -------------------
1038 hsLTyClDeclBinders :: Located (TyClDecl pass)
1039 -> ([Located (IdP pass)], [LFieldOcc pass])
1040 -- ^ Returns all the /binding/ names of the decl. The first one is
1041 -- guaranteed to be the name of the decl. The first component
1042 -- represents all binding names except record fields; the second
1043 -- represents field occurrences. For record fields mentioned in
1044 -- multiple constructors, the SrcLoc will be from the first occurrence.
1045 --
1046 -- Each returned (Located name) has a SrcSpan for the /whole/ declaration.
1047 -- See Note [SrcSpan for binders]
1048
1049 hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
1050 = ([L loc name], [])
1051 hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) = ([L loc name], [])
1052 hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name
1053 , tcdSigs = sigs, tcdATs = ats }))
1054 = (L loc cls_name :
1055 [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
1056 [ L mem_loc mem_name | L mem_loc (ClassOpSig False ns _) <- sigs, L _ mem_name <- ns ]
1057 , [])
1058 hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn }))
1059 = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
1060
1061 -------------------
1062 hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)]
1063 -- See Note [SrcSpan for binders]
1064 hsForeignDeclsBinders foreign_decls
1065 = [ L decl_loc n
1066 | L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls]
1067
1068
1069 -------------------
1070 hsPatSynSelectors :: HsValBinds p -> [IdP p]
1071 -- Collects record pattern-synonym selectors only; the pattern synonym
1072 -- names are collected by collectHsValBinders.
1073 hsPatSynSelectors (ValBindsIn _ _) = panic "hsPatSynSelectors"
1074 hsPatSynSelectors (ValBindsOut binds _)
1075 = foldrBag addPatSynSelector [] . unionManyBags $ map snd binds
1076
1077 addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p]
1078 addPatSynSelector bind sels
1079 | L _ (PatSynBind (PSB { psb_args = RecordPatSyn as })) <- bind
1080 = map (unLoc . recordPatSynSelectorId) as ++ sels
1081 | otherwise = sels
1082
1083 getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
1084 getPatSynBinds binds
1085 = [ psb | (_, lbinds) <- binds
1086 , L _ (PatSynBind psb) <- bagToList lbinds ]
1087
1088 -------------------
1089 hsLInstDeclBinders :: LInstDecl pass
1090 -> ([Located (IdP pass)], [LFieldOcc pass])
1091 hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))
1092 = foldMap (hsDataFamInstBinders . unLoc) dfis
1093 hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
1094 = hsDataFamInstBinders fi
1095 hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
1096
1097 -------------------
1098 -- the SrcLoc returned are for the whole declarations, not just the names
1099 hsDataFamInstBinders :: DataFamInstDecl pass
1100 -> ([Located (IdP pass)], [LFieldOcc pass])
1101 hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
1102 = hsDataDefnBinders defn
1103 -- There can't be repeated symbols because only data instances have binders
1104
1105 -------------------
1106 -- the SrcLoc returned are for the whole declarations, not just the names
1107 hsDataDefnBinders :: HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass])
1108 hsDataDefnBinders (HsDataDefn { dd_cons = cons })
1109 = hsConDeclsBinders cons
1110 -- See Note [Binders in family instances]
1111
1112 -------------------
1113 hsConDeclsBinders :: [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass])
1114 -- See hsLTyClDeclBinders for what this does
1115 -- The function is boringly complicated because of the records
1116 -- And since we only have equality, we have to be a little careful
1117 hsConDeclsBinders cons = go id cons
1118 where go :: ([LFieldOcc pass] -> [LFieldOcc pass])
1119 -> [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass])
1120 go _ [] = ([], [])
1121 go remSeen (r:rs) =
1122 -- don't re-mangle the location of field names, because we don't
1123 -- have a record of the full location of the field declaration anyway
1124 case r of
1125 -- remove only the first occurrence of any seen field in order to
1126 -- avoid circumventing detection of duplicate fields (#9156)
1127 L loc (ConDeclGADT { con_names = names
1128 , con_type = HsIB { hsib_body = res_ty}}) ->
1129 case tau of
1130 L _ (HsFunTy
1131 (L _ (HsAppsTy
1132 [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _res_ty)
1133 -> record_gadt flds
1134 L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty)
1135 -> record_gadt flds
1136
1137 _other -> (map (L loc . unLoc) names ++ ns, fs)
1138 where (ns, fs) = go remSeen rs
1139 where
1140 (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
1141 record_gadt flds = (map (L loc . unLoc) names ++ ns, r' ++ fs)
1142 where r' = remSeen (concatMap (cd_fld_names . unLoc) flds)
1143 remSeen' = foldr (.) remSeen
1144 [deleteBy ((==) `on`
1145 unLoc . rdrNameFieldOcc . unLoc) v
1146 | v <- r']
1147 (ns, fs) = go remSeen' rs
1148
1149 L loc (ConDeclH98 { con_name = name
1150 , con_details = RecCon flds }) ->
1151 ([L loc (unLoc name)] ++ ns, r' ++ fs)
1152 where r' = remSeen (concatMap (cd_fld_names . unLoc)
1153 (unLoc flds))
1154 remSeen'
1155 = foldr (.) remSeen
1156 [deleteBy ((==) `on`
1157 unLoc . rdrNameFieldOcc . unLoc) v | v <- r']
1158 (ns, fs) = go remSeen' rs
1159 L loc (ConDeclH98 { con_name = name }) ->
1160 ([L loc (unLoc name)] ++ ns, fs)
1161 where (ns, fs) = go remSeen rs
1162
1163 {-
1164
1165 Note [SrcSpan for binders]
1166 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1167 When extracting the (Located RdrNme) for a binder, at least for the
1168 main name (the TyCon of a type declaration etc), we want to give it
1169 the @SrcSpan@ of the whole /declaration/, not just the name itself
1170 (which is how it appears in the syntax tree). This SrcSpan (for the
1171 entire declaration) is used as the SrcSpan for the Name that is
1172 finally produced, and hence for error messages. (See Trac #8607.)
1173
1174 Note [Binders in family instances]
1175 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1176 In a type or data family instance declaration, the type
1177 constructor is an *occurrence* not a binding site
1178 type instance T Int = Int -> Int -- No binders
1179 data instance S Bool = S1 | S2 -- Binders are S1,S2
1180
1181
1182 ************************************************************************
1183 * *
1184 Collecting binders the user did not write
1185 * *
1186 ************************************************************************
1187
1188 The job of this family of functions is to run through binding sites and find the set of all Names
1189 that were defined "implicitly", without being explicitly written by the user.
1190
1191 The main purpose is to find names introduced by record wildcards so that we can avoid
1192 warning the user when they don't use those names (#4404)
1193 -}
1194
1195 lStmtsImplicits :: [LStmtLR GhcRn idR (Located (body idR))] -> NameSet
1196 lStmtsImplicits = hs_lstmts
1197 where
1198 hs_lstmts :: [LStmtLR GhcRn idR (Located (body idR))] -> NameSet
1199 hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet
1200
1201 hs_stmt :: StmtLR GhcRn idR (Located (body idR)) -> NameSet
1202 hs_stmt (BindStmt pat _ _ _ _) = lPatImplicits pat
1203 hs_stmt (ApplicativeStmt args _ _) = unionNameSets (map do_arg args)
1204 where do_arg (_, ApplicativeArgOne pat _) = lPatImplicits pat
1205 do_arg (_, ApplicativeArgMany stmts _ _) = hs_lstmts stmts
1206 hs_stmt (LetStmt binds) = hs_local_binds (unLoc binds)
1207 hs_stmt (BodyStmt {}) = emptyNameSet
1208 hs_stmt (LastStmt {}) = emptyNameSet
1209 hs_stmt (ParStmt xs _ _ _) = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss]
1210 hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
1211 hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
1212
1213 hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds
1214 hs_local_binds (HsIPBinds _) = emptyNameSet
1215 hs_local_binds EmptyLocalBinds = emptyNameSet
1216
1217 hsValBindsImplicits :: HsValBindsLR GhcRn idR -> NameSet
1218 hsValBindsImplicits (ValBindsOut binds _)
1219 = foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds
1220 hsValBindsImplicits (ValBindsIn binds _)
1221 = lhsBindsImplicits binds
1222
1223 lhsBindsImplicits :: LHsBindsLR GhcRn idR -> NameSet
1224 lhsBindsImplicits = foldBag unionNameSet (lhs_bind . unLoc) emptyNameSet
1225 where
1226 lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
1227 lhs_bind _ = emptyNameSet
1228
1229 lPatImplicits :: LPat GhcRn -> NameSet
1230 lPatImplicits = hs_lpat
1231 where
1232 hs_lpat (L _ pat) = hs_pat pat
1233
1234 hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSet` rest) emptyNameSet
1235
1236 hs_pat (LazyPat pat) = hs_lpat pat
1237 hs_pat (BangPat pat) = hs_lpat pat
1238 hs_pat (AsPat _ pat) = hs_lpat pat
1239 hs_pat (ViewPat _ pat _) = hs_lpat pat
1240 hs_pat (ParPat pat) = hs_lpat pat
1241 hs_pat (ListPat pats _ _) = hs_lpats pats
1242 hs_pat (PArrPat pats _) = hs_lpats pats
1243 hs_pat (TuplePat pats _ _) = hs_lpats pats
1244
1245 hs_pat (SigPatIn pat _) = hs_lpat pat
1246 hs_pat (SigPatOut pat _) = hs_lpat pat
1247 hs_pat (CoPat _ pat _) = hs_pat pat
1248
1249 hs_pat (ConPatIn _ ps) = details ps
1250 hs_pat (ConPatOut {pat_args=ps}) = details ps
1251
1252 hs_pat _ = emptyNameSet
1253
1254 details (PrefixCon ps) = hs_lpats ps
1255 details (RecCon fs) = hs_lpats explicit `unionNameSet` mkNameSet (collectPatsBinders implicit)
1256 where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat
1257 | (i, fld) <- [0..] `zip` rec_flds fs
1258 , let pat = hsRecFieldArg
1259 (unLoc fld)
1260 pat_explicit = maybe True (i<) (rec_dotdot fs)]
1261 details (InfixCon p1 p2) = hs_lpat p1 `unionNameSet` hs_lpat p2