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

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Sat Mar 23 04:22:00 UTC 2024



Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
0c48f2b9 by Apoorv Ingle at 2024-03-23T00:21:28-04:00
Fix for #24552 (see testcase T24552)

Fixes for a bug in desugaring pattern synonyms matches, introduced
while working on  on expanding `do`-blocks in #18324

The `matchWrapper` unecessarily (and incorrectly) filtered out the
default wild patterns in a match. Now the wild pattern alternative is
simply ignored by the pm check as its origin is `Generated`.
The current code now matches the expected semantics according to the language spec.

- - - - -


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:_) ->
@@ -797,6 +788,8 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches'
                 , text "matchPmChecked" <+> ppr (isMatchContextPmChecked dflags origin ctxt)])
         ; matches_nablas <-
             if isMatchContextPmChecked dflags origin ctxt
+               -- See Note [Expanding HsDo with XXExprGhcRn] Part 1. Wrinkle 1 for
+               -- pmc for pattern synonyms
 
             -- See Note [Long-distance information] in GHC.HsToCore.Pmc
             then addHsScrutTmCs (concat scrs) new_vars $
@@ -843,16 +836,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
=====================================
@@ -212,7 +212,7 @@ mk_failable_expr doFlav pat@(L loc _) expr fail_op =
 mk_fail_block :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn)
 mk_fail_block doFlav pat@(L ploc _) e (Just (SyntaxExprRn fail_op)) =
   do  dflags <- getDynFlags
-      return $ HsLam noAnn LamSingle $ mkMatchGroup (doExpansionOrigin doFlav)     -- \
+      return $ HsLam noAnn LamCases $ mkMatchGroup (doExpansionOrigin doFlav)      -- \
                 (wrapGenSpan [ genHsCaseAltDoExp doFlav (mkVisPat pat) e           --  pat -> expr
                              , fail_alt_case dflags pat fail_op      --  _   -> fail "fail pattern"
                              ])
@@ -356,25 +356,42 @@ The `fail`-block wrapping is done by `GHC.Tc.Gen.Do.mk_failable_expr`.
   of do-notation is that if the pattern match fails, we fail in the monad, *not* just crash
   at runtime.
 
-* That call of `fail` will (rightly) automatically generate a `MonadFail` constraint. So if the
-  pattern is irrefuable, we don't want to generate that `fail` alternative, else we'll generate
-  a `MonadFail` constraint that isn't needed.
+* According to the language specification, when the pattern is irrefutable,
+  we should not add the `fail` alternative. This is important because
+  the occurrence of `fail` means that the typechecker will generate a `MonadFail` constraint,
+  and irrefutable patterns shouldn't need a fail alternative.
 
-* _Wrinkle 1_: For pattern synonyms, we always wrap it with a `fail`-block.
-  When the pattern is irrefutable, we do not add the fail block.
-  This is important because the occurrence of `fail` means that the typechecker
-  will generate a `MonadFail` constraint, and the language spec says that
-  we should not do that for irrefutable patterns.
+* _Wrinkel 1_: Note that pattern synonyms count as refutable during type checking,
+  (see `GHC.Tc.Gen.Pat.isIrrefutableHsPatRnTcM`). They will hence generate a
+  `MonadFail` constraint and they will always be wrapped in a `fail`able-block.
 
-  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)
+  Consider a patten synonym declaration (testcase T24552):
+
+             pattern MyJust :: a -> Maybe a
+             pattern MyJust x <- Just x where MyJust = Just
+
+  and a `do`-block with the following bind and return statement
+
+             do { MyJust x <- [MyNothing, MyJust ()]
+                ; return x }
+
+  The `do`-expansion will generate the expansion
+
+            (>>=) ([MyNothing, MyJust ()])
+                  (\case MyJust x -> return x                     -- (1)
+                         _        -> fail "failable pattern .. "  -- (2)
+                  )
+
+  This code (specifically the `match` spanning lines (1) and (2)) is a compiler generated code;
+  the associated `Origin` in tagged `Generated`
+  The alternative statements will thus be ignored by the pattern match check (c.f. `isMatchContextPmChecked`).
+  This ensures we do not generate spurious redundant-pattern-match warnings due to the line (2) above.
+  See Note [Generated code and pattern-match checking]
+  See Note [Long-distance information in matchWrapper]
 
 * _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
-  messages when the `MonadFail` constraint can't be solved.  Ideally, it should identify the
+  attach to that constraint?  When the `MonadFail` constraint can't be solved, it'll show up in error
+  messages and it needs to be a good location.  Ideally, it should identify the
   pattern `p`.  Hence, we wrap the `fail` alternative expression with a `ExpandedPat`
   that tags the fail expression with the failable pattern. (See testcase MonadFailErrors.hs)
 


=====================================
testsuite/tests/patsyn/should_run/T24552.hs
=====================================
@@ -0,0 +1,14 @@
+{-# language PatternSynonyms #-}
+
+module Main where
+
+import Prelude
+import qualified Prelude as P
+
+pattern MyNothing :: Maybe a
+pattern MyNothing <- Nothing where MyNothing = Nothing
+
+pattern MyJust :: a -> Maybe a
+pattern MyJust x <- Just x where MyJust = Just
+
+main = print $ do MyJust x <- [MyNothing, MyJust ()] ; 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/0c48f2b952ad4ee995e4eafa458b7a8d3c442415

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0c48f2b952ad4ee995e4eafa458b7a8d3c442415
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/20240323/74dc18f5/attachment-0001.html>


More information about the ghc-commits mailing list