[Git][ghc/ghc][master] Propagate long distance info to guarded let binds

[Marge Bot (@marge-bot)]

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


Commits:
0f2241e9 by sheaf at 2025-02-25T19:23:21-05:00
Propagate long distance info to guarded let binds

This commit ensures that we propagate the enclosing long distance
information to let bindings inside guards, in order to get accurate
pattern-match checking warnings, in particular incomplete record
selector warnings.

Example:

  data D = K0 | K1 { fld :: Int }
  f :: D -> Int
  f d@(K1 {})
    | let i = fld d
    = i
  f _ = 3

We now correctly recognise that the field selector 'fld' cannot fail,
due to the outer pattern match which guarantees that the value 'd' has
the field 'fld'.

Fixes #25749

- - - - -


3 changed files:

- compiler/GHC/HsToCore/GuardedRHSs.hs
- + testsuite/tests/pmcheck/should_compile/T25749.hs
- testsuite/tests/pmcheck/should_compile/all.T


Changes:

=====================================
compiler/GHC/HsToCore/GuardedRHSs.hs
=====================================
@@ -76,7 +76,8 @@ dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_nablas
 dsGRHS :: HsMatchContextRn -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc)
        -> DsM (MatchResult CoreExpr)
 dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs))
-  = matchGuards (map unLoc guards) hs_ctx rhs_nablas rhs rhs_ty
+  = updPmNablas rhs_nablas $
+      matchGuards (map unLoc guards) hs_ctx rhs rhs_ty
 
 {-
 ************************************************************************
@@ -88,7 +89,6 @@ dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs))
 
 matchGuards :: [GuardStmt GhcTc]     -- Guard
             -> HsMatchContextRn      -- Context
-            -> Nablas                -- The RHS's covered set for PmCheck
             -> LHsExpr GhcTc         -- RHS
             -> Type                  -- Type of RHS of guard
             -> DsM (MatchResult CoreExpr)
@@ -96,8 +96,8 @@ matchGuards :: [GuardStmt GhcTc]     -- Guard
 -- See comments with HsExpr.Stmt re what a BodyStmt means
 -- Here we must be in a guard context (not do-expression, nor list-comp)
 
