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

Commits:

15 changed files:

Changes:

  • changelog.d/T27323
    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

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

  • compiler/GHC/HsToCore/Match/Literal.hs
    ... ... @@ -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
    

  • compiler/GHC/HsToCore/Monad.hs
    ... ... @@ -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)
    

  • compiler/GHC/HsToCore/Pmc.hs
    ... ... @@ -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
    

  • compiler/GHC/HsToCore/Pmc/Desugar.hs
    ... ... @@ -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
     -}

  • compiler/GHC/HsToCore/Types.hs
    ... ... @@ -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
    

  • compiler/GHC/HsToCore/Utils.hs
    ... ... @@ -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
     
    

  • testsuite/tests/pmcheck/should_compile/T27323.hs
    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 ()

  • testsuite/tests/pmcheck/should_compile/T27323b.hs
    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

  • testsuite/tests/pmcheck/should_compile/all.T
    ... ... @@ -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'])

  • testsuite/tests/warnings/should_compile/Overflow.stderr-ws-32
    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
    +

  • testsuite/tests/warnings/should_compile/Overflow.stderr-ws-64
    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
    +

  • testsuite/tests/warnings/should_compile/T13256.stderr-ws-32
    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
    +

  • testsuite/tests/warnings/should_compile/T13256.stderr-ws-64
    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
    +