diff options
Diffstat (limited to 'compiler/rename')
| -rw-r--r-- | compiler/rename/RnBinds.hs | 4 | ||||
| -rw-r--r-- | compiler/rename/RnEnv.hs | 21 | ||||
| -rw-r--r-- | compiler/rename/RnNames.hs | 81 | ||||
| -rw-r--r-- | compiler/rename/RnSource.hs | 42 | ||||
| -rw-r--r-- | compiler/rename/RnTypes.hs | 2 |
5 files changed, 91 insertions, 59 deletions
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index 33a1cb447b..2f7e808cfe 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -462,7 +462,7 @@ rnBind _ bind@(PatBind { pat_lhs = pat -- or an occurrence of, a variable on the RHS ; whenWOptM Opt_WarnUnusedPatternBinds $ when (null bndrs && not is_wild_pat) $ - addWarn $ unusedPatBindWarn bind' + addWarn (Reason Opt_WarnUnusedPatternBinds) $ unusedPatBindWarn bind' ; fvs' `seq` -- See Note [Free-variable space leak] return (bind', bndrs, all_fvs) } @@ -1104,7 +1104,7 @@ rnGRHS' ctxt rnBody (GRHS guards rhs) rnBody rhs ; unless (pattern_guards_allowed || is_standard_guard guards') - (addWarn (nonStdGuardErr guards')) + (addWarn NoReason (nonStdGuardErr guards')) ; return (GRHS guards' rhs', fvs) } where diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 5d74d7c94f..0ecd85e3c7 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -743,7 +743,8 @@ lookup_demoted rdr_name dflags Just demoted_name | data_kinds -> do { whenWOptM Opt_WarnUntickedPromotedConstructors $ - addWarn (untickedPromConstrWarn demoted_name) + addWarn (Reason Opt_WarnUntickedPromotedConstructors) + (untickedPromConstrWarn demoted_name) ; return demoted_name } | otherwise -> unboundNameX WL_Any rdr_name suggest_dk } @@ -1068,7 +1069,8 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss }) -- See Note [Handling of deprecations] do { iface <- loadInterfaceForName doc name ; case lookupImpDeprec iface gre of - Just txt -> addWarn (mk_msg imp_spec txt) + Just txt -> addWarn (Reason Opt_WarnWarningsDeprecations) + (mk_msg imp_spec txt) Nothing -> return () } } | otherwise = return () @@ -1738,7 +1740,9 @@ checkShadowedOccs (global_env,local_env) get_loc_occ ns -- we don't find any GREs that are in scope qualified-only complain [] = return () - complain pp_locs = addWarnAt loc (shadowedNameWarn occ pp_locs) + complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing) + loc + (shadowedNameWarn occ pp_locs) is_shadowed_gre :: GlobalRdrElt -> RnM Bool -- Returns False for record selectors that are shadowed, when @@ -2118,7 +2122,8 @@ warnUnusedLocals names = do warnUnusedLocal :: NameEnv (FieldLabelString, Name) -> Name -> RnM () warnUnusedLocal fld_env name = when (reportable name) $ - addUnusedWarning occ (nameSrcSpan name) + addUnusedWarning Opt_WarnUnusedLocalBinds + occ (nameSrcSpan name) (text "Defined but not used") where occ = case lookupNameEnv fld_env name of @@ -2132,7 +2137,7 @@ warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is }) | otherwise = when (reportable name) (mapM_ warn is) where occ = greOccName gre - warn spec = addUnusedWarning occ span msg + warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg where span = importSpecLoc spec pp_mod = quotes (ppr (importSpecModule spec)) @@ -2154,9 +2159,9 @@ reportable name -- from Data.Tuple | otherwise = not (startsWithUnderscore (nameOccName name)) -addUnusedWarning :: OccName -> SrcSpan -> SDoc -> RnM () -addUnusedWarning occ span msg - = addWarnAt span $ +addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () +addUnusedWarning flag occ span msg + = addWarnAt (Reason flag) span $ sep [msg <> colon, nest 2 $ pprNonVarNameSpace (occNameSpace occ) <+> quotes (ppr occ)] diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index 75191adc74..70f76b9a54 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -236,7 +236,8 @@ rnImportDecl this_mod _ | implicit -> return () -- Do not bleat for implicit imports | qual_only -> return () | otherwise -> whenWOptM Opt_WarnMissingImportList $ - addWarn (missingImportListWarn imp_mod_name) + addWarn (Reason Opt_WarnMissingImportList) + (missingImportListWarn imp_mod_name) iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg) @@ -253,7 +254,8 @@ rnImportDecl this_mod -- the non-boot module depends on the compilation order, which -- is not deterministic. The hs-boot test can show this up. dflags <- getDynFlags - warnIf (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags)) + warnIf NoReason + (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags)) (warnRedundantSourceImport imp_mod_name) when (mod_safe && not (safeImportsOn dflags)) $ addErr (text "safe import can't be used as Safe Haskell isn't on!" @@ -297,7 +299,8 @@ rnImportDecl this_mod -- Complain if we import a deprecated module whenWOptM Opt_WarnWarningsDeprecations ( case (mi_warns iface) of - WarnAll txt -> addWarn $ moduleWarn imp_mod_name txt + WarnAll txt -> addWarn (Reason Opt_WarnWarningsDeprecations) + (moduleWarn imp_mod_name txt) _ -> return () ) @@ -814,11 +817,11 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) where -- Warn when importing T(..) if T was exported abstractly emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $ - addWarn (dodgyImportWarn n) + addWarn (Reason Opt_WarnDodgyImports) (dodgyImportWarn n) emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $ - addWarn (missingImportListItem ieRdr) + addWarn (Reason Opt_WarnMissingImportList) (missingImportListItem ieRdr) emit_warning BadImportW = whenWOptM Opt_WarnDodgyImports $ - addWarn (lookup_err_msg BadImport) + addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg BadImport) run_lookup :: IELookupM a -> TcRn (Maybe a) run_lookup m = case m of @@ -1262,7 +1265,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod | (L _ (IEModuleContents (L _ mod))) <- ie_names ] , mod `elem` earlier_mods -- Duplicate export of M = do { warn_dup_exports <- woptM Opt_WarnDuplicateExports ; - warnIf warn_dup_exports (dupModuleExport mod) ; + warnIf (Reason Opt_WarnDuplicateExports) warn_dup_exports + (dupModuleExport mod) ; return acc } | otherwise @@ -1276,7 +1280,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod } ; checkErr exportValid (moduleNotImported mod) - ; warnIf (warnDodgyExports && exportValid && null gre_prs) + ; warnIf (Reason Opt_WarnDodgyExports) + (warnDodgyExports && exportValid && null gre_prs) (nullModuleExport mod) ; traceRn (text "efa" <+> (ppr mod $$ ppr all_gres)) @@ -1373,7 +1378,9 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod warnDodgyExports <- woptM Opt_WarnDodgyExports when (null gres) $ if isTyConName name - then when warnDodgyExports $ addWarn (dodgyExportWarn name) + then when warnDodgyExports $ + addWarn (Reason Opt_WarnDodgyExports) + (dodgyExportWarn name) else -- This occurs when you export T(..), but -- only import T abstractly, or T is a synonym. addErr (exportItemErr ie) @@ -1416,7 +1423,8 @@ check_occs ie occs names -- 'names' are the entities specifed by 'ie' -- by two different module exports. See ticket #4478. -> do unless (dupExport_ok name ie ie') $ do warn_dup_exports <- woptM Opt_WarnDuplicateExports - warnIf warn_dup_exports (dupExportWarn name_occ ie ie') + warnIf (Reason Opt_WarnDuplicateExports) warn_dup_exports + (dupExportWarn name_occ ie ie') return occs | otherwise -- Same occ name but different names: an error @@ -1550,7 +1558,7 @@ warnUnusedImportDecls gbl_env ; traceRn (vcat [ text "Uses:" <+> ppr uses , text "Import usage" <+> ppr usage]) ; whenWOptM Opt_WarnUnusedImports $ - mapM_ (warnUnusedImport fld_env) usage + mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage ; whenGOptM Opt_D_dump_minimal_imports $ printMinimalImports usage } @@ -1570,9 +1578,15 @@ warnMissingSignatures gbl_env ; warn_pat_syns <- woptM Opt_WarnMissingPatternSynonymSignatures ; let sig_warn - | warn_only_exported = topSigWarnIfExported exports sig_ns - | warn_missing_sigs || warn_pat_syns = topSigWarn sig_ns - | otherwise = noSigWarn + | warn_only_exported + = topSigWarnIfExported Opt_WarnMissingExportedSignatures + exports sig_ns + | warn_missing_sigs + = topSigWarn Opt_WarnMissingSignatures sig_ns + | warn_pat_syns + = topSigWarn Opt_WarnMissingPatternSynonymSignatures sig_ns + | otherwise + = noSigWarn ; let binders = (if warn_pat_syns then ps_binders else []) @@ -1591,35 +1605,36 @@ type SigWarn = [(Type, Name)] -> RnM () noSigWarn :: SigWarn noSigWarn _ = return () -topSigWarnIfExported :: NameSet -> NameSet -> SigWarn -topSigWarnIfExported exported sig_ns ids - = mapM_ (topSigWarnIdIfExported exported sig_ns) ids +topSigWarnIfExported :: WarningFlag -> NameSet -> NameSet -> SigWarn +topSigWarnIfExported flag exported sig_ns ids + = mapM_ (topSigWarnIdIfExported flag exported sig_ns) ids -topSigWarnIdIfExported :: NameSet -> NameSet -> (Type, Name) -> RnM () -topSigWarnIdIfExported exported sig_ns (ty, name) +topSigWarnIdIfExported :: WarningFlag -> NameSet -> NameSet -> (Type, Name) + -> RnM () +topSigWarnIdIfExported flag exported sig_ns (ty, name) | name `elemNameSet` exported - = topSigWarnId sig_ns (ty, name) + = topSigWarnId flag sig_ns (ty, name) | otherwise = return () -topSigWarn :: NameSet -> SigWarn -topSigWarn sig_ns ids = mapM_ (topSigWarnId sig_ns) ids +topSigWarn :: WarningFlag -> NameSet -> SigWarn +topSigWarn flag sig_ns ids = mapM_ (topSigWarnId flag sig_ns) ids -topSigWarnId :: NameSet -> (Type, Name) -> RnM () +topSigWarnId :: WarningFlag -> NameSet -> (Type, Name) -> RnM () -- The NameSet is the Ids that *lack* a signature -- We have to do it this way round because there are -- lots of top-level bindings that are generated by GHC -- and that don't have signatures -topSigWarnId sig_ns (ty, name) - | name `elemNameSet` sig_ns = warnMissingSig msg (ty, name) +topSigWarnId flag sig_ns (ty, name) + | name `elemNameSet` sig_ns = warnMissingSig flag msg (ty, name) | otherwise = return () where msg = text "Top-level binding with no type signature:" -warnMissingSig :: SDoc -> (Type, Name) -> RnM () -warnMissingSig msg (ty, name) = do +warnMissingSig :: WarningFlag -> SDoc -> (Type, Name) -> RnM () +warnMissingSig flag msg (ty, name) = do tymsg <- getMsg ty - addWarnAt (getSrcSpan name) (mk_msg tymsg) + addWarnAt (Reason flag) (getSrcSpan name) (mk_msg tymsg) where mk_msg endmsg = sep [ msg, nest 2 $ pprPrefixName name <+> endmsg ] @@ -1723,9 +1738,9 @@ extendImportMap gre imp_map -- For srcSpanEnd see Note [The ImportMap] avail = availFromGRE gre -warnUnusedImport :: NameEnv (FieldLabelString, Name) -> ImportDeclUsage - -> RnM () -warnUnusedImport fld_env (L loc decl, used, unused) +warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Name) + -> ImportDeclUsage -> RnM () +warnUnusedImport flag fld_env (L loc decl, used, unused) | Just (False,L _ []) <- ideclHiding decl = return () -- Do not warn for 'import M()' @@ -1733,9 +1748,9 @@ warnUnusedImport fld_env (L loc decl, used, unused) , not (null hides) , pRELUDE_NAME == unLoc (ideclName decl) = return () -- Note [Do not warn about Prelude hiding] - | null used = addWarnAt loc msg1 -- Nothing used; drop entire decl + | null used = addWarnAt (Reason flag) loc msg1 -- Nothing used; drop entire decl | null unused = return () -- Everything imported is used; nop - | otherwise = addWarnAt loc msg2 -- Some imports are unused + | otherwise = addWarnAt (Reason flag) loc msg2 -- Some imports are unused where msg1 = vcat [pp_herald <+> quotes pp_mod <+> pp_not_used, nest 2 (text "except perhaps to import instances from" diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 4f655090c6..f3851ba770 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -500,10 +500,12 @@ checkCanonicalInstances cls poly_ty mbinds = do case mbind of FunBind { fun_id = L _ name, fun_matches = mg } | name == pureAName, isAliasMG mg == Just returnMName - -> addWarnNonCanonicalMethod1 "pure" "return" + -> addWarnNonCanonicalMethod1 + Opt_WarnNonCanonicalMonadInstances "pure" "return" | name == thenAName, isAliasMG mg == Just thenMName - -> addWarnNonCanonicalMethod1 "(*>)" "(>>)" + -> addWarnNonCanonicalMethod1 + Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)" _ -> return () @@ -512,10 +514,12 @@ checkCanonicalInstances cls poly_ty mbinds = do case mbind of FunBind { fun_id = L _ name, fun_matches = mg } | name == returnMName, isAliasMG mg /= Just pureAName - -> addWarnNonCanonicalMethod2 "return" "pure" + -> addWarnNonCanonicalMethod2 + Opt_WarnNonCanonicalMonadInstances "return" "pure" | name == thenMName, isAliasMG mg /= Just thenAName - -> addWarnNonCanonicalMethod2 "(>>)" "(*>)" + -> addWarnNonCanonicalMethod2 + Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)" _ -> return () @@ -540,7 +544,9 @@ checkCanonicalInstances cls poly_ty mbinds = do case mbind of FunBind { fun_id = L _ name, fun_matches = mg } | name == failMName, isAliasMG mg == Just failMName_preMFP - -> addWarnNonCanonicalMethod1 "fail" "Control.Monad.fail" + -> addWarnNonCanonicalMethod1 + Opt_WarnNonCanonicalMonadFailInstances "fail" + "Control.Monad.fail" _ -> return () @@ -549,8 +555,9 @@ checkCanonicalInstances cls poly_ty mbinds = do case mbind of FunBind { fun_id = L _ name, fun_matches = mg } | name == failMName_preMFP, isAliasMG mg /= Just failMName - -> addWarnNonCanonicalMethod2 "fail" - "Control.Monad.Fail.fail" + -> addWarnNonCanonicalMethod2 + Opt_WarnNonCanonicalMonadFailInstances "fail" + "Control.Monad.Fail.fail" _ -> return () | otherwise = return () @@ -574,7 +581,8 @@ checkCanonicalInstances cls poly_ty mbinds = do case mbind of FunBind { fun_id = L _ name, fun_matches = mg } | name == sappendName, isAliasMG mg == Just mappendName - -> addWarnNonCanonicalMethod1 "(<>)" "mappend" + -> addWarnNonCanonicalMethod1 + Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend" _ -> return () @@ -583,7 +591,8 @@ checkCanonicalInstances cls poly_ty mbinds = do case mbind of FunBind { fun_id = L _ name, fun_matches = mg } | name == mappendName, isAliasMG mg /= Just sappendName - -> addWarnNonCanonicalMethod2NoDefault "mappend" "(<>)" + -> addWarnNonCanonicalMethod2NoDefault + Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)" _ -> return () @@ -599,8 +608,9 @@ checkCanonicalInstances cls poly_ty mbinds = do isAliasMG _ = Nothing -- got "lhs = rhs" but expected something different - addWarnNonCanonicalMethod1 lhs rhs = do - addWarn $ vcat [ text "Noncanonical" <+> + addWarnNonCanonicalMethod1 flag lhs rhs = do + addWarn (Reason flag) $ vcat + [ text "Noncanonical" <+> quotes (text (lhs ++ " = " ++ rhs)) <+> text "definition detected" , instDeclCtxt1 poly_ty @@ -610,8 +620,9 @@ checkCanonicalInstances cls poly_ty mbinds = do ] -- expected "lhs = rhs" but got something else - addWarnNonCanonicalMethod2 lhs rhs = do - addWarn $ vcat [ text "Noncanonical" <+> + addWarnNonCanonicalMethod2 flag lhs rhs = do + addWarn (Reason flag) $ vcat + [ text "Noncanonical" <+> quotes (text lhs) <+> text "definition detected" , instDeclCtxt1 poly_ty @@ -621,8 +632,9 @@ checkCanonicalInstances cls poly_ty mbinds = do ] -- like above, but method has no default impl - addWarnNonCanonicalMethod2NoDefault lhs rhs = do - addWarn $ vcat [ text "Noncanonical" <+> + addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do + addWarn (Reason flag) $ vcat + [ text "Noncanonical" <+> quotes (text lhs) <+> text "definition detected" , instDeclCtxt1 poly_ty diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 118a32b392..7e82ddc32a 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -1409,7 +1409,7 @@ warnUnusedForAll :: SDoc -> LHsTyVarBndr Name -> FreeVars -> TcM () warnUnusedForAll in_doc (L loc tv) used_names = whenWOptM Opt_WarnUnusedForalls $ unless (hsTyVarName tv `elemNameSet` used_names) $ - addWarnAt loc $ + addWarnAt (Reason Opt_WarnUnusedForalls) loc $ vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) , in_doc ] |