9de4aacaba938745e712ad4f9c47181af67174f8
[ghc.git] / compiler / rename / RnUtils.hs
1 {-
2
3 This module contains miscellaneous functions related to renaming.
4
5 -}
6 {-# LANGUAGE FlexibleContexts #-}
7 {-# LANGUAGE ViewPatterns #-}
8 {-# LANGUAGE TypeFamilies #-}
9
10 module RnUtils (
11 checkDupRdrNames, checkShadowedRdrNames,
12 checkDupNames, checkDupAndShadowedNames, dupNamesErr,
13 checkTupSize,
14 addFvRn, mapFvRn, mapMaybeFvRn,
15 warnUnusedMatches, warnUnusedTypePatterns,
16 warnUnusedTopBinds, warnUnusedLocalBinds,
17 checkUnusedRecordWildcard,
18 mkFieldEnv,
19 unknownSubordinateErr, badQualBndrErr, typeAppErr,
20 HsDocContext(..), pprHsDocContext,
21 inHsDocContext, withHsDocContext,
22
23 newLocalBndrRn, newLocalBndrsRn,
24
25 bindLocalNames, bindLocalNamesFV,
26
27 addNameClashErrRn, extendTyVarEnvFVRn
28
29 )
30
31 where
32
33
34 import GhcPrelude
35
36 import HsSyn
37 import RdrName
38 import HscTypes
39 import TcEnv
40 import TcRnMonad
41 import Name
42 import NameSet
43 import NameEnv
44 import DataCon
45 import SrcLoc
46 import Outputable
47 import Util
48 import BasicTypes ( TopLevelFlag(..) )
49 import ListSetOps ( removeDups )
50 import DynFlags
51 import FastString
52 import Control.Monad
53 import Data.List
54 import Constants ( mAX_TUPLE_SIZE )
55 import qualified Data.List.NonEmpty as NE
56 import qualified GHC.LanguageExtensions as LangExt
57
58 {-
59 *********************************************************
60 * *
61 \subsection{Binding}
62 * *
63 *********************************************************
64 -}
65
66 newLocalBndrRn :: Located RdrName -> RnM Name
67 -- Used for non-top-level binders. These should
68 -- never be qualified.
69 newLocalBndrRn (dL->L loc rdr_name)
70 | Just name <- isExact_maybe rdr_name
71 = return name -- This happens in code generated by Template Haskell
72 -- See Note [Binders in Template Haskell] in Convert.hs
73 | otherwise
74 = do { unless (isUnqual rdr_name)
75 (addErrAt loc (badQualBndrErr rdr_name))
76 ; uniq <- newUnique
77 ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
78
79 newLocalBndrsRn :: [Located RdrName] -> RnM [Name]
80 newLocalBndrsRn = mapM newLocalBndrRn
81
82 bindLocalNames :: [Name] -> RnM a -> RnM a
83 bindLocalNames names enclosed_scope
84 = do { lcl_env <- getLclEnv
85 ; let th_level = thLevel (tcl_th_ctxt lcl_env)
86 th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)
87 [ (n, (NotTopLevel, th_level)) | n <- names ]
88 rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names
89 ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs'
90 , tcl_rdr = rdr_env' })
91 enclosed_scope }
92
93 bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
94 bindLocalNamesFV names enclosed_scope
95 = do { (result, fvs) <- bindLocalNames names enclosed_scope
96 ; return (result, delFVs names fvs) }
97
98 -------------------------------------
99
100 extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
101 extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside
102
103 -------------------------------------
104 checkDupRdrNames :: [Located RdrName] -> RnM ()
105 -- Check for duplicated names in a binding group
106 checkDupRdrNames rdr_names_w_loc
107 = mapM_ (dupNamesErr getLoc) dups
108 where
109 (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc
110
111 checkDupNames :: [Name] -> RnM ()
112 -- Check for duplicated names in a binding group
113 checkDupNames names = check_dup_names (filterOut isSystemName names)
114 -- See Note [Binders in Template Haskell] in Convert
115
116 check_dup_names :: [Name] -> RnM ()
117 check_dup_names names
118 = mapM_ (dupNamesErr nameSrcSpan) dups
119 where
120 (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names
121
122 ---------------------
123 checkShadowedRdrNames :: [Located RdrName] -> RnM ()
124 checkShadowedRdrNames loc_rdr_names
125 = do { envs <- getRdrEnvs
126 ; checkShadowedOccs envs get_loc_occ filtered_rdrs }
127 where
128 filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names
129 -- See Note [Binders in Template Haskell] in Convert
130 get_loc_occ (dL->L loc rdr) = (loc,rdrNameOcc rdr)
131
132 checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()
133 checkDupAndShadowedNames envs names
134 = do { check_dup_names filtered_names
135 ; checkShadowedOccs envs get_loc_occ filtered_names }
136 where
137 filtered_names = filterOut isSystemName names
138 -- See Note [Binders in Template Haskell] in Convert
139 get_loc_occ name = (nameSrcSpan name, nameOccName name)
140
141 -------------------------------------
142 checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv)
143 -> (a -> (SrcSpan, OccName))
144 -> [a] -> RnM ()
145 checkShadowedOccs (global_env,local_env) get_loc_occ ns
146 = whenWOptM Opt_WarnNameShadowing $
147 do { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns))
148 ; mapM_ check_shadow ns }
149 where
150 check_shadow n
151 | startsWithUnderscore occ = return () -- Do not report shadowing for "_x"
152 -- See Trac #3262
153 | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)]
154 | otherwise = do { gres' <- filterM is_shadowed_gre gres
155 ; complain (map pprNameProvenance gres') }
156 where
157 (loc,occ) = get_loc_occ n
158 mb_local = lookupLocalRdrOcc local_env occ
159 gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env
160 -- Make an Unqualified RdrName and look that up, so that
161 -- we don't find any GREs that are in scope qualified-only
162
163 complain [] = return ()
164 complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing)
165 loc
166 (shadowedNameWarn occ pp_locs)
167
168 is_shadowed_gre :: GlobalRdrElt -> RnM Bool
169 -- Returns False for record selectors that are shadowed, when
170 -- punning or wild-cards are on (cf Trac #2723)
171 is_shadowed_gre gre | isRecFldGRE gre
172 = do { dflags <- getDynFlags
173 ; return $ not (xopt LangExt.RecordPuns dflags
174 || xopt LangExt.RecordWildCards dflags) }
175 is_shadowed_gre _other = return True
176
177
178 {-
179 ************************************************************************
180 * *
181 \subsection{Free variable manipulation}
182 * *
183 ************************************************************************
184 -}
185
186 -- A useful utility
187 addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)
188 addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside
189 ; return (res, fvs1 `plusFV` fvs2) }
190
191 mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
192 mapFvRn f xs = do stuff <- mapM f xs
193 case unzip stuff of
194 (ys, fvs_s) -> return (ys, plusFVs fvs_s)
195
196 mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
197 mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs)
198 mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) }
199
200 {-
201 ************************************************************************
202 * *
203 \subsection{Envt utility functions}
204 * *
205 ************************************************************************
206 -}
207
208 warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
209 warnUnusedTopBinds gres
210 = whenWOptM Opt_WarnUnusedTopBinds
211 $ do env <- getGblEnv
212 let isBoot = tcg_src env == HsBootFile
213 let noParent gre = case gre_par gre of
214 NoParent -> True
215 _ -> False
216 -- Don't warn about unused bindings with parents in
217 -- .hs-boot files, as you are sometimes required to give
218 -- unused bindings (trac #3449).
219 -- HOWEVER, in a signature file, you are never obligated to put a
220 -- definition in the main text. Thus, if you define something
221 -- and forget to export it, we really DO want to warn.
222 gres' = if isBoot then filter noParent gres
223 else gres
224 warnUnusedGREs gres'
225
226
227 -- | Checks to see if we need to warn for -Wunused-record-wildcards or
228 -- -Wredundant-record-wildcards
229 checkUnusedRecordWildcard :: SrcSpan
230 -> FreeVars
231 -> Maybe [Name]
232 -> RnM ()
233 checkUnusedRecordWildcard _ _ Nothing = return ()
234 checkUnusedRecordWildcard loc _ (Just []) = do
235 -- Add a new warning if the .. pattern binds no variables
236 setSrcSpan loc $ warnRedundantRecordWildcard
237 checkUnusedRecordWildcard loc fvs (Just dotdot_names) =
238 setSrcSpan loc $ warnUnusedRecordWildcard dotdot_names fvs
239
240
241 -- | Produce a warning when the `..` pattern binds no new
242 -- variables.
243 --
244 -- @
245 -- data P = P { x :: Int }
246 --
247 -- foo (P{x, ..}) = x
248 -- @
249 --
250 -- The `..` here doesn't bind any variables as `x` is already bound.
251 warnRedundantRecordWildcard :: RnM ()
252 warnRedundantRecordWildcard =
253 whenWOptM Opt_WarnRedundantRecordWildcards
254 (addWarn (Reason Opt_WarnRedundantRecordWildcards)
255 redundantWildcardWarning)
256
257
258 -- | Produce a warning when no variables bound by a `..` pattern are used.
259 --
260 -- @
261 -- data P = P { x :: Int }
262 --
263 -- foo (P{..}) = ()
264 -- @
265 --
266 -- The `..` pattern binds `x` but it is not used in the RHS so we issue
267 -- a warning.
268 warnUnusedRecordWildcard :: [Name] -> FreeVars -> RnM ()
269 warnUnusedRecordWildcard ns used_names = do
270 let used = filter (`elemNameSet` used_names) ns
271 traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used)
272 warnIfFlag Opt_WarnUnusedRecordWildcards (null used)
273 unusedRecordWildcardWarning
274
275
276
277 warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns
278 :: [Name] -> FreeVars -> RnM ()
279 warnUnusedLocalBinds = check_unused Opt_WarnUnusedLocalBinds
280 warnUnusedMatches = check_unused Opt_WarnUnusedMatches
281 warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns
282
283 check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM ()
284 check_unused flag bound_names used_names
285 = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names)
286 bound_names))
287
288 -------------------------
289 -- Helpers
290 warnUnusedGREs :: [GlobalRdrElt] -> RnM ()
291 warnUnusedGREs gres = mapM_ warnUnusedGRE gres
292
293 warnUnused :: WarningFlag -> [Name] -> RnM ()
294 warnUnused flag names = do
295 fld_env <- mkFieldEnv <$> getGlobalRdrEnv
296 mapM_ (warnUnused1 flag fld_env) names
297
298 warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM ()
299 warnUnused1 flag fld_env name
300 = when (reportable name occ) $
301 addUnusedWarning flag
302 occ (nameSrcSpan name)
303 (text $ "Defined but not used" ++ opt_str)
304 where
305 occ = case lookupNameEnv fld_env name of
306 Just (fl, _) -> mkVarOccFS fl
307 Nothing -> nameOccName name
308 opt_str = case flag of
309 Opt_WarnUnusedTypePatterns -> " on the right hand side"
310 _ -> ""
311
312 warnUnusedGRE :: GlobalRdrElt -> RnM ()
313 warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })
314 | lcl = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv
315 warnUnused1 Opt_WarnUnusedTopBinds fld_env name
316 | otherwise = when (reportable name occ) (mapM_ warn is)
317 where
318 occ = greOccName gre
319 warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg
320 where
321 span = importSpecLoc spec
322 pp_mod = quotes (ppr (importSpecModule spec))
323 msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used")
324
325 -- | Make a map from selector names to field labels and parent tycon
326 -- names, to be used when reporting unused record fields.
327 mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name)
328 mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre)))
329 | gres <- occEnvElts rdr_env
330 , gre <- gres
331 , Just lbl <- [greLabel gre]
332 ]
333
334 -- | Should we report the fact that this 'Name' is unused? The
335 -- 'OccName' may differ from 'nameOccName' due to
336 -- DuplicateRecordFields.
337 reportable :: Name -> OccName -> Bool
338 reportable name occ
339 | isWiredInName name = False -- Don't report unused wired-in names
340 -- Otherwise we get a zillion warnings
341 -- from Data.Tuple
342 | otherwise = not (startsWithUnderscore occ)
343
344 addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM ()
345 addUnusedWarning flag occ span msg
346 = addWarnAt (Reason flag) span $
347 sep [msg <> colon,
348 nest 2 $ pprNonVarNameSpace (occNameSpace occ)
349 <+> quotes (ppr occ)]
350
351 unusedRecordWildcardWarning :: SDoc
352 unusedRecordWildcardWarning =
353 wildcardDoc $ text "No variables bound in the record wildcard match are used"
354
355 redundantWildcardWarning :: SDoc
356 redundantWildcardWarning =
357 wildcardDoc $ text "Record wildcard does not bind any new variables"
358
359 wildcardDoc :: SDoc -> SDoc
360 wildcardDoc herald =
361 herald
362 $$ nest 2 (text "Possible fix" <> colon <+> text "omit the"
363 <+> quotes (text ".."))
364
365 addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()
366 addNameClashErrRn rdr_name gres
367 | all isLocalGRE gres && not (all isRecFldGRE gres)
368 -- If there are two or more *local* defns, we'll have reported
369 = return () -- that already, and we don't want an error cascade
370 | otherwise
371 = addErr (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name)
372 , text "It could refer to"
373 , nest 3 (vcat (msg1 : msgs)) ])
374 where
375 (np1:nps) = gres
376 msg1 = text "either" <+> ppr_gre np1
377 msgs = [text " or" <+> ppr_gre np | np <- nps]
378 ppr_gre gre = sep [ pp_gre_name gre <> comma
379 , pprNameProvenance gre]
380
381 -- When printing the name, take care to qualify it in the same
382 -- way as the provenance reported by pprNameProvenance, namely
383 -- the head of 'gre_imp'. Otherwise we get confusing reports like
384 -- Ambiguous occurrence ‘null’
385 -- It could refer to either ‘T15487a.null’,
386 -- imported from ‘Prelude’ at T15487.hs:1:8-13
387 -- or ...
388 -- See Trac #15487
389 pp_gre_name gre@(GRE { gre_name = name, gre_par = parent
390 , gre_lcl = lcl, gre_imp = iss })
391 | FldParent { par_lbl = Just lbl } <- parent
392 = text "the field" <+> quotes (ppr lbl)
393 | otherwise
394 = quotes (pp_qual <> dot <> ppr (nameOccName name))
395 where
396 pp_qual | lcl
397 = ppr (nameModule name)
398 | imp : _ <- iss -- This 'imp' is the one that
399 -- pprNameProvenance chooses
400 , ImpDeclSpec { is_as = mod } <- is_decl imp
401 = ppr mod
402 | otherwise
403 = pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss)
404 -- Invariant: either 'lcl' is True or 'iss' is non-empty
405
406 shadowedNameWarn :: OccName -> [SDoc] -> SDoc
407 shadowedNameWarn occ shadowed_locs
408 = sep [text "This binding for" <+> quotes (ppr occ)
409 <+> text "shadows the existing binding" <> plural shadowed_locs,
410 nest 2 (vcat shadowed_locs)]
411
412
413 unknownSubordinateErr :: SDoc -> RdrName -> SDoc
414 unknownSubordinateErr doc op -- Doc is "method of class" or
415 -- "field of constructor"
416 = quotes (ppr op) <+> text "is not a (visible)" <+> doc
417
418
419 dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM ()
420 dupNamesErr get_loc names
421 = addErrAt big_loc $
422 vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)),
423 locations]
424 where
425 locs = map get_loc (NE.toList names)
426 big_loc = foldr1 combineSrcSpans locs
427 locations = text "Bound at:" <+> vcat (map ppr (sort locs))
428
429 badQualBndrErr :: RdrName -> SDoc
430 badQualBndrErr rdr_name
431 = text "Qualified name in binding position:" <+> ppr rdr_name
432
433 typeAppErr :: String -> LHsType GhcPs -> SDoc
434 typeAppErr what (L _ k)
435 = hang (text "Illegal visible" <+> text what <+> text "application"
436 <+> quotes (char '@' <> ppr k))
437 2 (text "Perhaps you intended to use TypeApplications")
438
439 checkTupSize :: Int -> RnM ()
440 checkTupSize tup_size
441 | tup_size <= mAX_TUPLE_SIZE
442 = return ()
443 | otherwise
444 = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"),
445 nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),
446 nest 2 (text "Workaround: use nested tuples or define a data type")])
447
448
449 {-
450 ************************************************************************
451 * *
452 \subsection{Contexts for renaming errors}
453 * *
454 ************************************************************************
455 -}
456
457 -- AZ:TODO: Change these all to be Name instead of RdrName.
458 -- Merge TcType.UserTypeContext in to it.
459 data HsDocContext
460 = TypeSigCtx SDoc
461 | PatCtx
462 | SpecInstSigCtx
463 | DefaultDeclCtx
464 | ForeignDeclCtx (Located RdrName)
465 | DerivDeclCtx
466 | RuleCtx FastString
467 | TyDataCtx (Located RdrName)
468 | TySynCtx (Located RdrName)
469 | TyFamilyCtx (Located RdrName)
470 | FamPatCtx (Located RdrName) -- The patterns of a type/data family instance
471 | ConDeclCtx [Located Name]
472 | ClassDeclCtx (Located RdrName)
473 | ExprWithTySigCtx
474 | TypBrCtx
475 | HsTypeCtx
476 | GHCiCtx
477 | SpliceTypeCtx (LHsType GhcPs)
478 | ClassInstanceCtx
479 | GenericCtx SDoc -- Maybe we want to use this more!
480
481 withHsDocContext :: HsDocContext -> SDoc -> SDoc
482 withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt
483
484 inHsDocContext :: HsDocContext -> SDoc
485 inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt
486
487 pprHsDocContext :: HsDocContext -> SDoc
488 pprHsDocContext (GenericCtx doc) = doc
489 pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc
490 pprHsDocContext PatCtx = text "a pattern type-signature"
491 pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma"
492 pprHsDocContext DefaultDeclCtx = text "a `default' declaration"
493 pprHsDocContext DerivDeclCtx = text "a deriving declaration"
494 pprHsDocContext (RuleCtx name) = text "the transformation rule" <+> ftext name
495 pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon)
496 pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon)
497 pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name)
498 pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name)
499 pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name)
500 pprHsDocContext ExprWithTySigCtx = text "an expression type signature"
501 pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type"
502 pprHsDocContext HsTypeCtx = text "a type argument"
503 pprHsDocContext GHCiCtx = text "GHCi input"
504 pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty)
505 pprHsDocContext ClassInstanceCtx = text "TcSplice.reifyInstances"
506
507 pprHsDocContext (ForeignDeclCtx name)
508 = text "the foreign declaration for" <+> quotes (ppr name)
509 pprHsDocContext (ConDeclCtx [name])
510 = text "the definition of data constructor" <+> quotes (ppr name)
511 pprHsDocContext (ConDeclCtx names)
512 = text "the definition of data constructors" <+> interpp'SP names