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

Apoorv Ingle (@ani) gitlab at gitlab.haskell.org
Tue Mar 19 21:18:21 UTC 2024



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


Commits:
bbd3447f by Apoorv Ingle at 2024-03-19T16:18:09-05: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
=====================================
@@ -356,25 +356,44 @@ 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.
-
-* _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.
-
-  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)
+* 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.
+
+* _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 we will always be wrapped in a `fail`able-block.
+
+  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 <- [Just ()]
+                ; return x
+                }
+
+  The `do`-expansion will generate the expansion
+
+            (>>=) ([MyJust x])
+                  (\case MyJust x -> return x                     -- (1)
+                         _        -> fail "failable pattern .. "  -- (2)
+                  )
+
+  This code is compiler generated, so the associated `Origin` will be `Generated`.
+  It will be ignored by the pattern match check (using `isMatchContextPmChecked`).
+  This ensures we do not generate spurious redundant pattern match warnings, eg. due to line (2) above
+  `MyJust x`  pattern can never be anything else; it is effectively irrefutable and evaluation
+  will always preceed with line (1).
+  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,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/bbd3447f06a253a72c379018d2378bbaa413614b

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bbd3447f06a253a72c379018d2378bbaa413614b
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/b0e08ab5/attachment-0001.html>


More information about the ghc-commits mailing list