[commit: ghc] wip/gadtpm: Simon says: Do not export dsPmWarn (cc0533c)

[git at git.haskell.org]

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

On branch  : wip/gadtpm
Link       : http://ghc.haskell.org/trac/ghc/changeset/cc0533c5a50b1c66ce39662c95e371d335023c5c/ghc

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

commit cc0533c5a50b1c66ce39662c95e371d335023c5c
Author: George Karachalias <george.karachalias at gmail.com>
Date:   Fri Jan 29 17:18:36 2016 +0100

    Simon says: Do not export dsPmWarn


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

cc0533c5a50b1c66ce39662c95e371d335023c5c
 compiler/deSugar/Check.hs | 60 +++++++++++++++++++++++++----------------------
 compiler/deSugar/Match.hs |  5 ++--
 2 files changed, 34 insertions(+), 31 deletions(-)

diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 786a04b..0ae5a31 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -7,8 +7,8 @@ Pattern Matching Coverage Checking.
 {-# LANGUAGE CPP, GADTs, DataKinds, KindSignatures #-}
 
 module Check (
-        -- Actual check and pretty printing
-        checkSingle, checkMatches, dsPmWarn, isAnyPmCheckEnabled,
+        -- Checking and printing
+        checkSingle, checkMatches, isAnyPmCheckEnabled,
 
         -- See Note [Type and Term Equality Propagation]
         genCaseTmCs1, genCaseTmCs2
@@ -142,12 +142,12 @@ type PmResult = ([[LPat Id]], Uncovered, [[LPat Id]])
 -}
 
 -- | Check a single pattern binding (let)
-checkSingle :: Id -> Pat Id -> DsM (Maybe PmResult)
-checkSingle var p = do
+checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat Id -> DsM ()
+checkSingle dflags ctxt var p = do
   mb_pm_res <- tryM (checkSingle' var p)
-  return $ case mb_pm_res of
-    Left  _   -> Nothing
-    Right res -> Just res
+  case mb_pm_res of
+    Left  _   -> warnPmIters dflags ctxt
+    Right res -> dsPmWarn dflags ctxt res
 
 -- | Check a single pattern binding (let)
 checkSingle' :: Id -> Pat Id -> DsM PmResult
@@ -163,12 +163,14 @@ checkSingle' var p = do
     (False, True ) -> ([], us,  m) -- inaccessible rhs
   where m = [[noLoc p]]
 
-checkMatches :: [Id] -> [LMatch Id (LHsExpr Id)] -> DsM (Maybe PmResult)
-checkMatches vars matches = do
+-- | Check a matchgroup (case, functions, etc.)
+checkMatches :: DynFlags -> DsMatchContext
+             -> [Id] -> [LMatch Id (LHsExpr Id)] -> DsM ()
+checkMatches dflags ctxt vars matches = do
   mb_pm_res <- tryM (checkMatches' vars matches)
-  return $ case mb_pm_res of
-    Left  _   -> Nothing
-    Right res -> Just res
+  case mb_pm_res of
+    Left  _   -> warnPmIters dflags ctxt
+    Right res -> dsPmWarn dflags ctxt res
 
 -- | Check a matchgroup (case, functions, etc.)
 checkMatches' :: [Id] -> [LMatch Id (LHsExpr Id)] -> DsM PmResult
@@ -1215,20 +1217,18 @@ wrapUpTmState :: TmState -> ([ComplexEq], PmVarEnv)
 wrapUpTmState (residual, (_, subst)) = (residual, flattenPmVarEnv subst)
 
 -- | Issue all the warnings (coverage, exhaustiveness, inaccessibility)
-dsPmWarn :: DynFlags -> DsMatchContext -> DsM (Maybe PmResult) -> DsM ()
-dsPmWarn dflags ctx@(DsMatchContext kind loc) mPmResult
+dsPmWarn :: DynFlags -> DsMatchContext -> PmResult -> DsM ()
+dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
   = when (flag_i || flag_u) $ do
-      mb_pm_res <- mPmResult
-      case mb_pm_res of
-        Just (redundant, uncovered, inaccessible) -> do
-          let exists_r = flag_i && notNull redundant
-              exists_i = flag_i && notNull inaccessible
-              exists_u = flag_u && notNull uncovered
-          when exists_r $ putSrcSpanDs loc (warnDs (pprEqns  redundant    rmsg))
-          when exists_i $ putSrcSpanDs loc (warnDs (pprEqns  inaccessible imsg))
-          when exists_u $ putSrcSpanDs loc (warnDs (pprEqnsU uncovered))
-        Nothing -> warnPmIters ctx
+      let exists_r = flag_i && notNull redundant
+          exists_i = flag_i && notNull inaccessible
+          exists_u = flag_u && notNull uncovered
+      when exists_r $ putSrcSpanDs loc (warnDs (pprEqns  redundant    rmsg))
+      when exists_i $ putSrcSpanDs loc (warnDs (pprEqns  inaccessible imsg))
+      when exists_u $ putSrcSpanDs loc (warnDs (pprEqnsU uncovered))
   where
+    (redundant, uncovered, inaccessible) = pm_result
+
     flag_i = wopt Opt_WarnOverlappingPatterns dflags
     flag_u = exhaustive dflags kind
 
@@ -1248,10 +1248,11 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) mPmResult
 
 -- | Issue a warning when the predefined number of iterations is exceeded
 -- for the pattern match checker
-warnPmIters :: DsMatchContext -> PmM ()
-warnPmIters (DsMatchContext kind loc) = do
-  iters <- maxPmCheckIterations <$> getDynFlags
-  putSrcSpanDs loc (warnDs (msg iters))
+warnPmIters :: DynFlags -> DsMatchContext -> PmM ()
+warnPmIters dflags (DsMatchContext kind loc)
+  = when (flag_i || flag_u) $ do
+      iters <- maxPmCheckIterations <$> getDynFlags
+      putSrcSpanDs loc (warnDs (msg iters))
   where
     ctxt   = pprMatchContext kind
     msg is = fsep [ text "Pattern match checker exceeded"
@@ -1259,6 +1260,9 @@ warnPmIters (DsMatchContext kind loc) = do
                   , text "(Use fmax-pmcheck-iterations=n"
                   , text "to set the maximun number of iterations to n)" ]
 
+    flag_i = wopt Opt_WarnOverlappingPatterns dflags
+    flag_u = exhaustive dflags kind
+
 dots :: [a] -> SDoc
 dots qs | qs `lengthExceeds` maximum_output = text "..."
         | otherwise                         = empty
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index bee454f..be089e6 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -696,8 +696,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
 
               -- See Note [Type and Term Equality Propagation]
               addTmCsDs (genCaseTmCs1 mb_scr new_vars) $
-                dsPmWarn dflags (DsMatchContext ctxt locn) $
-                  checkMatches new_vars matches
+                checkMatches dflags (DsMatchContext ctxt locn) new_vars matches
 
         ; result_expr <- handleWarnings $
                          matchEquations ctxt new_vars eqns_info rhs_ty
@@ -766,7 +765,7 @@ matchSinglePat (Var var) ctx pat ty match_result
        ; locn   <- getSrcSpanDs
        ; let pat' = getMaybeStrictPat dflags pat
        -- pattern match check warnings
-       ; dsPmWarn dflags (DsMatchContext ctx locn) (checkSingle var pat')
+       ; checkSingle dflags (DsMatchContext ctx locn) var pat'
 
        ; match [var] ty
                [EqnInfo { eqn_pats = [pat'], eqn_rhs  = match_result }] }