fd3d5efa6af10f8831265f20b7bd129b52a7eacd
[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, mkUntypedSplice,
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 unqualSplice :: RdrName
285 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
286
287 mkUntypedSplice :: LHsExpr RdrName -> HsSplice RdrName
288 mkUntypedSplice e = HsUntypedSplice unqualSplice e
289
290 mkHsSpliceE :: LHsExpr RdrName -> HsExpr RdrName
291 mkHsSpliceE e = HsSpliceE (mkUntypedSplice e)
292
293 mkHsSpliceTE :: LHsExpr RdrName -> HsExpr RdrName
294 mkHsSpliceTE e = HsSpliceE (HsTypedSplice unqualSplice e)
295
296 mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
297 mkHsSpliceTy e = HsSpliceTy (HsUntypedSplice unqualSplice e) placeHolderKind
298
299 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice RdrName
300 mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice 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 -- input coercion is Nominal
508 mkHsWrapPatCo :: TcCoercion -> Pat id -> Type -> Pat id
509 mkHsWrapPatCo co pat ty | isTcReflCo co = pat
510 | otherwise = CoPat (mkWpCast (mkTcSubCo co)) pat ty
511
512 mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
513 mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
514
515 {-
516 l
517 ************************************************************************
518 * *
519 Bindings; with a location at the top
520 * *
521 ************************************************************************
522 -}
523
524 mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
525 -> HsBind RdrName
526 -- Not infix, with place holders for coercion and free vars
527 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
528 , fun_matches = mkMatchGroup Generated ms
529 , fun_co_fn = idHsWrapper
530 , bind_fvs = placeHolderNames
531 , fun_tick = [] }
532
533 mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)]
534 -> HsBind Name
535 -- In Name-land, with empty bind_fvs
536 mkTopFunBind origin fn ms = FunBind { fun_id = fn, fun_infix = False
537 , fun_matches = mkMatchGroupName origin ms
538 , fun_co_fn = idHsWrapper
539 , bind_fvs = emptyNameSet -- NB: closed
540 -- binding
541 , fun_tick = [] }
542
543 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
544 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
545
546 mkVarBind :: id -> LHsExpr id -> LHsBind id
547 mkVarBind var rhs = L (getLoc rhs) $
548 VarBind { var_id = var, var_rhs = rhs, var_inline = False }
549
550 mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
551 -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName
552 mkPatSynBind name details lpat dir = PatSynBind psb
553 where
554 psb = PSB{ psb_id = name
555 , psb_args = details
556 , psb_def = lpat
557 , psb_dir = dir
558 , psb_fvs = placeHolderNames }
559
560 ------------
561 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
562 -> LHsExpr RdrName -> LHsBind RdrName
563 mk_easy_FunBind loc fun pats expr
564 = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
565
566 ------------
567 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id)
568 mkMatch pats expr binds
569 = noLoc (Match Nothing (map paren pats) Nothing
570 (GRHSs (unguardedRHS noSrcSpan expr) binds))
571 where
572 paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
573 | otherwise = lp
574
575 {-
576 ************************************************************************
577 * *
578 Collecting binders
579 * *
580 ************************************************************************
581
582 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
583
584 ...
585 where
586 (x, y) = ...
587 f i j = ...
588 [a, b] = ...
589
590 it should return [x, y, f, a, b] (remember, order important).
591
592 Note [Collect binders only after renaming]
593 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
594 These functions should only be used on HsSyn *after* the renamer,
595 to return a [Name] or [Id]. Before renaming the record punning
596 and wild-card mechanism makes it hard to know what is bound.
597 So these functions should not be applied to (HsSyn RdrName)
598 -}
599
600 ----------------- Bindings --------------------------
601 collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
602 collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
603 -- No pattern synonyms here
604 collectLocalBinders (HsIPBinds _) = []
605 collectLocalBinders EmptyLocalBinds = []
606
607 collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [idL]
608 -- Collect Id binders only, or Ids + pattern synonmys, respectively
609 collectHsIdBinders = collect_hs_val_binders True
610 collectHsValBinders = collect_hs_val_binders False
611
612 collectHsBindBinders :: HsBindLR idL idR -> [idL]
613 -- Collect both Ids and pattern-synonym binders
614 collectHsBindBinders b = collect_bind False b []
615
616 collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
617 collectHsBindsBinders binds = collect_binds False binds []
618
619 collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
620 -- Same as collectHsBindsBinders, but works over a list of bindings
621 collectHsBindListBinders = foldr (collect_bind False . unLoc) []
622
623 collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [idL]
624 collect_hs_val_binders ps (ValBindsIn binds _) = collect_binds ps binds []
625 collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds
626
627 collect_out_binds :: Bool -> [(RecFlag, LHsBinds id)] -> [id]
628 collect_out_binds ps = foldr (collect_binds ps . snd) []
629
630 collect_binds :: Bool -> LHsBindsLR idL idR -> [idL] -> [idL]
631 -- Collect Ids, or Ids + patter synonyms, depending on boolean flag
632 collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds
633
634 collect_bind :: Bool -> HsBindLR idL idR -> [idL] -> [idL]
635 collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc
636 collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc
637 collect_bind _ (VarBind { var_id = f }) acc = f : acc
638 collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
639 -- I don't think we want the binders from the abe_binds
640 -- The only time we collect binders from a typechecked
641 -- binding (hence see AbsBinds) is in zonking in TcHsSyn
642 collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc =
643 if omitPatSyn then acc else ps : acc
644
645 collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
646 -- Used exclusively for the bindings of an instance decl which are all FunBinds
647 collectMethodBinders binds = foldrBag (get . unLoc) [] binds
648 where
649 get (FunBind { fun_id = f }) fs = f : fs
650 get _ fs = fs
651 -- Someone else complains about non-FunBinds
652
653 ----------------- Statements --------------------------
654 collectLStmtsBinders :: [LStmtLR idL idR body] -> [idL]
655 collectLStmtsBinders = concatMap collectLStmtBinders
656
657 collectStmtsBinders :: [StmtLR idL idR body] -> [idL]
658 collectStmtsBinders = concatMap collectStmtBinders
659
660 collectLStmtBinders :: LStmtLR idL idR body -> [idL]
661 collectLStmtBinders = collectStmtBinders . unLoc
662
663 collectStmtBinders :: StmtLR idL idR body -> [idL]
664 -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
665 collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
666 collectStmtBinders (LetStmt binds) = collectLocalBinders binds
667 collectStmtBinders (BodyStmt {}) = []
668 collectStmtBinders (LastStmt {}) = []
669 collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders
670 $ [s | ParStmtBlock ss _ _ <- xs, s <- ss]
671 collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
672 collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
673
674
675 ----------------- Patterns --------------------------
676 collectPatBinders :: LPat a -> [a]
677 collectPatBinders pat = collect_lpat pat []
678
679 collectPatsBinders :: [LPat a] -> [a]
680 collectPatsBinders pats = foldr collect_lpat [] pats
681
682 -------------
683 collect_lpat :: LPat name -> [name] -> [name]
684 collect_lpat (L _ pat) bndrs
685 = go pat
686 where
687 go (VarPat var) = var : bndrs
688 go (WildPat _) = bndrs
689 go (LazyPat pat) = collect_lpat pat bndrs
690 go (BangPat pat) = collect_lpat pat bndrs
691 go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs
692 go (ViewPat _ pat _) = collect_lpat pat bndrs
693 go (ParPat pat) = collect_lpat pat bndrs
694
695 go (ListPat pats _ _) = foldr collect_lpat bndrs pats
696 go (PArrPat pats _) = foldr collect_lpat bndrs pats
697 go (TuplePat pats _ _) = foldr collect_lpat bndrs pats
698
699 go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps)
700 go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps)
701 -- See Note [Dictionary binders in ConPatOut]
702 go (LitPat _) = bndrs
703 go (NPat _ _ _) = bndrs
704 go (NPlusKPat (L _ n) _ _ _) = n : bndrs
705
706 go (SigPatIn pat _) = collect_lpat pat bndrs
707 go (SigPatOut pat _) = collect_lpat pat bndrs
708 go (SplicePat _) = 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 :: HsValBinds RdrName -> [Located RdrName]
785 -- Collect pattern-synonym binders only, not Ids
786 -- See Note [SrcSpan for binders]
787 hsPatSynBinders (ValBindsIn binds _) = foldrBag addPatSynBndr [] binds
788 hsPatSynBinders _ = panic "hsPatSynBinders"
789
790 addPatSynBndr :: LHsBindLR idL idR -> [Located idL] -> [Located idL]
791 -- See Note [SrcSpan for binders]
792 addPatSynBndr bind pss
793 | L bind_loc (PatSynBind (PSB { psb_id = L _ n })) <- bind
794 = L bind_loc n : pss
795 | otherwise
796 = pss
797
798 -------------------
799 hsLInstDeclBinders :: Eq name => LInstDecl name -> [Located name]
800 hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))
801 = concatMap (hsDataFamInstBinders . unLoc) dfis
802 hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
803 = hsDataFamInstBinders fi
804 hsLInstDeclBinders (L _ (TyFamInstD {})) = []
805
806 -------------------
807 -- the SrcLoc returned are for the whole declarations, not just the names
808 hsDataFamInstBinders :: Eq name => DataFamInstDecl name -> [Located name]
809 hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
810 = hsDataDefnBinders defn
811 -- There can't be repeated symbols because only data instances have binders
812
813 -------------------
814 -- the SrcLoc returned are for the whole declarations, not just the names
815 hsDataDefnBinders :: Eq name => HsDataDefn name -> [Located name]
816 hsDataDefnBinders (HsDataDefn { dd_cons = cons })
817 = hsConDeclsBinders cons
818 -- See Note [Binders in family instances]
819
820 -------------------
821 hsConDeclsBinders :: forall name. (Eq name) => [LConDecl name] -> [Located name]
822 -- See hsLTyClDeclBinders for what this does
823 -- The function is boringly complicated because of the records
824 -- And since we only have equality, we have to be a little careful
825 hsConDeclsBinders cons = go id cons
826 where go :: ([Located name] -> [Located name]) -> [LConDecl name] -> [Located name]
827 go _ [] = []
828 go remSeen (r:rs) =
829 -- don't re-mangle the location of field names, because we don't
830 -- have a record of the full location of the field declaration anyway
831 case r of
832 -- remove only the first occurrence of any seen field in order to
833 -- avoid circumventing detection of duplicate fields (#9156)
834 L loc (ConDecl { con_names = names, con_details = RecCon flds }) ->
835 (map (L loc . unLoc) names) ++ r' ++ go remSeen' rs
836 where r' = remSeen (concatMap (cd_fld_names . unLoc)
837 (unLoc flds))
838 remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc) v | v <- r']
839 L loc (ConDecl { con_names = names }) ->
840 (map (L loc . unLoc) names) ++ go remSeen rs
841
842 {-
843
844 Note [SrcSpan for binders]
845 ~~~~~~~~~~~~~~~~~~~~~~~~~~
846 When extracting the (Located RdrNme) for a binder, at least for the
847 main name (the TyCon of a type declaration etc), we want to give it
848 the @SrcSpan@ of the whole /declaration/, not just the name itself
849 (which is how it appears in the syntax tree). This SrcSpan (for the
850 entire declaration) is used as the SrcSpan for the Name that is
851 finally produced, and hence for error messages. (See Trac #8607.)
852
853 Note [Binders in family instances]
854 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
855 In a type or data family instance declaration, the type
856 constructor is an *occurrence* not a binding site
857 type instance T Int = Int -> Int -- No binders
858 data instance S Bool = S1 | S2 -- Binders are S1,S2
859
860
861 ************************************************************************
862 * *
863 Collecting binders the user did not write
864 * *
865 ************************************************************************
866
867 The job of this family of functions is to run through binding sites and find the set of all Names
868 that were defined "implicitly", without being explicitly written by the user.
869
870 The main purpose is to find names introduced by record wildcards so that we can avoid
871 warning the user when they don't use those names (#4404)
872 -}
873
874 lStmtsImplicits :: [LStmtLR Name idR (Located (body idR))] -> NameSet
875 lStmtsImplicits = hs_lstmts
876 where
877 hs_lstmts :: [LStmtLR Name idR (Located (body idR))] -> NameSet
878 hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet
879
880 hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat
881 hs_stmt (LetStmt binds) = hs_local_binds binds
882 hs_stmt (BodyStmt {}) = emptyNameSet
883 hs_stmt (LastStmt {}) = emptyNameSet
884 hs_stmt (ParStmt xs _ _) = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss]
885 hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
886 hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
887
888 hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds
889 hs_local_binds (HsIPBinds _) = emptyNameSet
890 hs_local_binds EmptyLocalBinds = emptyNameSet
891
892 hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet
893 hsValBindsImplicits (ValBindsOut binds _)
894 = foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds
895 hsValBindsImplicits (ValBindsIn binds _)
896 = lhsBindsImplicits binds
897
898 lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet
899 lhsBindsImplicits = foldBag unionNameSet (lhs_bind . unLoc) emptyNameSet
900 where
901 lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
902 lhs_bind _ = emptyNameSet
903
904 lPatImplicits :: LPat Name -> NameSet
905 lPatImplicits = hs_lpat
906 where
907 hs_lpat (L _ pat) = hs_pat pat
908
909 hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSet` rest) emptyNameSet
910
911 hs_pat (LazyPat pat) = hs_lpat pat
912 hs_pat (BangPat pat) = hs_lpat pat
913 hs_pat (AsPat _ pat) = hs_lpat pat
914 hs_pat (ViewPat _ pat _) = hs_lpat pat
915 hs_pat (ParPat pat) = hs_lpat pat
916 hs_pat (ListPat pats _ _) = hs_lpats pats
917 hs_pat (PArrPat pats _) = hs_lpats pats
918 hs_pat (TuplePat pats _ _) = hs_lpats pats
919
920 hs_pat (SigPatIn pat _) = hs_lpat pat
921 hs_pat (SigPatOut pat _) = hs_lpat pat
922 hs_pat (CoPat _ pat _) = hs_pat pat
923
924 hs_pat (ConPatIn _ ps) = details ps
925 hs_pat (ConPatOut {pat_args=ps}) = details ps
926
927 hs_pat _ = emptyNameSet
928
929 details (PrefixCon ps) = hs_lpats ps
930 details (RecCon fs) = hs_lpats explicit `unionNameSet` mkNameSet (collectPatsBinders implicit)
931 where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat
932 | (i, fld) <- [0..] `zip` rec_flds fs
933 , let pat = hsRecFieldArg
934 (unLoc fld)
935 pat_explicit = maybe True (i<) (rec_dotdot fs)]
936 details (InfixCon p1 p2) = hs_lpat p1 `unionNameSet` hs_lpat p2