[Git][ghc/ghc][wip/expand-do] run the pattern match check in generated lambda exprs to avoid getting...
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Sat Apr 22 04:09:23 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
96efd55c by Apoorv Ingle at 2023-04-21T22:57:48-05:00
run the pattern match check in generated lambda exprs to avoid getting suprious pattern match failures. c.f. pmcheck/should_compile/DoubleMatch.hs
- - - - -
7 changed files:
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Pmc/Utils.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Match.hs
- + testsuite/tests/pmcheck/should_compile/DoubleMatch.hs
Changes:
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -150,6 +150,7 @@ dsHsBind dflags (VarBind { var_id = var
force_var = if xopt LangExt.Strict dflags
then [id]
else []
+ -- ; tracePm "dsHsBind" (vcat [text "VarBind:", ppr force_var, ppr core_bind])
; return (force_var, [core_bind]) }
dsHsBind dflags b@(FunBind { fun_id = L loc fun
@@ -179,10 +180,11 @@ dsHsBind dflags b@(FunBind { fun_id = L loc fun
= [id]
| otherwise
= []
- ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun)
- -- , ppr (mg_alts matches)
- -- , ppr args, ppr core_binds, ppr body']) $
- return (force_var, [core_binds]) } }
+ -- ; tracePm "dsHsBind" (vcat [ text "FunBind:",
+ -- , ppr fun <+> ppr (idInlinePragma fun)
+ -- , ppr (mg_alts matches)
+ -- , ppr args, ppr core_binds, ppr body'])
+ ; return (force_var, [core_binds]) } }
dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
, pat_ext = (ty, (rhs_tick, var_ticks))
@@ -197,6 +199,9 @@ dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
; let force_var' = if isBangedLPat pat'
then [force_var]
else []
+ -- ; tracePm "dsHsBind" (vcat [text "PatBind"
+ -- , ppr force_var'
+ -- , ppr sel_binds])
; return (force_var', sel_binds) }
dsHsBind
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -783,6 +783,9 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
-- Pattern match check warnings for /this match-group/.
-- @rhss_nablas@ is a flat list of covered Nablas for each RHS.
-- Each Match will split off one Nablas for its RHSs from this.
+ -- ; tracePm "matchWrapper" (vcat [ppr ctxt
+ -- , text "matchPmChecked"
+ -- , ppr $ isMatchContextPmChecked dflags origin ctxt])
; matches_nablas <- if isMatchContextPmChecked dflags origin ctxt
then addHsScrutTmCs (concat scrs) new_vars $
-- See Note [Long-distance information]
=====================================
compiler/GHC/HsToCore/Pmc.hs
=====================================
@@ -159,7 +159,7 @@ pmcMatches ctxt vars matches = {-# SCC "pmcMatches" #-} do
tracePm "pmcMatches {" $
hang (vcat [ppr ctxt, ppr vars, text "Matches:"])
2
- (vcat (map ppr matches) $$ ppr missing)
+ (vcat (map ppr matches) $$ (text "missing:" <+> ppr missing))
case NE.nonEmpty matches of
Nothing -> do
-- This must be an -XEmptyCase. See Note [Checking EmptyCase]
=====================================
compiler/GHC/HsToCore/Pmc/Utils.hs
=====================================
@@ -108,6 +108,9 @@ arrowMatchContextExhaustiveWarningFlag = \ case
-- 'HsMatchContext' (does not matter whether it is the redundancy check or the
-- exhaustiveness check).
isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool
+isMatchContextPmChecked _ origin LambdaExpr
+ | isGenerated origin
+ = True
isMatchContextPmChecked dflags origin kind
| isGenerated origin
= False
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -326,6 +326,7 @@ tcApp rn_expr exp_res_ty
= do { traceTc "tcApp {" $
vcat [ text "rn_fun:" <+> ppr rn_fun
, text "rn_args:" <+> ppr rn_args ]
+
; (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args
-- Instantiate
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -326,7 +326,9 @@ tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty
; let expand_do_expr = mkExpandedExpr (HsDo noExtField doExpr (L l stmts))
(unLoc expand_expr)
-- Do expansion on the fly
- ; traceTc "tcDoStmts do" (text "tcExpr:" <+> ppr expand_do_expr)
+ ; traceTc "tcDoStmts do" (vcat [ text "original:" <+> ppr expand_do_expr
+ , text "expnd:" <+> ppr expand_expr
+ ])
; tcExpr expand_do_expr res_ty
}
=====================================
testsuite/tests/pmcheck/should_compile/DoubleMatch.hs
=====================================
@@ -0,0 +1,18 @@
+{-# LANGUAGE CApiFFI, CPP, DeriveDataTypeable, NondecreasingIndentation #-}
+{-# OPTIONS_GHC -Wincomplete-patterns #-}
+{-# OPTIONS_GHC -fno-cse #-}
+module DoubleMatch where
+
+data Handler = Default
+ | Handler1
+
+doingThing :: Handler -> IO Int
+doingThing handler = do
+ v <- case handler of
+ Default -> return 0
+ _other_Handler -> do
+ asdf <- return 1
+ let action = case handler of
+ Handler1 -> 1
+ return action
+ return v
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/96efd55c5b3cbcbc01327521e36c8aba7a16b165
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/96efd55c5b3cbcbc01327521e36c8aba7a16b165
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/20230422/f27498a1/attachment-0001.html>
More information about the ghc-commits
mailing list