[Git][ghc/ghc][wip/T24234] Pmc: Fix SrcLoc and warning for incomplete irrefutable pats (#24234)

Sebastian Graf (@sgraf812) gitlab at gitlab.haskell.org
Fri Dec 1 12:49:24 UTC 2023



Sebastian Graf pushed to branch wip/T24234 at Glasgow Haskell Compiler / GHC


Commits:
d46c4987 by Sebastian Graf at 2023-12-01T13:49:17+01:00
Pmc: Fix SrcLoc and warning for incomplete irrefutable pats (#24234)

Before, the source location would point at the surrounding function definition,
causing the confusion in #24234.
I also took the opportunity to introduce a new `LazyPatCtx :: HsMatchContext _`
to make the warning message say "irrefutable pattern" instead of "pattern
binding".

- - - - -


12 changed files:

- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Pmc/Utils.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- testsuite/tests/ado/T22483.stderr
- testsuite/tests/deSugar/should_run/dsrun008.stderr
- + testsuite/tests/pmcheck/should_compile/T24234.hs
- + testsuite/tests/pmcheck/should_compile/T24234.stderr
- testsuite/tests/pmcheck/should_compile/all.T


Changes:

=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1469,6 +1469,21 @@ pprGRHS ctxt (GRHS _ guards body)
 pp_rhs :: Outputable body => HsMatchContext passL -> body -> SDoc
 pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
 
+matchSeparator :: HsMatchContext p -> SDoc
+matchSeparator FunRhs{}         = text "="
+matchSeparator CaseAlt          = text "->"
+matchSeparator LamAlt{}         = text "->"
+matchSeparator IfAlt            = text "->"
+matchSeparator ArrowMatchCtxt{} = text "->"
+matchSeparator PatBindRhs       = text "="
+matchSeparator PatBindGuards    = text "="
+matchSeparator StmtCtxt{}       = text "<-"
+matchSeparator RecUpd           = text "="  -- This can be printed by the pattern
+matchSeparator PatSyn           = text "<-" -- match checker trace
+matchSeparator LazyPatCtx       = panic "unused"
+matchSeparator ThPatSplice      = panic "unused"
+matchSeparator ThPatQuote       = panic "unused"
+
 instance Outputable GrhsAnn where
   ppr (GrhsAnn v s) = text "GrhsAnn" <+> ppr v <+> ppr s
 
@@ -1931,6 +1946,7 @@ instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where
   ppr ThPatSplice             = text "ThPatSplice"
   ppr ThPatQuote              = text "ThPatQuote"
   ppr PatSyn                  = text "PatSyn"
+  ppr LazyPatCtx              = text "LazyPatCtx"
 
 instance Outputable HsLamVariant where
   ppr = text . \case
@@ -1981,6 +1997,7 @@ matchContextErrString (StmtCtxt (TransStmtCtxt c))  = matchContextErrString (Stm
 matchContextErrString (StmtCtxt (PatGuard _))       = text "pattern guard"
 matchContextErrString (StmtCtxt (ArrowExpr))        = text "'do' block"
 matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour
+matchContextErrString LazyPatCtx                    = text "irrefutable pattern"
 
 matchArrowContextErrString :: HsArrowMatchContext -> SDoc
 matchArrowContextErrString ProcExpr                  = text "proc"
@@ -2022,20 +2039,6 @@ pprStmtInCtxt ctxt stmt
                         , trS_form = form }) = pprTransStmt by using form
     ppr_stmt stmt = pprStmt stmt
 
-matchSeparator :: HsMatchContext p -> SDoc
-matchSeparator FunRhs{}         = text "="
-matchSeparator CaseAlt          = text "->"
-matchSeparator LamAlt{}         = text "->"
-matchSeparator IfAlt            = text "->"
-matchSeparator ArrowMatchCtxt{} = text "->"
-matchSeparator PatBindRhs       = text "="
-matchSeparator PatBindGuards    = text "="
-matchSeparator StmtCtxt{}       = text "<-"
-matchSeparator RecUpd           = text "="  -- This can be printed by the pattern
-matchSeparator PatSyn           = text "<-" -- match checker trace
-matchSeparator ThPatSplice  = panic "unused"
-matchSeparator ThPatQuote   = panic "unused"
-
 pprMatchContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
                 => HsMatchContext p -> SDoc
 pprMatchContext ctxt
@@ -2045,6 +2048,7 @@ pprMatchContext ctxt
     want_an (FunRhs {})                              = True  -- Use "an" in front
     want_an (ArrowMatchCtxt ProcExpr)                = True
     want_an (ArrowMatchCtxt (ArrowLamAlt LamSingle)) = True
+    want_an LazyPatCtx                               = True
     want_an _                                        = False
 
 pprMatchContextNoun :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
@@ -2065,6 +2069,7 @@ pprMatchContextNoun (ArrowMatchCtxt c)      = pprArrowMatchContextNoun c
 pprMatchContextNoun (StmtCtxt ctxt)         = text "pattern binding in"
                                               $$ pprAStmtContext ctxt
 pprMatchContextNoun PatSyn                  = text "pattern synonym declaration"
+pprMatchContextNoun LazyPatCtx              = text "irrefutable pattern"
 
 pprMatchContextNouns :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
                      => HsMatchContext p -> SDoc


=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -237,7 +237,7 @@ dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
         ; body_expr <- dsGuarded grhss ty rhss_nablas
         ; let body' = mkOptTickBox rhs_tick body_expr
               pat'  = decideBangHood dflags pat
-        ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body'
+        ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat PatBindRhs body'
           -- We silently ignore inline pragmas; no makeCorePair
           -- Not so cool, but really doesn't matter
         ; let force_var' = if isBangedLPat pat'


=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -451,13 +451,13 @@ tidy1 v _ (LazyPat _ pat)
     -- This is a convenient place to check for unlifted types under a lazy pattern.
     -- Doing this check during type-checking is unsatisfactory because we may
     -- not fully know the zonked types yet. We sure do here.
-  = do  { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat)
+  = putSrcSpanDs (getLocA pat) $
+    do  { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat)
             -- NB: the binders can't be representation-polymorphic, so we're OK to call isUnliftedType
         ; unless (null unlifted_bndrs) $
-          putSrcSpanDs (getLocA pat) $
           diagnosticDs (DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs)
 
-        ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)
+        ; (_,sel_prs) <- mkSelectorBinds [] pat LazyPatCtx (Var v)
         ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
         ; return (mkCoreLets sel_binds, WildPat (idType v)) }
 


