Improve exhaustive checking for guards in pattern bindings and MultiIf.

Previously we didn't do exhaustive checking on MultiIf expressions
and guards in pattern bindings.

We can construct the `LMatch` directly from GRHSs or [LHsExpr]
(MultiIf's alts) then feed it to checkMatches, without construct the
MatchGroup and using function `matchWrapper`.

Signed-off-by: HE, Tao <sighingnow@gmail.com>

Test Plan: make test TEST="T14773a T14773b"

Reviewers: bgamari, RyanGlScott, simonpj

Reviewed By: bgamari, simonpj

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #14773

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

11 files changed, 91 insertions, 16 deletions

diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index d35615ca86..7e52e469eb 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -9,7 +9,7 @@ Pattern Matching Coverage Checking.
 
 module Check (
         -- Checking and printing
-        checkSingle, checkMatches, isAnyPmCheckEnabled,
+        checkSingle, checkMatches, checkGuardMatches, isAnyPmCheckEnabled,
 
         -- See Note [Type and Term Equality Propagation]
         genCaseTmCs1, genCaseTmCs2,
@@ -52,7 +52,7 @@ import TyCoRep
 import Type
 import UniqSupply
 import DsGRHSs       (isTrueLHsExpr)
-import Maybes        ( expectJust )
+import Maybes        (expectJust)
 
 import Data.List     (find)
 import Data.Maybe    (isJust, fromMaybe)
@@ -342,6 +342,21 @@ checkSingle' locn var p = do
     (NotCovered, Diverged )   -> PmResult prov [] us' m  -- inaccessible rhs
   where m = [L locn [L locn p]]
 
+-- | Exhaustive for guard matches, is used for guards in pattern bindings and
+-- in @MultiIf@ expressions.
+checkGuardMatches :: HsMatchContext Name          -- Match context
+                  -> GRHSs GhcTc (LHsExpr GhcTc)  -- Guarded RHSs
+                  -> DsM ()
+checkGuardMatches hs_ctx guards@(GRHSs grhss _) = do
+    dflags <- getDynFlags
+    let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)
+        dsMatchContext = DsMatchContext hs_ctx combinedLoc
+        match = L combinedLoc $
+                  Match { m_ctxt = hs_ctx
+                        , m_pats = []
+                        , m_grhss = guards }
+    checkMatches dflags dsMatchContext [] [match]
+
 -- | Check a matchgroup (case, functions, etc.)
 checkMatches :: DynFlags -> DsMatchContext
              -> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM ()
@@ -368,7 +383,7 @@ checkMatches' vars matches
   | otherwise = do
       liftD resetPmIterDs -- set the iter-no to zero
       missing    <- mkInitialUncovered vars
-      tracePm "checkMatches: missing" (vcat (map pprValVecDebug missing))
+      tracePm "checkMatches': missing" (vcat (map pprValVecDebug missing))
       (prov, rs,us,ds) <- go matches missing
       return $ PmResult {
                    pmresultProvenance   = prov
@@ -1893,9 +1908,10 @@ exhaustive  dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag
 exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag
 exhaustiveWarningFlag (FunRhs {})   = Just Opt_WarnIncompletePatterns
 exhaustiveWarningFlag CaseAlt       = Just Opt_WarnIncompletePatterns
-exhaustiveWarningFlag IfAlt         = Nothing
+exhaustiveWarningFlag IfAlt         = Just Opt_WarnIncompletePatterns
 exhaustiveWarningFlag LambdaExpr    = Just Opt_WarnIncompleteUniPatterns
 exhaustiveWarningFlag PatBindRhs    = Just Opt_WarnIncompleteUniPatterns
+exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns
 exhaustiveWarningFlag ProcExpr      = Just Opt_WarnIncompleteUniPatterns
 exhaustiveWarningFlag RecUpd        = Just Opt_WarnIncompletePatternsRecUpd
 exhaustiveWarningFlag ThPatSplice   = Nothing
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index e912a369b3..3a736a5e6c 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -27,6 +27,7 @@ import {-# SOURCE #-}   Match( matchWrapper )
 import DsMonad
 import DsGRHSs
 import DsUtils
+import Check ( checkGuardMatches )
 
 import HsSyn            -- lots of things
 import CoreSyn          -- lots of things
@@ -165,6 +166,7 @@ dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
                          , pat_rhs_ty = ty
                          , pat_ticks = (rhs_tick, var_ticks) })
   = do  { body_expr <- dsGuarded grhss ty
+        ; checkGuardMatches PatBindGuards grhss
         ; let body' = mkOptTickBox rhs_tick body_expr
               pat'  = decideBangHood dflags pat
         ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body'
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 0b439a14b2..17cbcab7a6 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -24,6 +24,7 @@ import DsListComp
 import DsUtils
 import DsArrows
 import DsMonad
+import Check ( checkGuardMatches )
 import Name
 import NameEnv
 import FamInstEnv( topNormaliseType )
@@ -203,6 +204,7 @@ dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
   =     -- let C x# y# = rhs in body
         -- ==> case rhs of C x# y# -> body
     do { rhs <- dsGuarded grhss ty
+       ; checkGuardMatches PatBindGuards grhss
        ; let upat = unLoc pat
              eqn = EqnInfo { eqn_pats = [upat],
                              eqn_rhs = cantFailMatchResult body }
@@ -437,6 +439,7 @@ ds_expr _ (HsMultiIf res_ty alts)
   | otherwise
   = do { match_result <- liftM (foldr1 combineMatchResults)
                                (mapM (dsGRHS IfAlt res_ty) alts)
+       ; checkGuardMatches IfAlt (GRHSs alts (noLoc emptyLocalBinds))
        ; error_expr   <- mkErrorExpr
        ; extractMatchResult match_result error_expr }
   where
diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs
index d521f537e5..e4127ad97f 100644
--- a/compiler/deSugar/DsGRHSs.hs
+++ b/compiler/deSugar/DsGRHSs.hs
@@ -33,7 +33,7 @@ import SrcLoc
 import Outputable
 
 {-
-@dsGuarded@ is used for both @case@ expressions and pattern bindings.
+@dsGuarded@ is used for pattern bindings.
 It desugars:
 \begin{verbatim}
         | g1 -> e1
@@ -46,7 +46,6 @@ necessary.  The type argument gives the type of the @ei@.
 -}
 
 dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr
-
 dsGuarded grhss rhs_ty = do
     match_result <- dsGRHSs PatBindRhs grhss rhs_ty
     error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 1c7340d216..925967271f 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -1564,8 +1564,10 @@ pprMatch match
 
             LambdaExpr -> (char '\\', m_pats match)
 
-            _  -> ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 )
-                  (ppr pat1, [])        -- No parens around the single pat
+            _  -> if null (m_pats match)
+                     then (empty, [])
+                     else ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 )
+                          (ppr pat1, [])        -- No parens around the single pat
 
     (pat1:pats1) = m_pats match
     (pat2:pats2) = pats1
@@ -2411,6 +2413,9 @@ data HsMatchContext id -- Not an extensible tag
   | IfAlt                       -- ^Guards of a multi-way if alternative
   | ProcExpr                    -- ^Patterns of a proc
   | PatBindRhs                  -- ^A pattern binding  eg [y] <- e = e
+  | PatBindGuards               -- ^Guards of pattern bindings, e.g.,
+                                --    (Just b) | Just _ <- x = e
+                                --             | otherwise   = e'
 
   | RecUpd                      -- ^Record update [used only in DsExpr to
                                 --    tell matchWrapper what sort of
@@ -2432,6 +2437,7 @@ instance OutputableBndr id => Outputable (HsMatchContext id) where
   ppr IfAlt                 = text "IfAlt"
   ppr ProcExpr              = text "ProcExpr"
   ppr PatBindRhs            = text "PatBindRhs"
+  ppr PatBindGuards         = text "PatBindGuards"
   ppr RecUpd                = text "RecUpd"
   ppr (StmtCtxt _)          = text "StmtCtxt _"
   ppr ThPatSplice           = text "ThPatSplice"
@@ -2483,14 +2489,15 @@ isMonadFailStmtContext (TransStmtCtxt ctxt) = isMonadFailStmtContext ctxt
 isMonadFailStmtContext _ = False -- ListComp, PArrComp, PatGuard, ArrowExpr
 
 matchSeparator :: HsMatchContext id -> SDoc
-matchSeparator (FunRhs {})  = text "="
-matchSeparator CaseAlt      = text "->"
-matchSeparator IfAlt        = text "->"
-matchSeparator LambdaExpr   = text "->"
-matchSeparator ProcExpr     = text "->"
-matchSeparator PatBindRhs   = text "="
-matchSeparator (StmtCtxt _) = text "<-"
-matchSeparator RecUpd       = text "=" -- This can be printed by the pattern
+matchSeparator (FunRhs {})   = text "="
+matchSeparator CaseAlt       = text "->"
+matchSeparator IfAlt         = text "->"
+matchSeparator LambdaExpr    = text "->"
+matchSeparator ProcExpr      = text "->"
+matchSeparator PatBindRhs    = text "="
+matchSeparator PatBindGuards = text "="
+matchSeparator (StmtCtxt _)  = text "<-"
+matchSeparator RecUpd        = text "=" -- This can be printed by the pattern
                                        -- match checker trace
 matchSeparator ThPatSplice  = panic "unused"
 matchSeparator ThPatQuote   = panic "unused"
@@ -2517,6 +2524,7 @@ pprMatchContextNoun RecUpd          = text "record-update construct"
 pprMatchContextNoun ThPatSplice     = text "Template Haskell pattern splice"
 pprMatchContextNoun ThPatQuote      = text "Template Haskell pattern quotation"
 pprMatchContextNoun PatBindRhs      = text "pattern binding"
+pprMatchContextNoun PatBindGuards   = text "pattern binding guards"
 pprMatchContextNoun LambdaExpr      = text "lambda abstraction"
 pprMatchContextNoun ProcExpr        = text "arrow abstraction"
 pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"
@@ -2571,6 +2579,7 @@ matchContextErrString (FunRhs{mc_fun=L _ fun})   = text "function" <+> ppr fun
 matchContextErrString CaseAlt                    = text "case"
 matchContextErrString IfAlt                      = text "multi-way if"
 matchContextErrString PatBindRhs                 = text "pattern binding"
+matchContextErrString PatBindGuards              = text "pattern binding guards"
 matchContextErrString RecUpd                     = text "record update"
 matchContextErrString LambdaExpr                 = text "lambda"
 matchContextErrString ProcExpr                   = text "proc"
diff --git a/docs/users_guide/8.6.1-notes.rst b/docs/users_guide/8.6.1-notes.rst
index 70c3b0c10d..f5f2a5a341 100644
--- a/docs/users_guide/8.6.1-notes.rst
+++ b/docs/users_guide/8.6.1-notes.rst
@@ -31,6 +31,22 @@ Language
   The grammar is invalid in Haskell2010. Previously it could be compiled successfully
   without ``GADTs``. As of GHC 8.6.1, this is a parse error.
 
+- Incomplete patterns warning :ghc-flag:`-Wincomplete-patterns` is extended to
+  guards in pattern bindings and ``if`` alternatives of :extension:`MultiWayIf`.
+  For instance, consider the following, ::
+
+      foo :: Bool -> Int
+      foo b = if | b -> 1
+
+  In GHC 8.6.1, it will raise the warning: ::
+
+      <interactive>:2:12: warning: [-Wincomplete-patterns]
+          Pattern match(es) are non-exhaustive
+          In a multi-way if alternative:
+              Guards do not cover entire pattern space
+
+  See :ghc-ticket:`14773`.
+
 Compiler
 ~~~~~~~~
 
diff --git a/testsuite/tests/deSugar/should_compile/T14773a.hs b/testsuite/tests/deSugar/should_compile/T14773a.hs
new file mode 100644
index 0000000000..6d1e9fca5d
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T14773a.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE MultiWayIf #-}
+
+module T14773a where
+
+foo :: Bool -> Int
+foo b = if | b -> 1
+
+bar :: Bool -> Int
+bar b = if | b         -> 1
+           | otherwise -> 2
diff --git a/testsuite/tests/deSugar/should_compile/T14773a.stderr b/testsuite/tests/deSugar/should_compile/T14773a.stderr
new file mode 100644
index 0000000000..49d1ef05fc
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T14773a.stderr
@@ -0,0 +1,5 @@
+
+T14773a.hs:6:12: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In a multi-way if alternative:
+        Guards do not cover entire pattern space
diff --git a/testsuite/tests/deSugar/should_compile/T14773b.hs b/testsuite/tests/deSugar/should_compile/T14773b.hs
new file mode 100644
index 0000000000..d11bbfe5d5
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T14773b.hs
@@ -0,0 +1,8 @@
+module T14773b where
+
+b :: Bool
+(Just b) | False = Nothing
+
+c :: Bool
+(Just c) | False = Nothing
+         | True = Just True
diff --git a/testsuite/tests/deSugar/should_compile/T14773b.stderr b/testsuite/tests/deSugar/should_compile/T14773b.stderr
new file mode 100644
index 0000000000..557b10b8f0
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T14773b.stderr
@@ -0,0 +1,5 @@
+
+T14773b.hs:4:10: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In a pattern binding guards:
+        Guards do not cover entire pattern space
diff --git a/testsuite/tests/deSugar/should_compile/all.T b/testsuite/tests/deSugar/should_compile/all.T
index fe6535ea3f..2608b7d245 100644
--- a/testsuite/tests/deSugar/should_compile/all.T
+++ b/testsuite/tests/deSugar/should_compile/all.T
@@ -100,3 +100,5 @@ test('T13290', normal, compile, [''])
 test('T13257', normal, compile, [''])
 test('T13870', normal, compile, [''])
 test('T14135', normal, compile, [''])
+test('T14773a', normal, compile, ['-Wincomplete-patterns'])
+test('T14773b', normal, compile, ['-Wincomplete-patterns'])