[commit: ghc] master: Improve the behaviour of warnIf (f02af79)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/f02af79e71f0383cf16b9d7c89691578ab77fa1c/ghc

>---------------------------------------------------------------

commit f02af79e71f0383cf16b9d7c89691578ab77fa1c
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Thu Apr 21 12:58:52 2016 +0100

    Improve the behaviour of warnIf
    
    Now that warnIf takes a "reason", we can test the reason
    in warnIf rather than in the caller.  Less code, and less
    risk of getting the test and the reason out of sync.


>---------------------------------------------------------------

f02af79e71f0383cf16b9d7c89691578ab77fa1c
 compiler/rename/RnNames.hs      | 17 +++++++----------
 compiler/typecheck/Inst.hs      |  5 ++---
 compiler/typecheck/TcRnMonad.hs | 15 ++++++++++-----
 3 files changed, 19 insertions(+), 18 deletions(-)

diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 24e6bca..e3bdaab 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -1272,14 +1272,12 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
         | let earlier_mods = [ mod
                              | (L _ (IEModuleContents (L _ mod))) <- ie_names ]
         , mod `elem` earlier_mods    -- Duplicate export of M
-        = do { warn_dup_exports <- woptM Opt_WarnDuplicateExports ;
-               warnIf (Reason Opt_WarnDuplicateExports) warn_dup_exports
+        = do { warnIf (Reason Opt_WarnDuplicateExports) True
                       (dupModuleExport mod) ;
                return acc }
 
         | otherwise
-        = do { warnDodgyExports <- woptM Opt_WarnDodgyExports
-             ; let { exportValid = (mod `elem` imported_modules)
+        = do { let { exportValid = (mod `elem` imported_modules)
                                 || (moduleName this_mod == mod)
                    ; gre_prs     = pickGREsModExp mod (globalRdrEnvElts rdr_env)
                    ; new_exports = map (availFromGRE . fst) gre_prs
@@ -1289,7 +1287,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
 
              ; checkErr exportValid (moduleNotImported mod)
              ; warnIf (Reason Opt_WarnDodgyExports)
-                      (warnDodgyExports && exportValid && null gre_prs)
+                      (exportValid && null gre_prs)
                       (nullModuleExport mod)
 
              ; traceRn (text "efa" <+> (ppr mod $$ ppr all_gres))
@@ -1429,11 +1427,10 @@ check_occs ie occs names  -- 'names' are the entities specifed by 'ie'
             | name == name'   -- Duplicate export
             -- But we don't want to warn if the same thing is exported
             -- by two different module exports. See ticket #4478.
-            -> do unless (dupExport_ok name ie ie') $ do
-                      warn_dup_exports <- woptM Opt_WarnDuplicateExports
-                      warnIf (Reason Opt_WarnDuplicateExports) warn_dup_exports
-                             (dupExportWarn name_occ ie ie')
-                  return occs
+            -> do { warnIf (Reason Opt_WarnDuplicateExports)
+                           (not (dupExport_ok name ie ie'))
+                           (dupExportWarn name_occ ie ie')
+                  ; return occs }
 
             | otherwise    -- Same occ name but different names: an error
             ->  do { global_env <- getGlobalRdrEnv ;
diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs
index 49f57a5..25aa3cc 100644
--- a/compiler/typecheck/Inst.hs
+++ b/compiler/typecheck/Inst.hs
@@ -640,10 +640,9 @@ newClsInst overlap_mode dfun_name tvs theta clas tys
              -- but it'll do fine
        ; oflag <- getOverlapFlag overlap_mode
        ; let inst = mkLocalInstance dfun oflag tvs' clas tys'
-       ; dflags <- getDynFlags
        ; warnIf (Reason Opt_WarnOrphans)
-             (isOrphan (is_orphan inst) && wopt Opt_WarnOrphans dflags)
-             (instOrphWarn inst)
+                (isOrphan (is_orphan inst))
+                (instOrphWarn inst)
        ; return inst }
 
 instOrphWarn :: ClsInst -> SDoc
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index 5a6ff43..91a6a57 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -724,11 +724,6 @@ checkErr :: Bool -> MsgDoc -> TcRn ()
 -- Add the error if the bool is False
 checkErr ok msg = unless ok (addErr msg)
 
--- | Display a warning if a condition is met.
-warnIf :: WarnReason -> Bool -> MsgDoc -> TcRn ()
-warnIf reason True  msg = addWarn reason msg
-warnIf _      False _   = return ()
-
 addMessages :: Messages -> TcRn ()
 addMessages msgs1
   = do { errs_var <- getErrsVar ;
@@ -1088,6 +1083,16 @@ failIfTcM True  err = failWithTcM err
 --         Warnings have no 'M' variant, nor failure
 
 -- | Display a warning if a condition is met.
+--   and the warning is enabled
+warnIf :: WarnReason -> Bool -> MsgDoc -> TcRn ()
+warnIf reason is_bad msg
+  = do { warn_on <- case reason of
+                       NoReason         -> return True
+                       Reason warn_flag -> woptM warn_flag
+       ; when (warn_on && is_bad) $
+         addWarn reason msg }
+
+-- | Display a warning if a condition is met.
 warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()
 warnTc reason warn_if_true warn_msg
   | warn_if_true = addWarnTc reason warn_msg