[Git][ghc/ghc][wip/T24552] Fix for #24552 (see testcase T24552)

[Apoorv Ingle (@ani)]

Apoorv Ingle pushed to branch wip/T24552 at Glasgow Haskell Compiler / GHC


Commits:
04d319c5 by Apoorv Ingle at 2024-03-19T10:38:44-05:00
Fix for #24552 (see testcase T24552)

Fixes for a bug in desugaring pattern synonyms matches. It now matches the expected semantics. The desugaring for match via `matchWrapper` was overly complex (and wrong) which was introduced while working on expanding `do`-blocks (#18324)

The bug was that we were filtering out the default wild fail patterns, rather than just discarding the warnings. This patch ensures that we just discards warnings.

- - - - -


5 changed files:

- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/Tc/Gen/Do.hs
- + testsuite/tests/patsyn/should_run/T24552.hs
- + testsuite/tests/patsyn/should_run/T24552.stdout
- testsuite/tests/patsyn/should_run/all.T


Changes:

=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -29,7 +29,7 @@ import Language.Haskell.Syntax.Basic (Boxity(..))
 
 import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
 
-import GHC.Types.Basic ( Origin(..), requiresPMC, isDoExpansionGenerated )
+import GHC.Types.Basic ( Origin(..), requiresPMC )
 
 import GHC.Types.SourceText
     ( FractionalLit,
@@ -765,20 +765,11 @@ 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_gen_wc origin) matches'
-                       -- filter out the wild pattern fail alternatives
-                       -- which have a do expansion origin
-                       -- They generate spurious overlapping warnings
-                       -- Due to pattern synonyms treated as refutable patterns
-                       -- See Part 1's Wrinkle 1 in Note [Expanding HsDo with XXExprGhcRn] in GHC.Tc.Gen.Do
-                  else matches'
         ; new_vars    <- case matches of
                            []    -> newSysLocalsDs arg_tys
                            (m:_) ->
@@ -843,16 +834,6 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches'
       $ NEL.nonEmpty
       $ replicate (length (grhssGRHSs m)) ldi_nablas
 
-    is_pat_syn_match :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool
-    is_pat_syn_match origin (L _ (Match _ _ [L _ (VisPat _ l_pat)] _)) | isDoExpansionGenerated origin
-                         = isPatSyn l_pat
-    is_pat_syn_match _ _ = False
-    -- generated match pattern that is not a wildcard
-    non_gen_wc :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool
-    non_gen_wc origin (L _ (Match _ _ ([L _ (VisPat _ (L _ (WildPat _)))]) _))
-                   = not . isDoExpansionGenerated $ origin
-    non_gen_wc _ _ = True
-
 {- Note [Long-distance information in matchWrapper]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The pattern match checking in matchWrapper is done conditionally, depending


=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -368,9 +368,11 @@ The `fail`-block wrapping is done by `GHC.Tc.Gen.Do.mk_failable_expr`.
 
   Note that pattern synonyms count as refutable (see `isIrrefutableHsPat`), and hence will generate
   a `MonadFail` constraint, also, we would get a pattern match checker's redundant pattern warnings.
-  because after desugaring, it is marked as irrefutable!  To avoid such
-  spurious warnings and type checker errors, we filter out those patterns that appear
-  in a do expansion generated match in `HsToCore.Match.matchWrapper`. (see testcase Typeable1.hs)
+  After desugaring such patterns are, it is marked as irrefutable!  To avoid such
+  spurious warnings and type checker errors, we make sure we drop those spurious warnings
+  with `discard_warnings_if_skip_pmc` in `HsToCore.Match.matchWrapper` as they
+  appear in the pattern match check within an expression associated with a `do`-block expansion.
+  (see testcase Typeable1.hs)
 
 * _Wrinkle 2_: The call to `fail` will give rise to a `MonadFail` constraint. What `CtOrigin` do we
   attach to that constraint?  It should be a good one, because it'll show up in error


=====================================
testsuite/tests/patsyn/should_run/T24552.hs
=====================================
@@ -0,0 +1,16 @@
+{-# language PatternSynonyms #-}
+
+module Main where
+
+import Prelude hiding (Maybe, Nothing,Just)
+import qualified Prelude as P
+
+data Maybe a = Nothing_  | Just_  a
+
+pattern Nothing :: Maybe a
+pattern Nothing <- Nothing_ where Nothing = Nothing_
+
+pattern Just :: a -> Maybe a
+pattern Just x <- Just_ x where Just = Just_
+
+main = print $ do Just x <- [Nothing, Just ()] ; return x


=====================================
testsuite/tests/patsyn/should_run/T24552.stdout
=====================================
@@ -0,0 +1 @@
+[()]


=====================================
testsuite/tests/patsyn/should_run/all.T
=====================================
@@ -17,3 +17,4 @@ test('T11224', normal, compile_and_run, ['-Wincomplete-patterns -Woverlapping-pa
 test('T13688', req_th, multimod_compile_and_run, ['T13688', '-v0'])
 test('T14228', normal, compile_and_run, [''])
 test('records-poly-update', normal, compile_and_run, [''])
+test('T24552', normal, compile_and_run, [''])
\ No newline at end of file



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/04d319c58be7f7dc3242934bc57feee4b761c356

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/04d319c58be7f7dc3242934bc57feee4b761c356
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240319/10b5b58c/attachment-0001.html>