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