=====================================
compiler/GHC/HsToCore/Pmc.hs
=====================================
@@ -118,6 +118,7 @@ pmcPatBind ctxt@(DsMatchContext match_ctxt loc) var p
         then id
         else discardWarningsDs
     want_pmc PatBindRhs = True
+    want_pmc LazyPatCtx = True
     want_pmc (StmtCtxt stmt_ctxt) =
       case stmt_ctxt of
         PatGuard {} -> False


=====================================
compiler/GHC/HsToCore/Pmc/Utils.hs
=====================================
@@ -91,6 +91,7 @@ exhaustiveWarningFlag PatBindRhs         = Just Opt_WarnIncompleteUniPatterns
 exhaustiveWarningFlag PatBindGuards      = Just Opt_WarnIncompletePatterns
 exhaustiveWarningFlag (ArrowMatchCtxt c) = arrowMatchContextExhaustiveWarningFlag c
 exhaustiveWarningFlag RecUpd             = Just Opt_WarnIncompletePatternsRecUpd
+exhaustiveWarningFlag LazyPatCtx         = Just Opt_WarnIncompleteUniPatterns
 exhaustiveWarningFlag ThPatSplice        = Nothing
 exhaustiveWarningFlag PatSyn             = Nothing
 exhaustiveWarningFlag ThPatQuote         = Nothing


=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -726,15 +726,16 @@ work out well:
 -}
 -- Remark: pattern selectors only occur in unrestricted patterns so we are free
 -- to select Many as the multiplicity of every let-expression introduced.
-mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly
-                -> LPat GhcTc      -- ^ The pattern
-                -> CoreExpr        -- ^ Expression to which the pattern is bound
+mkSelectorBinds :: [[CoreTickish]]       -- ^ ticks to add, possibly
+                -> LPat GhcTc            -- ^ The pattern
+                -> HsMatchContext GhcTc  -- ^ Where the pattern occurs
+                -> CoreExpr              -- ^ Expression to which the pattern is bound
                 -> DsM (Id,[(Id,CoreExpr)])
                 -- ^ Id the rhs is bound to, for desugaring strict
                 -- binds (see Note [Desugar Strict binds] in "GHC.HsToCore.Binds")
                 -- and all the desugared binds
 
