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