Print which warning-flag controls an emitted warning.wip/warning-origins

Both gcc and clang tell which warning flag a reported warning can be
controlled with, this patch makes ghc do the same. More generally, this
allows for annotated compiler output, where an optional annotation is
displayed in brackets after the severity.

Display which group enables a warning.

Add flag to show which group a warning belongs to

``-f(no-)show-warning-groups``, used to show/hide the group an emitted
warning belongs to. On by default.

Fix compilation error in ghc-api test

Reviewers: goldfire, hvr, quchen, austin, bgamari

Reviewed By: quchen, bgamari

Subscribers: goldfire, thomie

Differential Revision: https://phabricator.haskell.org/D1943

GHC Trac Issues: #10752

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 ]