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