- Discard default monad fail alternatives that are spuriously generated

- Make sure we check for generated loc span for checking if the (>>) is user written or expanded for /do/ purposes

8 files changed, 56 insertions, 35 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 00ce4040b1..4314141811 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -1114,9 +1114,9 @@ data HsExpansion orig expanded
 -- | Just print the original expression (the @a@) with the expanded version (the @b@)
 instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where
   ppr (HsExpanded orig expanded)
-    -- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
-    --            (ppr orig)
-    = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded)
+    = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
+               (ppr orig)
+    -- = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded)
 
 
 {-
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 6905d9c349..c7dd41586e 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -39,7 +39,7 @@ module GHC.Hs.Pat (
 
         mkPrefixConPat, mkCharLitPat, mkNilPat,
 
-        isSimplePat,
+        isSimplePat, isPatSyn,
         looksLazyPatBind,
         isBangedLPat,
         gParPat, patNeedsParens, parenthesizePat,
@@ -617,6 +617,10 @@ isSimplePat p = case unLoc p of
   VarPat _ x -> Just (unLoc x)
   _ -> Nothing
 
+isPatSyn :: LPat GhcTc -> Bool
+isPatSyn (L _ (ConPat {pat_con = L _ (PatSynCon{})})) = True
+isPatSyn _ = False
+
 
 {- Note [Unboxed sum patterns aren't irrefutable]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index cd54f2e8ab..88704a9e1e 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -858,31 +858,27 @@ warnDiscardedDoBindings rhs rhs_ty
 
 warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM ()
 warnUnusedBindValue fun arg arg_ty
-  | Just (SrcSpanAnn _ l, (L (SrcSpanAnn _ loc) f)) <- fish_var fun
-  , is_gen_then f
-  -- , isNoSrcSpan l
+  | Just (l, f) <- fish_var fun
+  , f `hasKey` thenMClassOpKey -- it is a (>>)
+  , isGeneratedSrcSpan l       -- it is compiler generated
   = do tracePm "warnUnusedBindValue" (vcat [ text "fun" <+> ppr fun
-                                           , text "arg" <+> ppr arg
-                                           , text "arg_ty" <+> ppr arg_ty
-                                           , text "f" <+> ppr f <+> ppr (is_gen_then f)
-                                           , text "l" <+> ppr (isNoSrcSpan l) <+> ppr (isNoSrcSpan loc)
+                                           , text "loc" <+> ppr l
+                                           , text "locGen?" <+> ppr (isGeneratedSrcSpan l)
+                                           , text "noLoc?" <+> ppr (isNoSrcSpan l)
                                            ])
        warnDiscardedDoBindings arg arg_ty
   where
     -- retrieve the location info and the head of the application
-    fish_var :: LHsExpr GhcTc -> Maybe (SrcSpanAnnA , LIdP GhcTc)
-    fish_var (L l (HsVar _ id)) = return (l, id)
-    fish_var (L _ (PopSrcSpan e)) = pprPanic "warnUnusedBindValue" (ppr e)
+    -- It is important that we /do not/ look through HsApp to avoid
+    -- generating duplicate warnings
+    fish_var :: LHsExpr GhcTc -> Maybe (SrcSpan , Id)
+    fish_var (L l (HsVar _ id)) = return (locA l, unLoc id)
     fish_var (L _ (HsAppType _ e _ _)) = fish_var e
     fish_var (L l (XExpr (WrapExpr (HsWrap _ e)))) = do (l, e') <- fish_var (L l e)
                                                         return (l, e')
     fish_var (L l (XExpr (ExpansionExpr (HsExpanded _ e)))) = fish_var (L l e)
     fish_var _ = Nothing
 
-    -- is this id a compiler generated (>>) with expanded do
-    is_gen_then :: Id -> Bool
-    is_gen_then f = f `hasKey` thenMClassOpKey
-
 warnUnusedBindValue _ _ _  = return ()
 
 
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index 07c552b56a..a0e32c56d3 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -227,7 +227,7 @@ match (v:vs) ty eqns    -- Eqns *can* be empty
     match_groups [] = matchEmpty v ty
     match_groups (g:gs) = mapM match_group $ g :| gs
 
-    match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM (MatchResult CoreExpr)
+    match_group :: NonEmpty (PatGroup, EquationInfo) -> DsM (MatchResult CoreExpr)
     match_group eqns@((group,_) :| _)
         = case group of
             PgCon {}  -> matchConFamily  vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns'])
@@ -767,12 +767,15 @@ one pattern, and match simply only accepts one pattern.
 JJQC 30-Nov-1997
 -}
 
-matchWrapper ctxt scrs (MG { mg_alts = L _ matches
+matchWrapper ctxt scrs (MG { mg_alts = L _ matches'
                            , mg_ext = MatchGroupTc arg_tys rhs_ty origin
                            })
   = do  { dflags <- getDynFlags
         ; locn   <- getSrcSpanDs
-
+        ; let matches = if any (is_pat_syn_match origin) matches'
+                        then filter (non_wc origin) matches' -- filter out the wild pattern fail alternatives that
+                                                             -- generate spurious overlapping warnings
+                        else matches'
         ; new_vars    <- case matches of
                            []    -> newSysLocalsDs arg_tys
                            (m:_) ->
@@ -827,7 +830,13 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
                       $ NEL.nonEmpty
                       $ replicate (length (grhssGRHSs m)) initNablas
 
-
+    is_pat_syn_match :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool
+    is_pat_syn_match Generated (L _ (Match _ _ [l_pat] _)) = isPatSyn l_pat
+    is_pat_syn_match _ _ = False
+    non_wc :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool
+    non_wc Generated (L _ (Match _ _ ([L _ (WildPat _)]) _)) = False
+    non_wc _ _ = True
+    
 matchEquations  :: HsMatchContext GhcRn
                 -> [MatchId] -> [EquationInfo] -> Type
                 -> DsM CoreExpr
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index 1edcde6924..06b91888db 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -91,7 +91,7 @@ import GHC.Unit.Module
 import GHC.Unit.Module.ModGuts
 
 import GHC.Types.Name.Reader
-import GHC.Types.Basic ( Origin )
+import GHC.Types.Basic ( Origin (..) )
 import GHC.Types.SourceFile
 import GHC.Types.Id
 import GHC.Types.Var (EvId)
diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs
index 818ec4e991..9bf2aab406 100644
--- a/compiler/GHC/Tc/Gen/App.hs
+++ b/compiler/GHC/Tc/Gen/App.hs
@@ -325,7 +325,9 @@ tcApp rn_expr exp_res_ty
   | (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr
   = do { traceTc "tcApp {" $
            vcat [ text "rn_fun:" <+> ppr rn_fun
-                , text "rn_args:" <+> ppr rn_args ]
+                , text "rn_args:" <+> ppr rn_args
+                , text "fun_ctxt:" <+> ppr fun_ctxt <+> ppr (appCtxtLoc fun_ctxt)
+                ]
 
        ; (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args
 
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index d17207dc6b..3ac400bc28 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -1383,17 +1383,16 @@ mk_failable_lexpr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> Tc
 mk_failable_lexpr_tcm pat lexpr fail_op =
   do { tc_env <- getGblEnv
      ; is_strict <- xoptM LangExt.Strict
-     ; traceTc "mk_fail_lexpr_tcm" (vcat [ppr pat
+     ; traceTc "mk_fail_lexpr_tcm" (vcat [ ppr pat
                                          , ppr $ isIrrefutableHsPatRn tc_env is_strict pat
                                          ])
 
      ; if isIrrefutableHsPatRn tc_env is_strict pat
-          -- don't decorate with fail statement if the pattern is irrefutable
-          -- pattern syns always get a fail block while desugaring so skip
+          -- don't decorate with fail statement if
+          -- 1) the pattern is irrefutable
        then return $ mkHsLam [pat] (noLocA (PopSrcSpan lexpr))
        else mk_fail_lexpr pat lexpr fail_op
      }
-  where
 
 -- makes the fail block
 -- TODO: check the discussion around MonadFail.fail type signature.
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index ba0e682bb1..d95d1e780e 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -1623,9 +1623,9 @@ checkGADT conlike ex_tvs arg_tys = \case
     has_existentials :: Bool
     has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs
 
-
+-- | Very similar to GHC.Tc.Pat.isIrrefutableHsPat, but doesn't depend on the
 isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> Bool
-isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat = goL pat
+isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict = goL
   where
     goL :: LPat GhcRn -> Bool
     goL = go . unLoc
@@ -1649,11 +1649,22 @@ isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat =
 
     go (ConPat
         { pat_con  = L _ dcName
-        , pat_args = details }) = case lookupTypeEnv type_env dcName of
-                                    Just (ATyCon con) ->
-                                      isJust (tyConSingleDataCon_maybe con)
-                                      && all goL (hsConPatArgs details)
-                                    _ -> False -- conservative.
+        , pat_args = details }) =
+      case lookupTypeEnv type_env dcName of
+        Just (ATyCon tycon) ->
+          (isJust (tyConSingleDataCon_maybe tycon)
+            || isNewTyCon tycon)
+          && all goL (hsConPatArgs details)
+        Just id@(AnId _) -> pprPanic "isIrrefutableHsPatRn AnId" (ppr id)
+        Just (AConLike cl) -> case cl of
+                                   RealDataCon dc -> let tycon = dataConTyCon dc in
+                                     (isJust (tyConSingleDataCon_maybe tycon)
+                                       || isNewTyCon tycon)
+                                     && all goL (hsConPatArgs details)
+                                   PatSynCon _ -> False -- conservative
+
+        Just ax@(ACoAxiom _) -> pprPanic "isIrrefutableHsPatRn ACoAxiom" (ppr ax)
+        _ -> False -- conservative.
     go (LitPat {})         = False
     go (NPat {})           = False
     go (NPlusKPat {})      = False