[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: compiler: Rejects RULES whose LHS immediately fails to type-check
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Jun 17 10:51:53 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
2114f60a by Fabricio de Sousa Nascimento at 2024-06-17T06:51:39-04:00
compiler: Rejects RULES whose LHS immediately fails to type-check
Fixes GHC crashing on `decomposeRuleLhs` due to ignoring coercion values. This
happens when we have a RULE that does not type check, and enable
`-fdefer-type-errors`. We prevent this to happen by rejecting RULES with an
immediately LHS type error.
Fixes #24026
- - - - -
d93014c4 by Dylan Thinnes at 2024-06-17T06:51:44-04:00
Add hscTypecheckRenameWithDiagnostics, for HLS (#24996)
Use runHsc' in runHsc so that both functions can't fall out of sync
We're currently copying parts of GHC code to get structured warnings
in HLS, so that we can recreate `hscTypecheckRenameWithDiagnostics`
locally. Once we get this function into GHC we can drop the copied code
in future versions of HLS.
- - - - -
9 changed files:
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/Tc/Gen/Rule.hs
- + testsuite/tests/typecheck/T24026/T24026a.hs
- + testsuite/tests/typecheck/T24026/T24026a.stderr
- + testsuite/tests/typecheck/T24026/T24026b.hs
- + testsuite/tests/typecheck/T24026/T24026b.stderr
- + testsuite/tests/typecheck/T24026/all.T
Changes:
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -86,8 +86,8 @@ import qualified Data.Set as Set
import GHC.Unit.Module.Graph
runHsc :: HscEnv -> Hsc a -> IO a
-runHsc hsc_env (Hsc hsc) = do
- (a, w) <- hsc hsc_env emptyMessages
+runHsc hsc_env hsc = do
+ (a, w) <- runHsc' hsc_env hsc
let dflags = hsc_dflags hsc_env
let !diag_opts = initDiagOpts dflags
!print_config = initPrintConfig dflags
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -64,6 +64,7 @@ module GHC.Driver.Main
, hscRecompStatus
, hscParse
, hscTypecheckRename
+ , hscTypecheckRenameWithDiagnostics
, hscTypecheckAndGetWarnings
, hscDesugar
, makeSimpleDetails
@@ -642,7 +643,14 @@ extract_renamed_stuff mod_summary tc_result = do
-- | Rename and typecheck a module, additionally returning the renamed syntax
hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
-> IO (TcGblEnv, RenamedStuff)
-hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $
+hscTypecheckRename hsc_env mod_summary rdr_module =
+ fst <$> hscTypecheckRenameWithDiagnostics hsc_env mod_summary rdr_module
+
+-- | Rename and typecheck a module, additionally returning the renamed syntax
+-- and the diagnostics produced.
+hscTypecheckRenameWithDiagnostics :: HscEnv -> ModSummary -> HsParsedModule
+ -> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage)
+hscTypecheckRenameWithDiagnostics hsc_env mod_summary rdr_module = runHsc' hsc_env $
hsc_typecheck True mod_summary (Just rdr_module)
-- | Do Typechecking without throwing SourceError exception with -Werror
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -1031,9 +1031,12 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs rhs_fvs
extra_bndrs = scopedSort extra_tvs ++ extra_dicts
where
extra_tvs = [ v | v <- extra_vars, isTyVar v ]
+
+ -- isEvVar: this includes coercions, matching what
+ -- happens in `split_lets` (isDictId, isCoVar)
extra_dicts =
- [ mkLocalId (localiseName (idName d)) ManyTy (idType d)
- | d <- extra_vars, isDictId d ]
+ [ mkLocalIdOrCoVar (localiseName (idName d)) ManyTy (idType d)
+ | d <- extra_vars, isEvVar d ]
extra_vars =
[ v
| v <- exprsFreeVarsList args
=====================================
compiler/GHC/Tc/Gen/Rule.hs
=====================================
@@ -108,11 +108,13 @@ tcRules decls = mapM (wrapLocMA tcRuleDecls) decls
tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc)
tcRuleDecls (HsRules { rds_ext = src
, rds_rules = decls })
- = do { tc_decls <- mapM (wrapLocMA tcRule) decls
+ = do { maybe_tc_decls <- mapM (wrapLocMA tcRule) decls
+ ; let tc_decls = [L loc rule | (L loc (Just rule)) <- maybe_tc_decls]
; return $ HsRules { rds_ext = src
, rds_rules = tc_decls } }
-tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTc)
+
+tcRule :: RuleDecl GhcRn -> TcM (Maybe (RuleDecl GhcTc))
tcRule (HsRule { rd_ext = ext
, rd_name = rname@(L _ name)
, rd_act = act
@@ -181,7 +183,17 @@ tcRule (HsRule { rd_ext = ext
; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs
lhs_evs rhs_wanted
; emitImplications (lhs_implic `unionBags` rhs_implic)
- ; return $ HsRule { rd_ext = ext
+
+ -- A type error on the LHS of a rule will be reported earlier while solving for
+ -- lhs_implic. However, we should also drop the rule entirely for cases where
+ -- compilation continues regardless of the error. For example with
+ -- `-fdefer-type-errors`, where this ill-typed LHS rule may cause follow-on errors
+ -- (#24026).
+ ; if anyBag insolubleImplic lhs_implic
+ then
+ return Nothing -- The RULE LHS does not type-check and will be dropped.
+ else
+ return . Just $ HsRule { rd_ext = ext
, rd_name = rname
, rd_act = act
, rd_tyvs = ty_bndrs -- preserved for ppr-ing
=====================================
testsuite/tests/typecheck/T24026/T24026a.hs
=====================================
@@ -0,0 +1,7 @@
+-- This rule has a type error on the LHS
+module T24026a where
+
+{-# RULES "f" forall (x :: Bool). f x = 0 #-}
+
+f :: Int -> Int
+f x = 0
=====================================
testsuite/tests/typecheck/T24026/T24026a.stderr
=====================================
@@ -0,0 +1,9 @@
+T24026a.hs:4:11: warning: [GHC-95396] [-Winline-rule-shadowing (in -Wdefault)]
+ Rule "f" may never fire because ‘f’ might inline first
+ Suggested fix: Add an INLINE[n] or NOINLINE[n] pragma for ‘f’
+
+T24026a.hs:4:37: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+ • Couldn't match expected type ‘Int’ with actual type ‘Bool’
+ • In the first argument of ‘f’, namely ‘x’
+ In the expression: f x
+ When checking the rewrite rule "f"
\ No newline at end of file
=====================================
testsuite/tests/typecheck/T24026/T24026b.hs
=====================================
@@ -0,0 +1,7 @@
+-- This rule has a type error on the LHS
+module T24026b where
+
+{-# RULES "f" forall (x :: Bool). f x = 0 #-}
+
+f :: Int -> Int
+f x = 0
=====================================
testsuite/tests/typecheck/T24026/T24026b.stderr
=====================================
@@ -0,0 +1,5 @@
+T24026b.hs:4:37: error: [GHC-83865]
+ • Couldn't match expected type ‘Int’ with actual type ‘Bool’
+ • In the first argument of ‘f’, namely ‘x’
+ In the expression: f x
+ When checking the rewrite rule "f"
\ No newline at end of file
=====================================
testsuite/tests/typecheck/T24026/all.T
=====================================
@@ -0,0 +1,2 @@
+test('T24026a', normal, compile, ['-dlint -fdefer-type-errors'])
+test('T24026b', normal, compile_fail, [''])
\ No newline at end of file
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3f9ee626cc0cc3423dfaa838186f4f9c49f1c2bd...d93014c4808da90d68c3b43b97afb2066fc94724
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3f9ee626cc0cc3423dfaa838186f4f9c49f1c2bd...d93014c4808da90d68c3b43b97afb2066fc94724
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/20240617/4c185a0b/attachment-0001.html>
More information about the ghc-commits
mailing list