-mkSelectorBinds ticks pat val_expr
+mkSelectorBinds ticks pat ctx val_expr
   | L _ (VarPat _ (L _ v)) <- pat'     -- Special case (A)
   = return (v, [(v, val_expr)])
 
@@ -745,7 +746,7 @@ mkSelectorBinds ticks pat val_expr
        ; let mk_bind tick bndr_var
                -- (mk_bind sv bv)  generates  bv = case sv of { pat -> bv }
                -- Remember, 'pat' binds 'bv'
-               = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat'
+               = do { rhs_expr <- matchSimply (Var val_var) ctx pat'
                                        (Var bndr_var)
                                        (Var bndr_var)  -- Neat hack
                       -- Neat hack: since 'pat' can't fail, the
@@ -760,7 +761,7 @@ mkSelectorBinds ticks pat val_expr
   | otherwise                          -- General case (C)
   = do { tuple_var  <- newSysLocalDs ManyTy tuple_ty
        ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat')
-       ; tuple_expr <- matchSimply val_expr PatBindRhs pat
+       ; tuple_expr <- matchSimply val_expr ctx pat
                                    local_tuple error_expr
        ; let mk_tup_bind tick binder
                = (binder, mkOptTickBox tick $


=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -1576,6 +1576,7 @@ data HsMatchContext p
   | ThPatSplice            -- ^A Template Haskell pattern splice
   | ThPatQuote             -- ^A Template Haskell pattern quotation [p| (a,b) |]
   | PatSyn                 -- ^A pattern synonym declaration
+  | LazyPatCtx             -- ^An irrefutable pattern
 
 {-
 Note [mc_fun field of FunRhs]


=====================================
testsuite/tests/ado/T22483.stderr
=====================================
@@ -2,7 +2,7 @@
 T22483.hs:1:1: warning: [GHC-38417] [-Wmissing-signatures (in -Wall)]
     Top-level binding with no type signature: main :: IO ()
 
-T22483.hs:4:3: warning: [GHC-62161] [-Wincomplete-uni-patterns (in -Wall)]
+T22483.hs:4:4: warning: [GHC-62161] [-Wincomplete-uni-patterns (in -Wall)]
     Pattern match(es) are non-exhaustive
-    In a pattern binding:
+    In an irrefutable pattern:
         Patterns of type ‘Maybe ()’ not matched: Nothing


=====================================
testsuite/tests/deSugar/should_run/dsrun008.stderr
=====================================
@@ -1,2 +1,2 @@
-dsrun008: dsrun008.hs:2:15-42: Non-exhaustive patterns in (2, x)
+dsrun008: dsrun008.hs:2:32-36: Non-exhaustive patterns in (2, x)
 


=====================================
testsuite/tests/pmcheck/should_compile/T24234.hs
=====================================
@@ -0,0 +1,7 @@
+{-# OPTIONS_GHC -W #-}
+
+module T24234 where
+
+foo :: [()] -> ()
+foo ~(a:_) = a
+foo _      = ()


=====================================
testsuite/tests/pmcheck/should_compile/T24234.stderr
=====================================
@@ -0,0 +1,8 @@
+
+T24234.hs:6:6: warning: [GHC-62161] [-Wincomplete-uni-patterns (in -Wall)]
+    Pattern match(es) are non-exhaustive
+    In an irrefutable pattern: Patterns of type ‘[()]’ not matched: []
+
+T24234.hs:7:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)]
+    Pattern match is redundant
+    In an equation for ‘foo’: foo _ = ...


=====================================
testsuite/tests/pmcheck/should_compile/all.T
=====================================
@@ -120,6 +120,7 @@ test('T19271', [],  compile, [overlapping_incomplete])
 test('T21761', [],  compile, [overlapping_incomplete])
 test('T22964', [], compile, [overlapping_incomplete])
 test('T23445', [], compile, [overlapping_incomplete])
+test('T24234', [], compile, [overlapping_incomplete+'-Wincomplete-uni-patterns'])
 
 # Series (inspired) by Luke Maranget
 
@@ -166,4 +167,4 @@ test('EmptyCase009', [],  compile, [overlapping_incomplete])
 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'])
\ No newline at end of file
+test('DsIncompleteRecSel3', [collect_compiler_stats('bytes allocated', 10)], compile, ['-Wincomplete-record-selectors'])



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d46c49872e7b3d01abf65b78f2e4cc712a8e8f0b
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/20231201/b6da0fb3/attachment-0001.html>


More information about the ghc-commits mailing list