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