-matchGuards [] _ nablas rhs _
-  = do  { core_rhs <- updPmNablas nablas (dsLExpr rhs)
+matchGuards [] _ rhs _
+  = do  { core_rhs <- dsLExpr rhs
         ; return (cantFailMatchResult core_rhs) }
 
         -- BodyStmts must be guards
@@ -107,42 +107,50 @@ matchGuards [] _ nablas rhs _
         -- NB:  The success of this clause depends on the typechecker not
         --      wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
         --      If it does, you'll get bogus overlap warnings
-matchGuards (BodyStmt _ e _ _ : stmts) ctx nablas rhs rhs_ty
+matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty
   | Just addTicks <- isTrueLHsExpr e = do
-    match_result <- matchGuards stmts ctx nablas rhs rhs_ty
+    match_result <- matchGuards stmts ctx rhs rhs_ty
     return (adjustMatchResultDs addTicks match_result)
-matchGuards (BodyStmt _ expr _ _ : stmts) ctx nablas rhs rhs_ty = do
-    match_result <- matchGuards stmts ctx nablas rhs rhs_ty
+matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do
+    match_result <- matchGuards stmts ctx rhs rhs_ty
     pred_expr <- dsLExpr expr
     return (mkGuardedMatchResult pred_expr match_result)
 
-matchGuards (LetStmt _ binds : stmts) ctx nablas rhs rhs_ty = do
-    match_result <- matchGuards stmts ctx nablas rhs rhs_ty
-    return (adjustMatchResultDs (dsLocalBinds binds) match_result)
+matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do
+    ldi_nablas <- getPmNablas
+    match_result <- matchGuards stmts ctx rhs rhs_ty
+      -- Propagate long-distance information when desugaring let bindings, e.g.
+      --
+      --  f r@(K1 {})
+      --    | let g = fld r
+      --    = g
+      --
+      -- Failing to do so resulted in #25749.
+    return (adjustMatchResultDs (updPmNablas ldi_nablas . dsLocalBinds binds) match_result)
         -- NB the dsLet occurs inside the match_result
         -- Reason: dsLet takes the body expression as its argument
         --         so we can't desugar the bindings without the
         --         body expression in hand
 
-matchGuards (BindStmt _ pat bind_rhs : stmts) ctx nablas rhs rhs_ty = do
+matchGuards (BindStmt _ pat bind_rhs : stmts) ctx rhs rhs_ty = do
     let upat = unLoc pat
     match_var <- selectMatchVar ManyTy upat
        -- We only allow unrestricted patterns in guards, hence the `Many`
        -- above. It isn't clear what linear patterns would mean, maybe we will
        -- figure it out in the future.
 
-    match_result <- matchGuards stmts ctx nablas rhs rhs_ty
+    match_result <- matchGuards stmts ctx rhs rhs_ty
     core_rhs <- dsLExpr bind_rhs
     match_result' <-
       matchSinglePatVar match_var (Just core_rhs) (StmtCtxt $ PatGuard ctx)
       pat rhs_ty match_result
     return $ bindNonRec match_var core_rhs <$> match_result'
 
-matchGuards (LastStmt  {} : _) _ _ _ _ = panic "matchGuards LastStmt"
-matchGuards (ParStmt   {} : _) _ _ _ _ = panic "matchGuards ParStmt"
-matchGuards (TransStmt {} : _) _ _ _ _ = panic "matchGuards TransStmt"
-matchGuards (RecStmt   {} : _) _ _ _ _ = panic "matchGuards RecStmt"
-matchGuards (XStmtLR ApplicativeStmt {} : _) _ _ _ _ =
+matchGuards (LastStmt  {} : _) _ _ _ = panic "matchGuards LastStmt"
+matchGuards (ParStmt   {} : _) _ _ _ = panic "matchGuards ParStmt"
+matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"
+matchGuards (RecStmt   {} : _) _ _ _ = panic "matchGuards RecStmt"
+matchGuards (XStmtLR ApplicativeStmt {} : _) _ _ _ =
   panic "matchGuards ApplicativeLastStmt"
 
 {-


=====================================
testsuite/tests/pmcheck/should_compile/T25749.hs
=====================================
@@ -0,0 +1,18 @@
+module T25749 where
+
+data D = K0 | K1 { fld :: Int }
+
+foo :: D -> Int
+foo K0 = 3
+foo d
+  | let i = fld d
+  = let j = fld d
+    in i + j + k
+  where k = fld d
+
+bar :: D -> Int
+bar d@(K1 {})
+  | let i | let i' = fld d = i'
+  = let j = fld d in i + j + k
+  where k = fld d
+bar _ = 3


=====================================
testsuite/tests/pmcheck/should_compile/all.T
=====================================
@@ -170,6 +170,7 @@ test('EmptyCase010', [],  compile, [overlapping_incomplete])
 test('DsIncompleteRecSel1', normal, compile, ['-Wincomplete-record-selectors'])
 test('DsIncompleteRecSel2', normal, compile, ['-Wincomplete-record-selectors'])
 test('DsIncompleteRecSel3', [collect_compiler_stats('bytes allocated', 10)], compile, ['-Wincomplete-record-selectors'])
+test('T25749', normal, compile, ['-Wincomplete-record-selectors'])
 test('DoubleMatch', normal, compile, [overlapping_incomplete])
 test('T24817', normal, compile, [overlapping_incomplete])
 test('T24824', normal, compile, ['-package ghc -Wincomplete-record-selectors'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f2241e9758e8b74fedfe52269a8fb1ff17858cb

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f2241e9758e8b74fedfe52269a8fb1ff17858cb
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/20250225/2d7de604/attachment-0001.html>