[Git][ghc/ghc][wip/T24552] Fix for #24552 (see testcase T24552)
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Fri Mar 22 16:25:27 UTC 2024
Apoorv Ingle pushed to branch wip/T24552 at Glasgow Haskell Compiler / GHC
Commits:
8cf58aef by Apoorv Ingle at 2024-03-22T11:24:48-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
=====================================
@@ -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/8cf58aefb81d7c829b14d7c9d573489431a89c59
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8cf58aefb81d7c829b14d7c9d573489431a89c59
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/20240322/41cb48f9/attachment-0001.html>
More information about the ghc-commits
mailing list