[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:
33e5ce45 by Apoorv Ingle at 2024-03-18T16:59:51-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)

- - - - -


4 changed files:

- compiler/GHC/HsToCore/Match.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


=====================================
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/33e5ce45e3b3342b93deeade11c1759c387664b6

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/33e5ce45e3b3342b93deeade11c1759c387664b6
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/20240318/246a2fc1/attachment-0001.html>