Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
-
cc533b66
by Sasha Bogicevic at 2026-10-31T09:18:15-04:00
15 changed files:
- + changelog.d/T27323
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match/Literal.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Types.hs
- compiler/GHC/HsToCore/Utils.hs
- + testsuite/tests/pmcheck/should_compile/T27323.hs
- + testsuite/tests/pmcheck/should_compile/T27323b.hs
- testsuite/tests/pmcheck/should_compile/all.T
- testsuite/tests/warnings/should_compile/Overflow.stderr-ws-32
- testsuite/tests/warnings/should_compile/Overflow.stderr-ws-64
- testsuite/tests/warnings/should_compile/T13256.stderr-ws-32
- testsuite/tests/warnings/should_compile/T13256.stderr-ws-64
Changes:
| 1 | +section: compiler
|
|
| 2 | +synopsis: Don't report ``-XStrict``-generated bang patterns under ``-Wredundant-bang-patterns``
|
|
| 3 | +description:
|
|
| 4 | + Bangs introduced by ``-XStrict`` are no longer reported as redundant under
|
|
| 5 | + ``-Wredundant-bang-patterns``, as they are not user-written.
|
|
| 6 | +issues: #27323
|
|
| 7 | +mrs: !16395 |
| ... | ... | @@ -383,12 +383,14 @@ tidyEqnInfo :: MatchId -> EquationInfo |
| 383 | 383 | |
| 384 | 384 | tidyEqnInfo _ eqn@(EqnDone {}) = return (idDsWrapper, eqn)
|
| 385 | 385 | |
| 386 | -tidyEqnInfo v eqn@(EqnMatch { eqn_pat = (L loc pat) }) = do
|
|
| 387 | - (wrap, pat') <- tidy1 v (not . isGoodSrcSpan . locA $ loc) pat
|
|
| 386 | +tidyEqnInfo v eqn@(EqnMatch { eqn_pat = p@(L loc _) }) = do
|
|
| 387 | + (wrap, pat') <- tidyLPat v p
|
|
| 388 | 388 | return (wrap, eqn{eqn_pat = L loc pat' })
|
| 389 | 389 | |
| 390 | +tidyLPat :: MatchId -> LPat GhcTc -> DsM (DsWrapper, Pat GhcTc)
|
|
| 391 | +tidyLPat v (L loc pat) = putSrcSpanDsA loc (tidy1 v pat)
|
|
| 392 | + |
|
| 390 | 393 | tidy1 :: MatchId -- The scrutinee
|
| 391 | - -> Bool -- `True` if the pattern was generated, `False` if it was user-written
|
|
| 392 | 394 | -> Pat GhcTc -- The pattern against which it is to be matched
|
| 393 | 395 | -> DsM (DsWrapper, -- Extra bindings to do before the match
|
| 394 | 396 | Pat GhcTc) -- Equivalent pattern
|
| ... | ... | @@ -399,21 +401,22 @@ tidy1 :: MatchId -- The scrutinee |
| 399 | 401 | -- It eliminates many pattern forms (as-patterns, variable patterns,
|
| 400 | 402 | -- list patterns, etc) and returns any created bindings in the wrapper.
|
| 401 | 403 | |
| 402 | -tidy1 v g (ParPat _ pat) = tidy1 v g (unLoc pat)
|
|
| 403 | -tidy1 v g (SigPat _ pat _) = tidy1 v g (unLoc pat)
|
|
| 404 | -tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty)
|
|
| 405 | -tidy1 v g (BangPat _ (L l p)) = tidy_bang_pat v g l p
|
|
| 406 | -tidy1 v g (ModifiedPat _ _ pat) = tidy1 v g (unLoc pat)
|
|
| 404 | +tidy1 v (ParPat _ pat) = tidyLPat v pat
|
|
| 405 | +tidy1 v (SigPat _ pat _) = tidyLPat v pat
|
|
| 406 | +tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty)
|
|
| 407 | +tidy1 v (BangPat _ (L l p)) = putSrcSpanDsA l $ tidy_bang_pat v l p
|
|
| 408 | +tidy1 v (ModifiedPat _ _ pat) = tidyLPat v pat
|
|
| 407 | 409 | |
| 408 | 410 | -- case v of { x -> mr[] }
|
| 409 | 411 | -- = case v of { _ -> let x=v in mr[] }
|
| 410 | -tidy1 v _ (VarPat _ (L _ var))
|
|
| 412 | +tidy1 v (VarPat _ (L _ var))
|
|
| 411 | 413 | = return (bindMatchId var v, WildPat (idType var))
|
| 412 | 414 | |
| 413 | 415 | -- case v of { x@p -> mr[] }
|
| 414 | 416 | -- = case v of { p -> let x=v in mr[] }
|
| 415 | -tidy1 v g (AsPat _ (L _ var) pat)
|
|
| 416 | - = do { (wrap, pat') <- tidy1 v g (unLoc pat)
|
|
| 417 | +tidy1 v (AsPat _ (L _ var) pat)
|
|
| 418 | + |
|
| 419 | + = do { (wrap, pat') <- tidyLPat v pat
|
|
| 417 | 420 | ; return (bindMatchId var v . wrap, pat') }
|
| 418 | 421 | |
| 419 | 422 | {- now, here we handle lazy patterns:
|
| ... | ... | @@ -427,7 +430,7 @@ tidy1 v g (AsPat _ (L _ var) pat) |
| 427 | 430 | The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
|
| 428 | 431 | -}
|
| 429 | 432 | |
| 430 | -tidy1 v _ (LazyPat _ pat)
|
|
| 433 | +tidy1 v (LazyPat _ pat)
|
|
| 431 | 434 | -- This is a convenient place to check for unlifted types under a lazy pattern.
|
| 432 | 435 | -- Doing this check during type-checking is unsatisfactory because we may
|
| 433 | 436 | -- not fully know the zonked types yet. We sure do here.
|
| ... | ... | @@ -441,14 +444,14 @@ tidy1 v _ (LazyPat _ pat) |
| 441 | 444 | ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
|
| 442 | 445 | ; return (mkCoreLets sel_binds, WildPat (matchIdType v)) }
|
| 443 | 446 | |
| 444 | -tidy1 _ _ (ListPat ty pats)
|
|
| 447 | +tidy1 _ (ListPat ty pats)
|
|
| 445 | 448 | = return (idDsWrapper, unLoc list_ConPat)
|
| 446 | 449 | where
|
| 447 | 450 | list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
|
| 448 | 451 | (mkNilPat ty)
|
| 449 | 452 | pats
|
| 450 | 453 | |
| 451 | -tidy1 _ _ (TuplePat tys pats boxity)
|
|
| 454 | +tidy1 _ (TuplePat tys pats boxity)
|
|
| 452 | 455 | = return (idDsWrapper, unLoc tuple_ConPat)
|
| 453 | 456 | where
|
| 454 | 457 | arity = length pats
|
| ... | ... | @@ -458,34 +461,37 @@ tidy1 _ _ (TuplePat tys pats boxity) |
| 458 | 461 | Boxed -> tys
|
| 459 | 462 | -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
|
| 460 | 463 | |
| 461 | -tidy1 _ _ (SumPat tys pat alt arity)
|
|
| 464 | +tidy1 _ (SumPat tys pat alt arity)
|
|
| 462 | 465 | = return (idDsWrapper, unLoc sum_ConPat)
|
| 463 | 466 | where
|
| 464 | 467 | sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] (map getRuntimeRep tys ++ tys)
|
| 465 | 468 | -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
|
| 466 | 469 | |
| 467 | 470 | -- LitPats: we *might* be able to replace these w/ a simpler form
|
| 468 | -tidy1 _ g (LitPat _ lit)
|
|
| 469 | - = do { unless g $
|
|
| 471 | +tidy1 _ (LitPat _ lit)
|
|
| 472 | + = do { in_gen <- inGeneratedCodeDs;
|
|
| 473 | + unless in_gen $
|
|
| 470 | 474 | warnAboutOverflowedLit lit
|
| 471 | 475 | ; return (idDsWrapper, tidyLitPat lit) }
|
| 472 | 476 | |
| 473 | 477 | -- NPats: we *might* be able to replace these w/ a simpler form
|
| 474 | -tidy1 _ g (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq)
|
|
| 475 | - = do { unless g $
|
|
| 478 | +tidy1 _ (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq)
|
|
| 479 | + = do { in_gen <- inGeneratedCodeDs;
|
|
| 480 | + unless in_gen $
|
|
| 476 | 481 | let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
|
| 477 | 482 | | otherwise = lit
|
| 478 | 483 | in warnAboutOverflowedOverLit lit'
|
| 479 | 484 | ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }
|
| 480 | 485 | |
| 481 | 486 | -- NPlusKPat: we may want to warn about the literals
|
| 482 | -tidy1 _ g n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
|
|
| 483 | - = do { unless g $ do
|
|
| 487 | +tidy1 _ n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
|
|
| 488 | + = do { in_gen <- inGeneratedCodeDs;
|
|
| 489 | + unless in_gen $ do
|
|
| 484 | 490 | warnAboutOverflowedOverLit lit1
|
| 485 | 491 | warnAboutOverflowedOverLit lit2
|
| 486 | 492 | ; return (idDsWrapper, n) }
|
| 487 | 493 | |
| 488 | -tidy1 _ _ (OrPat ty lpats)
|
|
| 494 | +tidy1 _ (OrPat ty lpats)
|
|
| 489 | 495 | -- See Note [Implementation of OrPatterns]. We desugar
|
| 490 | 496 | -- (1; 2; 3)
|
| 491 | 497 | -- to
|
| ... | ... | @@ -514,44 +520,44 @@ tidy1 _ _ (OrPat ty lpats) |
| 514 | 520 | single_grhs e = GRHSs emptyComments [noLocA $ GRHS noAnn [] e] (EmptyLocalBinds noExtField)
|
| 515 | 521 | |
| 516 | 522 | -- Everything else goes through unchanged...
|
| 517 | -tidy1 _ _ non_interesting_pat
|
|
| 523 | +tidy1 _ non_interesting_pat
|
|
| 518 | 524 | = return (idDsWrapper, non_interesting_pat)
|
| 519 | 525 | |
| 520 | 526 | --------------------
|
| 521 | -tidy_bang_pat :: MatchId -> Bool -> SrcSpanAnnA -> Pat GhcTc
|
|
| 527 | +tidy_bang_pat :: MatchId -> SrcSpanAnnA -> Pat GhcTc
|
|
| 522 | 528 | -> DsM (DsWrapper, Pat GhcTc)
|
| 523 | 529 | |
| 524 | 530 | -- Discard par/sig under a bang
|
| 525 | -tidy_bang_pat v g _ (ParPat _ (L l p)) = tidy_bang_pat v g l p
|
|
| 526 | -tidy_bang_pat v g _ (SigPat _ (L l p) _) = tidy_bang_pat v g l p
|
|
| 531 | +tidy_bang_pat v _ (ParPat _ (L l p)) = putSrcSpanDsA l $ tidy_bang_pat v l p
|
|
| 532 | +tidy_bang_pat v _ (SigPat _ (L l p) _) = putSrcSpanDsA l $ tidy_bang_pat v l p
|
|
| 527 | 533 | |
| 528 | 534 | -- Push the bang-pattern inwards, in the hope that
|
| 529 | 535 | -- it may disappear next time
|
| 530 | -tidy_bang_pat v g l (AsPat x v' p)
|
|
| 531 | - = tidy1 v g (AsPat x v' (L l (BangPat noExtField p)))
|
|
| 532 | -tidy_bang_pat v g l (XPat (CoPat w p t))
|
|
| 533 | - = tidy1 v g (XPat $ CoPat w (BangPat noExtField (L l p)) t)
|
|
| 534 | -tidy_bang_pat v g l (OrPat x (p:|ps)) -- push bang into first pat alt
|
|
| 535 | - = tidy1 v g (OrPat x (L l (BangPat noExtField p) :| ps))
|
|
| 536 | +tidy_bang_pat v l (AsPat x v' p)
|
|
| 537 | + = tidy1 v (AsPat x v' (L l (BangPat noExtField p)))
|
|
| 538 | +tidy_bang_pat v l (XPat (CoPat w p t))
|
|
| 539 | + = tidy1 v (XPat $ CoPat w (BangPat noExtField (L l p)) t)
|
|
| 540 | +tidy_bang_pat v l (OrPat x (p:|ps)) -- push bang into first pat alt
|
|
| 541 | + = tidy1 v (OrPat x (L l (BangPat noExtField p) :| ps))
|
|
| 536 | 542 | |
| 537 | 543 | -- Discard bang around strict pattern
|
| 538 | -tidy_bang_pat v g _ p@(LitPat {}) = tidy1 v g p
|
|
| 539 | -tidy_bang_pat v g _ p@(ListPat {}) = tidy1 v g p
|
|
| 540 | -tidy_bang_pat v g _ p@(TuplePat {}) = tidy1 v g p
|
|
| 541 | -tidy_bang_pat v g _ p@(SumPat {}) = tidy1 v g p
|
|
| 544 | +tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p
|
|
| 545 | +tidy_bang_pat v _ p@(ListPat {}) = tidy1 v p
|
|
| 546 | +tidy_bang_pat v _ p@(TuplePat {}) = tidy1 v p
|
|
| 547 | +tidy_bang_pat v _ p@(SumPat {}) = tidy1 v p
|
|
| 542 | 548 | |
| 543 | 549 | -- Data/newtype constructors
|
| 544 | -tidy_bang_pat v g l p@(ConPat { pat_con = L _ (RealDataCon dc)
|
|
| 545 | - , pat_args = args
|
|
| 546 | - , pat_con_ext = ConPatTc
|
|
| 547 | - { cpt_arg_tys = arg_tys
|
|
| 548 | - }
|
|
| 549 | - })
|
|
| 550 | +tidy_bang_pat v l p@(ConPat { pat_con = L _ (RealDataCon dc)
|
|
| 551 | + , pat_args = args
|
|
| 552 | + , pat_con_ext = ConPatTc
|
|
| 553 | + { cpt_arg_tys = arg_tys
|
|
| 554 | + }
|
|
| 555 | + })
|
|
| 550 | 556 | -- Newtypes: push bang inwards (#9844)
|
| 551 | 557 | =
|
| 552 | 558 | if isNewTyCon (dataConTyCon dc)
|
| 553 | - then tidy1 v g (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })
|
|
| 554 | - else tidy1 v g p -- Data types: discard the bang
|
|
| 559 | + then tidy1 v (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })
|
|
| 560 | + else tidy1 v p -- Data types: discard the bang
|
|
| 555 | 561 | where
|
| 556 | 562 | (ty:_) = dataConInstArgTys dc arg_tys
|
| 557 | 563 | |
| ... | ... | @@ -570,7 +576,7 @@ tidy_bang_pat v g l p@(ConPat { pat_con = L _ (RealDataCon dc) |
| 570 | 576 | --
|
| 571 | 577 | -- NB: SigPatIn, ConPatIn should not happen
|
| 572 | 578 | |
| 573 | -tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p))
|
|
| 579 | +tidy_bang_pat _ l p = return (idDsWrapper, BangPat noExtField (L l p))
|
|
| 574 | 580 | |
| 575 | 581 | -------------------
|
| 576 | 582 | push_bang_into_newtype_arg :: SrcSpanAnnA
|
| ... | ... | @@ -954,7 +960,7 @@ matchSinglePatVar var mb_scrut ctx pat ty match_result |
| 954 | 960 | ; ldi_nablas <-
|
| 955 | 961 | if isMatchContextPmChecked_SinglePat dflags FromSource ctx pat
|
| 956 | 962 | then addCoreScrutTmCs (maybeToList mb_scrut) [var] $
|
| 957 | - pmcPatBind (DsMatchContext ctx locn) var (unLoc pat)
|
|
| 963 | + pmcPatBind (DsMatchContext ctx locn) var pat
|
|
| 958 | 964 | else getLdiNablas
|
| 959 | 965 | |
| 960 | 966 | ; let eqn_info = EqnMatch { eqn_pat = decideBangHood dflags pat
|
| ... | ... | @@ -33,6 +33,7 @@ import GHC.HsToCore.Utils |
| 33 | 33 | |
| 34 | 34 | import GHC.Hs
|
| 35 | 35 | |
| 36 | +import GHC.Rename.Utils (wrapGenSpan)
|
|
| 36 | 37 | import GHC.Tc.Utils.TcMType ( shortCutLit )
|
| 37 | 38 | import GHC.Tc.Utils.TcType
|
| 38 | 39 | |
| ... | ... | @@ -580,7 +581,8 @@ tidyNPat (OverLit (OverLitTc False _ ty) val) mb_neg _eq outer_ty |
| 580 | 581 | |
| 581 | 582 | mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc
|
| 582 | 583 | mk_con_pat con lit
|
| 583 | - = unLoc (mkPrefixConPat con [noLocA $ LitPat noExtField lit] [])
|
|
| 584 | + -- Mark the generated literal to avoid duplicate -Woverflowed-literals.
|
|
| 585 | + = unLoc (mkPrefixConPat con [wrapGenSpan $ LitPat noExtField lit] [])
|
|
| 584 | 586 | |
| 585 | 587 | mb_int_lit :: Maybe Integer
|
| 586 | 588 | mb_int_lit = case (mb_neg, val) of
|
| ... | ... | @@ -15,7 +15,7 @@ module GHC.HsToCore.Monad ( |
| 15 | 15 | duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
|
| 16 | 16 | newSysLocalMDs, newSysLocalsMDs, newFailLocalMDs,
|
| 17 | 17 | newUniqueId, newPredVarDs, newStaticId,
|
| 18 | - getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA,
|
|
| 18 | + getSrcSpanDs, inGeneratedCodeDs, putSrcSpanDs, putSrcSpanDsA,
|
|
| 19 | 19 | mkNamePprCtxDs,
|
| 20 | 20 | newUnique,
|
| 21 | 21 | UniqSupply, newUniqueSupply,
|
| ... | ... | @@ -584,6 +584,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env tcm_plugins ptc msg_var |
| 584 | 584 | , dsl_loc = real_span
|
| 585 | 585 | , dsl_nablas = Ldi initNablas
|
| 586 | 586 | , dsl_unspecables = Just emptyVarSet
|
| 587 | + , dsl_in_generated_code = False
|
|
| 587 | 588 | }
|
| 588 | 589 | in (gbl_env, lcl_env)
|
| 589 | 590 | |
| ... | ... | @@ -676,13 +677,17 @@ getSrcSpanDs :: DsM SrcSpan |
| 676 | 677 | getSrcSpanDs = do { env <- getLclEnv
|
| 677 | 678 | ; return (RealSrcSpan (dsl_loc env) Strict.Nothing) }
|
| 678 | 679 | |
| 680 | +-- | See 'dsl_in_generated_code'
|
|
| 681 | +inGeneratedCodeDs :: DsM Bool
|
|
| 682 | +inGeneratedCodeDs = dsl_in_generated_code <$> getLclEnv
|
|
| 683 | + |
|
| 679 | 684 | putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
|
| 680 | 685 | putSrcSpanDs (RealSrcSpan real_span _) thing_inside
|
| 681 | - = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
|
|
| 686 | + = updLclEnv (\ env -> env {dsl_loc = real_span, dsl_in_generated_code = False}) thing_inside
|
|
| 682 | 687 | putSrcSpanDs UnhelpfulSpan{} thing_inside
|
| 683 | 688 | = thing_inside
|
| 684 | 689 | putSrcSpanDs GeneratedSrcSpan{} thing_inside
|
| 685 | - = thing_inside
|
|
| 690 | + = updLclEnv (\ env -> env {dsl_in_generated_code = True}) thing_inside
|
|
| 686 | 691 | |
| 687 | 692 | putSrcSpanDsA :: EpAnn ann -> DsM a -> DsM a
|
| 688 | 693 | putSrcSpanDsA loc = putSrcSpanDs (locA loc)
|
| ... | ... | @@ -104,7 +104,7 @@ whenDoingPmc no_pmc thing_inside |
| 104 | 104 | Ldi nablas -> thing_inside nablas }
|
| 105 | 105 | |
| 106 | 106 | -- | Check a pattern binding (let, where) for exhaustiveness.
|
| 107 | -pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM LdiNablas
|
|
| 107 | +pmcPatBind :: DsMatchContext -> Id -> LPat GhcTc -> DsM LdiNablas
|
|
| 108 | 108 | pmcPatBind ctxt@(DsMatchContext match_ctxt loc) var p
|
| 109 | 109 | = whenDoingPmc NoPmc $ \ !missing ->
|
| 110 | 110 | mb_discard_warnings $ do
|
| ... | ... | @@ -155,11 +155,15 @@ desugarPat x pat = case pat of |
| 155 | 155 | VarPat _ y -> pure (mkPmLetVar (unLoc y) x)
|
| 156 | 156 | ParPat _ p -> desugarLPat x p
|
| 157 | 157 | LazyPat _ _ -> pure GdEnd -- like a wildcard
|
| 158 | - BangPat _ p@(L l p') ->
|
|
| 158 | + BangPat _ p@(L l p') -> do
|
|
| 159 | 159 | -- Add the bang in front of the list, because it will happen before any
|
| 160 | 160 | -- nested stuff.
|
| 161 | + in_gen <- inGeneratedCodeDs
|
|
| 162 | + -- A bang inserted by -XStrict (decideBangHood) has no SrcInfo: it is
|
|
| 163 | + -- divergence-checked but never reported as redundant (#27323).
|
|
| 164 | + let pm_loc | in_gen = Nothing
|
|
| 165 | + | otherwise = Just (SrcInfo (L (locA l) (ppr p')))
|
|
| 161 | 166 | consGrdDag (PmBang x pm_loc) <$> desugarLPat x p
|
| 162 | - where pm_loc = Just (SrcInfo (L (locA l) (ppr p')))
|
|
| 163 | 167 | |
| 164 | 168 | -- (x@pat) ==> Desugar pat with x as match var and handle impedance
|
| 165 | 169 | -- mismatch with incoming match var
|
| ... | ... | @@ -311,11 +315,11 @@ desugarPatV pat = do |
| 311 | 315 | pure (x, grds)
|
| 312 | 316 | |
| 313 | 317 | desugarLPat :: Id -> LPat GhcTc -> DsM GrdDag
|
| 314 | -desugarLPat x = desugarPat x . unLoc
|
|
| 318 | +desugarLPat x (L loc pat) = putSrcSpanDsA loc (desugarPat x pat)
|
|
| 315 | 319 | |
| 316 | 320 | -- | 'desugarLPat', but also select and return a new match var.
|
| 317 | 321 | desugarLPatV :: LPat GhcTc -> DsM (Id, GrdDag)
|
| 318 | -desugarLPatV = desugarPatV . unLoc
|
|
| 322 | +desugarLPatV (L loc pat) = putSrcSpanDsA loc (desugarPatV pat)
|
|
| 319 | 323 | |
| 320 | 324 | -- | @desugarListPat _ x [p1, ..., pn]@ is basically
|
| 321 | 325 | -- @desugarConPatOut _ x $(mkListConPatOuts [p1, ..., pn]>@ without ever
|
| ... | ... | @@ -374,11 +378,11 @@ desugarConPatOut x con univ_tys ex_tvs dicts = \case |
| 374 | 378 | -- tracePm "ConPatOut" (ppr x $$ ppr con $$ ppr arg_ids)
|
| 375 | 379 | pure (con_grd `consGrdDag` arg_grds)
|
| 376 | 380 | |
| 377 | -desugarPatBind :: SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre)
|
|
| 381 | +desugarPatBind :: SrcSpan -> Id -> LPat GhcTc -> DsM (PmPatBind Pre)
|
|
| 378 | 382 | -- See 'GrdPatBind' for how this simply repurposes GrdGRHS.
|
| 379 | 383 | -- See Note [Suppress warnings in PMC desugaring]
|
| 380 | 384 | desugarPatBind loc var pat = discardWarningsDs $
|
| 381 | - PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) <$> desugarPat var pat
|
|
| 385 | + PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) <$> desugarLPat var pat
|
|
| 382 | 386 | |
| 383 | 387 | desugarEmptyCase :: Id -> DsM PmEmptyCase
|
| 384 | 388 | desugarEmptyCase var = pure PmEmptyCase { pe_var = var }
|
| ... | ... | @@ -633,21 +637,16 @@ Consider (#21761) |
| 633 | 637 | idV :: Void -> Void
|
| 634 | 638 | idV v = v
|
| 635 | 639 | |
| 636 | -Without -XStrict, we would not warn here. But with -XStrict, there is an
|
|
| 637 | -implicit bang on `v` and we should give an inaccessible warning for the RHS.
|
|
| 638 | -The way we account for that is by calling `decideBangHood` on patterns
|
|
| 639 | -in a `Match`, which inserts the implicit bang.
|
|
| 640 | +With -XStrict, there is an implicit bang pattern on `v` as per
|
|
| 641 | +Note [decideBangHood], so the RHS is inaccessible and we must report it as such.
|
|
| 640 | 642 | |
| 641 | -Making the call here actually seems redundant with the call to `decideBangHood`
|
|
| 642 | -in `GHC.HsToCore.Match.matchWrapper`, which does it *after* it calls the
|
|
| 643 | -pattern-match checker on the Match's patterns. It would be great if we could expect
|
|
| 644 | -`matchWrapper` to pass the bang-adorned `Match` to the pattern-match checker,
|
|
| 645 | -but sadly then we get worse warning messages which would print `idV` as if the
|
|
| 646 | -user *had* written a bang:
|
|
| 643 | +The natural way to achieve this is described in #27677: insert the bang using
|
|
| 644 | +'ExpansionPat' (see Note [Handling overloaded and rebindable constructs] in
|
|
| 645 | +GHC.Rename.Expr). Then the pattern-match checker sees the bang pattern, while
|
|
| 646 | +warning messages display the user-written pattern.
|
|
| 647 | 647 | |
| 648 | - Pattern match has inaccessible right hand side
|
|
| 649 | -- In an equation for ‘idV’: idV v = ...
|
|
| 650 | -+ In an equation for ‘idV’: idV !v = ...
|
|
| 651 | - |
|
| 652 | -So we live with the duplication.
|
|
| 648 | +This approach hasn't been implemented yet, so for the time being 'desugarMatches'
|
|
| 649 | +calls 'decideBangHood' itself, duplicating the call in 'GHC.HsToCore.Match.matchWrapper'.
|
|
| 650 | +'decideBangHood' gives the bangs it inserts a generated span, so that they are
|
|
| 651 | +never reported as redundant (see Note [Dead bang patterns] in GHC.HsToCore.Pmc.Check).
|
|
| 653 | 652 | -} |
| ... | ... | @@ -11,7 +11,7 @@ module GHC.HsToCore.Types ( |
| 11 | 11 | DsMetaEnv, DsMetaVal(..), CompleteMatches
|
| 12 | 12 | ) where
|
| 13 | 13 | |
| 14 | -import GHC.Prelude (Int)
|
|
| 14 | +import GHC.Prelude (Bool, Int)
|
|
| 15 | 15 | |
| 16 | 16 | import Data.IORef
|
| 17 | 17 | |
| ... | ... | @@ -125,6 +125,7 @@ data DsLclEnv |
| 125 | 125 | -- ^ See Note [Desugaring non-canonical evidence]
|
| 126 | 126 | -- This field collects all un-specialisable evidence variables in scope.
|
| 127 | 127 | -- Nothing <=> don't collect this info (used for the LHS of Rules)
|
| 128 | + , dsl_in_generated_code :: Bool -- ^ Are we desugaring compiler-generated code?
|
|
| 128 | 129 | }
|
| 129 | 130 | |
| 130 | 131 | -- Inside [| |] brackets, the desugarer looks
|
| ... | ... | @@ -72,6 +72,7 @@ import GHC.Unit.Module |
| 72 | 72 | import GHC.Builtin.KnownKeys
|
| 73 | 73 | import GHC.Utils.Outputable
|
| 74 | 74 | import GHC.Utils.Panic
|
| 75 | +import GHC.Rename.Utils (wrapGenSpan')
|
|
| 75 | 76 | import GHC.Types.SrcLoc
|
| 76 | 77 | import GHC.Types.Tickish
|
| 77 | 78 | import GHC.Utils.Misc
|
| ... | ... | @@ -1024,8 +1025,9 @@ Specifically: |
| 1024 | 1025 | -}
|
| 1025 | 1026 | |
| 1026 | 1027 | |
| 1027 | --- | Use -XStrict to add a ! or remove a ~
|
|
| 1028 | --- See Note [decideBangHood]
|
|
| 1028 | +-- | Use -XStrict to add a ! or remove a ~, as per Note [decideBangHood].
|
|
| 1029 | +--
|
|
| 1030 | +-- The inserted bang is compiler-generated: see Note [Desugaring -XStrict matches in Pmc].
|
|
| 1029 | 1031 | decideBangHood :: DynFlags
|
| 1030 | 1032 | -> LPat GhcTc -- ^ Original pattern
|
| 1031 | 1033 | -> LPat GhcTc -- Pattern with bang if necessary
|
| ... | ... | @@ -1040,7 +1042,7 @@ decideBangHood dflags lpat |
| 1040 | 1042 | ParPat x p -> L l (ParPat x (go p))
|
| 1041 | 1043 | LazyPat _ lp' -> lp'
|
| 1042 | 1044 | BangPat _ _ -> lp
|
| 1043 | - _ -> L l (BangPat noExtField lp)
|
|
| 1045 | + _ -> wrapGenSpan' (locA l) (BangPat noExtField lp)
|
|
| 1044 | 1046 | |
| 1045 | 1047 | isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
|
| 1046 | 1048 |
| 1 | +{-# LANGUAGE MagicHash, Strict #-}
|
|
| 2 | +{-# OPTIONS_GHC -Wredundant-bang-patterns #-}
|
|
| 3 | + |
|
| 4 | +import GHC.Prim (Int#)
|
|
| 5 | + |
|
| 6 | +idInt# :: Int# -> Int#
|
|
| 7 | +idInt# x = x
|
|
| 8 | + |
|
| 9 | +main = pure () |
| 1 | +{-# LANGUAGE Strict, MonoLocalBinds #-}
|
|
| 2 | +{-# OPTIONS_GHC -Wredundant-bang-patterns #-}
|
|
| 3 | +module T27323b where
|
|
| 4 | + |
|
| 5 | +f :: Int -> Int
|
|
| 6 | +f x = let (a, b) = (x, x) in a + b |
| ... | ... | @@ -190,4 +190,6 @@ test('T24845', [], compile, [overlapping_incomplete]) |
| 190 | 190 | test('T22652', [], compile, [overlapping_incomplete])
|
| 191 | 191 | test('T22652a', [], compile, [overlapping_incomplete])
|
| 192 | 192 | test('T24867', [], compile_fail, [overlapping_incomplete])
|
| 193 | +test('T27323', normal, compile, ['-Wredundant-bang-patterns'])
|
|
| 194 | +test('T27323b', normal, compile, ['-Wredundant-bang-patterns'])
|
|
| 193 | 195 | test('T27360', normal, compile, [overlapping_incomplete + '-g3']) |
| 1 | - |
|
| 2 | 1 | Overflow.hs:8:15: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
| 3 | 2 | Literal 10000000000000000000000000000000 is out of the Int# range -2147483648..2147483647
|
| 4 | 3 | |
| 5 | -Overflow.hs:13:1: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
|
| 4 | +Overflow.hs:13:3: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
|
| 6 | 5 | Literal 100000000000000000000000000 is out of the Int# range -2147483648..2147483647
|
| 7 | 6 | |
| 8 | 7 | Overflow.hs:18:5: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
| 9 | 8 | Literal 1000000000000000000000000000000 is out of the Int range -2147483648..2147483647
|
| 10 | 9 | |
| 11 | -Overflow.hs:22:1: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
|
| 10 | +Overflow.hs:22:3: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
|
| 12 | 11 | Literal 100000000000000000000000000000000 is out of the Int range -2147483648..2147483647
|
| 13 | 12 | |
| 14 | 13 | Overflow.hs:27:6: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
| 15 | 14 | Literal -1 is out of the Word range 0..4294967295
|
| 16 | 15 | |
| 17 | -Overflow.hs:31:1: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
|
| 16 | +Overflow.hs:31:4: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
|
| 18 | 17 | Literal -1 is out of the Word range 0..4294967295
|
| 18 | + |
| 1 | - |
|
| 2 | 1 | Overflow.hs:8:15: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
| 3 | 2 | Literal 10000000000000000000000000000000 is out of the Int# range -9223372036854775808..9223372036854775807
|
| 4 | 3 | |
| 5 | -Overflow.hs:13:1: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
|
| 4 | +Overflow.hs:13:3: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
|
| 6 | 5 | Literal 100000000000000000000000000 is out of the Int# range -9223372036854775808..9223372036854775807
|
| 7 | 6 | |
| 8 | 7 | Overflow.hs:18:5: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
| 9 | 8 | Literal 1000000000000000000000000000000 is out of the Int range -9223372036854775808..9223372036854775807
|
| 10 | 9 | |
| 11 | -Overflow.hs:22:1: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
|
| 10 | +Overflow.hs:22:3: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
|
| 12 | 11 | Literal 100000000000000000000000000000000 is out of the Int range -9223372036854775808..9223372036854775807
|
| 13 | 12 | |
| 14 | 13 | Overflow.hs:27:6: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
| 15 | 14 | Literal -1 is out of the Word range 0..18446744073709551615
|
| 16 | 15 | |
| 17 | -Overflow.hs:31:1: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
|
| 16 | +Overflow.hs:31:4: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
|
| 18 | 17 | Literal -1 is out of the Word range 0..18446744073709551615
|
| 18 | + |
| 1 | - |
|
| 2 | -T13256.hs:4:12: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
|
| 1 | +T13256.hs:4:31: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
|
| 3 | 2 | Literal 100000000000000000000000000000000 is out of the Int range -2147483648..2147483647
|
| 3 | + |
| 1 | - |
|
| 2 | -T13256.hs:4:12: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
|
| 1 | +T13256.hs:4:31: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
|
|
| 3 | 2 | Literal 100000000000000000000000000000000 is out of the Int range -9223372036854775808..9223372036854775807
|
| 3 | + |