diff options
author | Sebastian Graf <sebastian.graf@kit.edu> | 2020-02-03 14:41:23 +0100 |
---|---|---|
committer | Sebastian Graf <sebastian.graf@kit.edu> | 2020-02-05 17:24:49 +0100 |
commit | 5be91d0392fd92f383164fc4280a41884f60384e (patch) | |
tree | af9bbd988c416ddbe3557bc595d33816abda4231 | |
parent | 70ddb8bf3066a2e70cffb49b100b640830bec7e1 (diff) | |
download | haskell-5be91d0392fd92f383164fc4280a41884f60384e.tar.gz |
Fix long distance info for record updateswip/T17783
For record updates where the `record_expr` is a variable, as in #17783:
```hs
data PartialRec = No
| Yes { a :: Int, b :: Bool }
update No = No
update r@(Yes {}) = r { b = False }
```
We should make use of long distance info in
`-Wincomplete-record-updates` checking. But the call to `matchWrapper`
in the `RecUpd` case didn't specify a scrutinee expression, which would
correspond to the `record_expr` `r` here. That is fixed now.
Fixes #17783.
-rw-r--r-- | compiler/GHC/HsToCore/PmCheck.hs | 24 | ||||
-rw-r--r-- | compiler/deSugar/DsExpr.hs | 20 | ||||
-rw-r--r-- | testsuite/tests/pmcheck/should_compile/T17783.hs | 9 | ||||
-rw-r--r-- | testsuite/tests/pmcheck/should_compile/all.T | 2 |
4 files changed, 49 insertions, 6 deletions
diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs index a7845de8bd..934967f055 100644 --- a/compiler/GHC/HsToCore/PmCheck.hs +++ b/compiler/GHC/HsToCore/PmCheck.hs @@ -1159,7 +1159,7 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) vars result = when (flag_i || flag_u) $ do unc_examples <- getNFirstUncovered vars (maxPatterns + 1) uncovered let exists_r = flag_i && notNull redundant - exists_i = flag_i && notNull inaccessible && not is_rec_upd + exists_i = flag_i && notNull inaccessible exists_u = flag_u && notNull unc_examples approx = precision == Approximate @@ -1182,13 +1182,10 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) vars result , cr_approx = precision } = result (redundant, inaccessible) = redundantAndInaccessibleRhss clauses - flag_i = wopt Opt_WarnOverlappingPatterns dflags + flag_i = overlapping dflags kind flag_u = exhaustive dflags kind flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind) - is_rec_upd = case kind of { RecUpd -> True; _ -> False } - -- See Note [Inaccessible warnings for record updates] - maxPatterns = maxUncoveredPatterns dflags -- Print a single clause (for redundant/with-inaccessible-rhs) @@ -1244,6 +1241,17 @@ it's impossible: We don't want to warn about the inaccessible branch because the programmer didn't put it there! So we filter out the warning here. + +The same can happen for long distance term constraints instead of type +constraints (#17783): + + data T = A { x :: Int } | B { x :: Int } + f r@A{} = r { x = 3 } + f _ = B 0 + +Here, the long distance info from the FunRhs match (@r ~ A x@) will make the +clause matching on @B@ of the desugaring to @case@ redundant. It's generated +code that we don't want to warn about. -} dots :: Int -> [a] -> SDoc @@ -1260,6 +1268,12 @@ allPmCheckWarnings = , Opt_WarnOverlappingPatterns ] +-- | Check whether the redundancy checker should run (redundancy only) +overlapping :: DynFlags -> HsMatchContext id -> Bool +-- See Note [Inaccessible warnings for record updates] +overlapping _ RecUpd = False +overlapping dflags _ = wopt Opt_WarnOverlappingPatterns dflags + -- | Check whether the exhaustiveness checker should run (exhaustiveness only) exhaustive :: DynFlags -> HsMatchContext id -> Bool exhaustive dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 0f1386d76d..45d208b3db 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -601,7 +601,7 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields -- constructor arguments. ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd ; ([discrim_var], matching_code) - <- matchWrapper RecUpd Nothing + <- matchWrapper RecUpd (Just record_expr) -- See Note [Scrutinee in Record updates] (MG { mg_alts = noLoc alts , mg_ext = MatchGroupTc [in_ty] out_ty , mg_origin = FromSource }) @@ -707,6 +707,24 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields , pat_wrap = req_wrap } ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) } +{- Note [Scrutinee in Record updates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider #17783: + + data PartialRec = No + | Yes { a :: Int, b :: Bool } + update No = No + update r@(Yes {}) = r { b = False } + +In the context of pattern-match checking, the occurrence of @r@ in +@r { b = False }@ is to be treated as if it was a scrutinee, as can be seen by +the following desugaring: + + r { b = False } ==> case r of Yes a b -> Yes a False + +Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above. +-} + -- Here is where we desugar the Template Haskell brackets and escapes -- Template Haskell stuff diff --git a/testsuite/tests/pmcheck/should_compile/T17783.hs b/testsuite/tests/pmcheck/should_compile/T17783.hs new file mode 100644 index 0000000000..8ac9246000 --- /dev/null +++ b/testsuite/tests/pmcheck/should_compile/T17783.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_GHC -Wincomplete-record-updates #-} + +module Bug where + +data PartialRec = No + | Yes { a :: Int, b :: Bool } + +update No = No +update r@(Yes {}) = r { b = False } diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T index 9d37f36fe5..dcb9ca4081 100644 --- a/testsuite/tests/pmcheck/should_compile/all.T +++ b/testsuite/tests/pmcheck/should_compile/all.T @@ -112,6 +112,8 @@ test('T17646', normal, compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns']) test('T17703', normal, compile, ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns']) +test('T17783', normal, compile, + ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns']) # Other tests test('pmc001', [], compile, |