1{- 2 3This module contains miscellaneous functions related to renaming. 4 5-} 6{-# LANGUAGE FlexibleContexts #-} 7{-# LANGUAGE ViewPatterns #-} 8{-# LANGUAGE TypeFamilies #-} 9 10module 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 31where 32 33 34import GhcPrelude 35 36import GHC.Hs 37import RdrName 38import HscTypes 39import TcEnv 40import TcRnMonad 41import Name 42import NameSet 43import NameEnv 44import DataCon 45import SrcLoc 46import Outputable 47import Util 48import BasicTypes ( TopLevelFlag(..) ) 49import ListSetOps ( removeDups ) 50import DynFlags 51import FastString 52import Control.Monad 53import Data.List 54import Constants ( mAX_TUPLE_SIZE ) 55import qualified Data.List.NonEmpty as NE 56import qualified GHC.LanguageExtensions as LangExt 57 58{- 59********************************************************* 60* * 61\subsection{Binding} 62* * 63********************************************************* 64-} 65 66newLocalBndrRn :: Located RdrName -> RnM Name 67-- Used for non-top-level binders. These should 68-- never be qualified. 69newLocalBndrRn (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 79newLocalBndrsRn :: [Located RdrName] -> RnM [Name] 80newLocalBndrsRn = mapM newLocalBndrRn 81 82bindLocalNames :: [Name] -> RnM a -> RnM a 83bindLocalNames 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 93bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) 94bindLocalNamesFV names enclosed_scope 95 = do { (result, fvs) <- bindLocalNames names enclosed_scope 96 ; return (result, delFVs names fvs) } 97 98------------------------------------- 99 100extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) 101extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside 102 103------------------------------------- 104checkDupRdrNames :: [Located RdrName] -> RnM () 105-- Check for duplicated names in a binding group 106checkDupRdrNames 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 111checkDupNames :: [Name] -> RnM () 112-- Check for duplicated names in a binding group 113checkDupNames names = check_dup_names (filterOut isSystemName names) 114 -- See Note [Binders in Template Haskell] in Convert 115 116check_dup_names :: [Name] -> RnM () 117check_dup_names names 118 = mapM_ (dupNamesErr nameSrcSpan) dups 119 where 120 (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names 121 122--------------------- 123checkShadowedRdrNames :: [Located RdrName] -> RnM () 124checkShadowedRdrNames 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 132checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM () 133checkDupAndShadowedNames 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------------------------------------- 142checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) 143 -> (a -> (SrcSpan, OccName)) 144 -> [a] -> RnM () 145checkShadowedOccs (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 #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 #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 187addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars) 188addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside 189 ; return (res, fvs1 `plusFV` fvs2) } 190 191mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) 192mapFvRn f xs = do stuff <- mapM f xs 193 case unzip stuff of 194 (ys, fvs_s) -> return (ys, plusFVs fvs_s) 195 196mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars) 197mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs) 198mapMaybeFvRn 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 208warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () 209warnUnusedTopBinds 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 229checkUnusedRecordWildcard :: SrcSpan 230 -> FreeVars 231 -> Maybe [Name] 232 -> RnM () 233checkUnusedRecordWildcard _ _ Nothing = return () 234checkUnusedRecordWildcard loc _ (Just []) = do 235 -- Add a new warning if the .. pattern binds no variables 236 setSrcSpan loc $ warnRedundantRecordWildcard 237checkUnusedRecordWildcard 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. 251warnRedundantRecordWildcard :: RnM () 252warnRedundantRecordWildcard = 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. 268warnUnusedRecordWildcard :: [Name] -> FreeVars -> RnM () 269warnUnusedRecordWildcard 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 277warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns 278 :: [Name] -> FreeVars -> RnM () 279warnUnusedLocalBinds = check_unused Opt_WarnUnusedLocalBinds 280warnUnusedMatches = check_unused Opt_WarnUnusedMatches 281warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns 282 283check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM () 284check_unused flag bound_names used_names 285 = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names) 286 bound_names)) 287 288------------------------- 289-- Helpers 290warnUnusedGREs :: [GlobalRdrElt] -> RnM () 291warnUnusedGREs gres = mapM_ warnUnusedGRE gres 292 293warnUnused :: WarningFlag -> [Name] -> RnM () 294warnUnused flag names = do 295 fld_env <- mkFieldEnv <$> getGlobalRdrEnv 296 mapM_ (warnUnused1 flag fld_env) names 297 298warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM () 299warnUnused1 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 312warnUnusedGRE :: GlobalRdrElt -> RnM () 313warnUnusedGRE 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. 327mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name) 328mkFieldEnv 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. 337reportable :: Name -> OccName -> Bool 338reportable 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 344addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () 345addUnusedWarning flag occ span msg 346 = addWarnAt (Reason flag) span $ 347 sep [msg <> colon, 348 nest 2 $ pprNonVarNameSpace (occNameSpace occ) 349 <+> quotes (ppr occ)] 350 351unusedRecordWildcardWarning :: SDoc 352unusedRecordWildcardWarning = 353 wildcardDoc $ text "No variables bound in the record wildcard match are used" 354 355redundantWildcardWarning :: SDoc 356redundantWildcardWarning = 357 wildcardDoc $ text "Record wildcard does not bind any new variables" 358 359wildcardDoc :: SDoc -> SDoc 360wildcardDoc herald = 361 herald 362 $$ nest 2 (text "Possible fix" <> colon <+> text "omit the" 363 <+> quotes (text "..")) 364 365addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM () 366addNameClashErrRn 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 #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 406shadowedNameWarn :: OccName -> [SDoc] -> SDoc 407shadowedNameWarn 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 413unknownSubordinateErr :: SDoc -> RdrName -> SDoc 414unknownSubordinateErr doc op -- Doc is "method of class" or 415 -- "field of constructor" 416 = quotes (ppr op) <+> text "is not a (visible)" <+> doc 417 418 419dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM () 420dupNamesErr 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 429badQualBndrErr :: RdrName -> SDoc 430badQualBndrErr rdr_name 431 = text "Qualified name in binding position:" <+> ppr rdr_name 432 433typeAppErr :: String -> LHsType GhcPs -> SDoc 434typeAppErr 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 439checkTupSize :: Int -> RnM () 440checkTupSize 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. 459data HsDocContext 460 = TypeSigCtx SDoc 461 | StandaloneKindSigCtx SDoc 462 | PatCtx 463 | SpecInstSigCtx 464 | DefaultDeclCtx 465 | ForeignDeclCtx (Located RdrName) 466 | DerivDeclCtx 467 | RuleCtx FastString 468 | TyDataCtx (Located RdrName) 469 | TySynCtx (Located RdrName) 470 | TyFamilyCtx (Located RdrName) 471 | FamPatCtx (Located RdrName) -- The patterns of a type/data family instance 472 | ConDeclCtx [Located Name] 473 | ClassDeclCtx (Located RdrName) 474 | ExprWithTySigCtx 475 | TypBrCtx 476 | HsTypeCtx 477 | GHCiCtx 478 | SpliceTypeCtx (LHsType GhcPs) 479 | ClassInstanceCtx 480 | GenericCtx SDoc -- Maybe we want to use this more! 481 482withHsDocContext :: HsDocContext -> SDoc -> SDoc 483withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt 484 485inHsDocContext :: HsDocContext -> SDoc 486inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt 487 488pprHsDocContext :: HsDocContext -> SDoc 489pprHsDocContext (GenericCtx doc) = doc 490pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc 491pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc 492pprHsDocContext PatCtx = text "a pattern type-signature" 493pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma" 494pprHsDocContext DefaultDeclCtx = text "a `default' declaration" 495pprHsDocContext DerivDeclCtx = text "a deriving declaration" 496pprHsDocContext (RuleCtx name) = text "the transformation rule" <+> ftext name 497pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon) 498pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon) 499pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name) 500pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name) 501pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name) 502pprHsDocContext ExprWithTySigCtx = text "an expression type signature" 503pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type" 504pprHsDocContext HsTypeCtx = text "a type argument" 505pprHsDocContext GHCiCtx = text "GHCi input" 506pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty) 507pprHsDocContext ClassInstanceCtx = text "TcSplice.reifyInstances" 508 509pprHsDocContext (ForeignDeclCtx name) 510 = text "the foreign declaration for" <+> quotes (ppr name) 511pprHsDocContext (ConDeclCtx [name]) 512 = text "the definition of data constructor" <+> quotes (ppr name) 513pprHsDocContext (ConDeclCtx names) 514 = text "the definition of data constructors" <+> interpp'SP names 515