[Git][ghc/ghc][wip/int-index/vdq-emptycase-errmsg] Error message with EmptyCase and RequiredTypeArguments (#25004)
Vladislav Zavialov (@int-index)
gitlab at gitlab.haskell.org
Thu Mar 6 21:25:32 UTC 2025
Vladislav Zavialov pushed to branch wip/int-index/vdq-emptycase-errmsg at Glasgow Haskell Compiler / GHC
Commits:
b4999d0e by Vladislav Zavialov at 2025-03-07T00:02:14+03:00
Error message with EmptyCase and RequiredTypeArguments (#25004)
Fix a panic triggered by a combination of \case{} and forall t ->
ghci> let f :: forall (xs :: Type) -> (); f = \case {}
panic! (the 'impossible' happened)
GHC version 9.10.1:
Util: only
The new error message looks like this:
ghci> let f :: forall (xs :: Type) -> (); f = \case {}
<interactive>:5:41: error: [GHC-48010]
• Empty list of alternatives in \case expression
checked against a forall-type: forall xs -> ...
This is achieved as follows:
* A new data type, BadEmptyCaseReason, is now used to describe
why an empty case has been rejected. Used in TcRnEmptyCase.
* HsMatchContextRn is passed to tcMatches, so that the type checker
can attach the syntactic context to the error message.
* tcMatches now rejects type arguments if the list of alternatives is
empty. This is what fixes the bug.
- - - - -
9 changed files:
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Arrow.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- + testsuite/tests/typecheck/should_fail/T25004.hs
- + testsuite/tests/typecheck/should_fail/T25004.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -1323,14 +1323,23 @@ rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContextRn
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars)
rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_ext = origin })
-- see Note [Empty MatchGroups]
- = do { whenM ((null ms &&) <$> mustn't_be_empty) (addErr (TcRnEmptyCase ctxt))
+ = do { when (null ms) $ checkEmptyCase ctxt
; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
; return (mkMatchGroup origin (L lm new_ms), ms_fvs) }
+
+checkEmptyCase :: HsMatchContextRn -> RnM ()
+checkEmptyCase ctxt
+ | disallowed_ctxt =
+ addErr (TcRnEmptyCase ctxt EmptyCaseDisallowedCtxt)
+ | otherwise =
+ unlessXOptM LangExt.EmptyCase $
+ addErr (TcRnEmptyCase ctxt EmptyCaseWithoutFlag)
where
- mustn't_be_empty = case ctxt of
- LamAlt LamCases -> return True
- ArrowMatchCtxt (ArrowLamAlt LamCases) -> return True
- _ -> not <$> xoptM LangExt.EmptyCase
+ disallowed_ctxt =
+ case ctxt of
+ LamAlt LamCases -> True
+ ArrowMatchCtxt (ArrowLamAlt LamCases) -> True
+ _ -> False
rnMatch :: AnnoBody body
=> HsMatchContextRn
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -62,7 +62,7 @@ import GHC.Core.FamInstEnv ( FamInst(..), famInstAxiom, pprFamInst )
import GHC.Core.InstEnv
import GHC.Core.TyCo.Rep (Type(..))
import GHC.Core.TyCo.Ppr (pprWithInvisibleBitsWhen, pprSourceTyCon,
- pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType)
+ pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType, pprForAll)
import GHC.Core.PatSyn ( patSynName, pprPatSynType )
import GHC.Core.Predicate
import GHC.Core.Type
@@ -1359,24 +1359,27 @@ instance Diagnostic TcRnMessage where
text "Orphan COMPLETE pragmas not supported" $$
text "A COMPLETE pragma must mention at least one data constructor" $$
text "or pattern synonym defined in the same module."
- TcRnEmptyCase ctxt -> mkSimpleDecorated message
- where
- pp_ctxt = case ctxt of
- CaseAlt -> text "case expression"
- LamAlt LamCase -> text "\\case expression"
- ArrowMatchCtxt (ArrowLamAlt LamSingle) -> text "kappa abstraction"
- ArrowMatchCtxt (ArrowLamAlt LamCase) -> text "\\case command"
- ArrowMatchCtxt ArrowCaseAlt -> text "case command"
- _ -> text "(unexpected)"
- <+> pprMatchContextNoun ctxt
-
- message = case ctxt of
- LamAlt LamCases -> lcases_msg <+> text "expression"
- ArrowMatchCtxt (ArrowLamAlt LamCases) -> lcases_msg <+> text "command"
- _ -> text "Empty list of alternatives in" <+> pp_ctxt
-
- lcases_msg =
- text "Empty list of alternatives is not allowed in \\cases"
+ TcRnEmptyCase ctxt reason -> mkSimpleDecorated $
+ case reason of
+ EmptyCaseWithoutFlag ->
+ text "Empty list of alternatives in" <+> pp_ctxt
+ EmptyCaseDisallowedCtxt ->
+ text "Empty list of alternatives is not allowed in" <+> pp_ctxt
+ EmptyCaseForall tvb ->
+ vcat [ text "Empty list of alternatives in" <+> pp_ctxt
+ , hang (text "checked against a forall-type:")
+ 2 (pprForAll [tvb] <+> text "...")
+ ]
+ where
+ pp_ctxt = case ctxt of
+ CaseAlt -> text "case expression"
+ LamAlt LamCase -> text "\\case expression"
+ LamAlt LamCases -> text "\\cases expression"
+ ArrowMatchCtxt (ArrowLamAlt LamSingle) -> text "kappa abstraction"
+ ArrowMatchCtxt (ArrowLamAlt LamCase) -> text "\\case command"
+ ArrowMatchCtxt (ArrowLamAlt LamCases) -> text "\\cases command"
+ ArrowMatchCtxt ArrowCaseAlt -> text "case command"
+ ctxt -> text "(unexpected)" <+> pprMatchContextNoun ctxt
TcRnNonStdGuards (NonStandardGuards guards) -> mkSimpleDecorated $
text "accepting non-standard pattern guards" $$
nest 4 (interpp'SP guards)
@@ -3062,10 +3065,11 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnOrphanCompletePragma{}
-> noHints
- TcRnEmptyCase ctxt -> case ctxt of
- LamAlt LamCases -> noHints -- cases syntax doesn't support empty case.
- ArrowMatchCtxt (ArrowLamAlt LamCases) -> noHints
- _ -> [suggestExtension LangExt.EmptyCase]
+ TcRnEmptyCase _ reason ->
+ case reason of
+ EmptyCaseWithoutFlag{} -> [suggestExtension LangExt.EmptyCase]
+ EmptyCaseDisallowedCtxt{} -> noHints
+ EmptyCaseForall{} -> noHints
TcRnNonStdGuards{}
-> [suggestExtension LangExt.PatternGuards]
TcRnDuplicateSigDecl{}
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -103,6 +103,7 @@ module GHC.Tc.Errors.Types (
, DisabledClassExtension(..)
, TyFamsDisabledReason(..)
, BadInvisPatReason(..)
+ , BadEmptyCaseReason(..)
, HsTypeOrSigType(..)
, HsTyVarBndrExistentialFlag(..)
, TySynCycleTyCons
@@ -223,7 +224,7 @@ import GHC.Core.InstEnv (LookupInstanceErrReason, ClsInst, DFunId)
import GHC.Core.PatSyn (PatSyn)
import GHC.Core.Predicate (EqRel, predTypeEqRel)
import GHC.Core.TyCon (TyCon, Role, FamTyConFlav, AlgTyConRhs)
-import GHC.Core.Type (Kind, Type, ThetaType, PredType, ErrorMsgType, ForAllTyFlag)
+import GHC.Core.Type (Kind, Type, ThetaType, PredType, ErrorMsgType, ForAllTyFlag, ForAllTyBinder)
import GHC.Driver.Backend (Backend)
@@ -3086,8 +3087,11 @@ data TcRnMessage where
case () of
Test cases: rename/should_fail/RnEmptyCaseFail
+ testsuite/tests/typecheck/should_fail/T25004
-}
- TcRnEmptyCase :: HsMatchContextRn -> TcRnMessage
+ TcRnEmptyCase :: !HsMatchContextRn
+ -> !BadEmptyCaseReason
+ -> TcRnMessage
{-| TcRnNonStdGuards is a warning thrown when a user uses
non-standard guards (e.g. patterns in guards) without
@@ -6183,6 +6187,12 @@ data BadInvisPatReason
| InvisPatMisplaced
deriving (Generic)
+-- | Why was the empty case rejected?
+data BadEmptyCaseReason
+ = EmptyCaseWithoutFlag
+ | EmptyCaseDisallowedCtxt
+ | EmptyCaseForall ForAllTyBinder
+
-- | Either `HsType p` or `HsSigType p`.
--
-- Used for reporting errors in `TcRnIllegalKind`.
=====================================
compiler/GHC/Tc/Gen/Arrow.hs
=====================================
@@ -318,8 +318,9 @@ tcCmdMatches :: CmdEnv
-> CmdType
-> TcM (MatchGroup GhcTc (LHsCmd GhcTc))
tcCmdMatches env scrut_ty matches (stk, res_ty)
- = tcCaseMatches tc_body (unrestricted scrut_ty) matches (mkCheckExpType res_ty)
+ = tcCaseMatches ctxt tc_body (unrestricted scrut_ty) matches (mkCheckExpType res_ty)
where
+ ctxt = ArrowMatchCtxt ArrowCaseAlt
tc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'
; tcCmd env body (stk, res_ty') }
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -493,7 +493,7 @@ tcExpr (HsCase ctxt scrut matches) res_ty
; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut
; hasFixedRuntimeRep_syntactic FRRCase scrut_ty
- ; matches' <- tcCaseMatches tcBody (Scaled mult scrut_ty) matches res_ty
+ ; matches' <- tcCaseMatches ctxt tcBody (Scaled mult scrut_ty) matches res_ty
; return (HsCase ctxt scrut' matches') }
tcExpr (HsIf x pred b1 b2) res_ty
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -133,10 +133,11 @@ tcFunBindMatches ctxt fun_name mult matches invis_pat_tys exp_ty
, text "invis_pat_tys:" <+> ppr invis_pat_tys
, text "pat_tys:" <+> ppr pat_tys
, text "rhs_ty:" <+> ppr rhs_ty ]
- ; tcMatches tcBody (invis_pat_tys ++ pat_tys) rhs_ty matches }
+ ; tcMatches mctxt tcBody (invis_pat_tys ++ pat_tys) rhs_ty matches }
; return (wrap_fun, r) }
where
+ mctxt = mkPrefixFunRhs (noLocA fun_name) noAnn
herald = ExpectedFunTyMatches (NameThing fun_name) matches
funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool
@@ -157,10 +158,11 @@ tcLambdaMatches e lam_variant matches invis_pat_tys res_ty
; (wrapper, r)
<- matchExpectedFunTys herald GenSigCtxt arity res_ty $ \ pat_tys rhs_ty ->
- tcMatches tc_body (invis_pat_tys ++ pat_tys) rhs_ty matches
+ tcMatches ctxt tc_body (invis_pat_tys ++ pat_tys) rhs_ty matches
; return (wrapper, r) }
where
+ ctxt = LamAlt lam_variant
herald = ExpectedFunTyLam lam_variant e
-- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify
@@ -178,7 +180,8 @@ parser guarantees that each equation has exactly one argument.
-}
tcCaseMatches :: (AnnoBody body, Outputable (body GhcTc))
- => TcMatchAltChecker body -- ^ Typecheck the alternative RHSS
+ => HsMatchContextRn
+ -> TcMatchAltChecker body -- ^ Typecheck the alternative RHSS
-> Scaled TcSigmaTypeFRR -- ^ Type of scrutinee
-> MatchGroup GhcRn (LocatedA (body GhcRn)) -- ^ The case alternatives
-> ExpRhoType -- ^ Type of the whole case expression
@@ -186,8 +189,8 @@ tcCaseMatches :: (AnnoBody body, Outputable (body GhcTc))
-- Translated alternatives
-- wrapper goes from MatchGroup's ty to expected ty
-tcCaseMatches tc_body (Scaled scrut_mult scrut_ty) matches res_ty
- = tcMatches tc_body [ExpFunPatTy (Scaled scrut_mult (mkCheckExpType scrut_ty))] res_ty matches
+tcCaseMatches ctxt tc_body (Scaled scrut_mult scrut_ty) matches res_ty
+ = tcMatches ctxt tc_body [ExpFunPatTy (Scaled scrut_mult (mkCheckExpType scrut_ty))] res_ty matches
-- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind at .
tcGRHSsPat :: Mult -> GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType
@@ -222,23 +225,29 @@ type AnnoBody body
-- | Type-check a MatchGroup.
tcMatches :: (AnnoBody body, Outputable (body GhcTc))
- => TcMatchAltChecker body
+ => HsMatchContextRn
+ -> TcMatchAltChecker body
-> [ExpPatType] -- ^ Expected pattern types.
-> ExpRhoType -- ^ Expected result-type of the Match.
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
-tcMatches tc_body pat_tys rhs_ty (MG { mg_alts = L l matches
- , mg_ext = origin })
+tcMatches ctxt tc_body pat_tys rhs_ty (MG { mg_alts = L l matches
+ , mg_ext = origin })
| null matches -- Deal with case e of {}
-- Since there are no branches, no one else will fill in rhs_ty
-- when in inference mode, so we must do it ourselves,
-- here, using expTypeToType
= do { tcEmitBindingUsage bottomUE
- ; pat_tys <- mapM scaledExpTypeToType (filter_out_forall_pat_tys pat_tys)
+ ; pat_ty <- case pat_tys of
+ [ExpFunPatTy t] -> scaledExpTypeToType t
+ [ExpForAllPatTy tvb] -> failWithTc $ TcRnEmptyCase ctxt (EmptyCaseForall tvb)
+ -- It should be impossible to trigger the panics because the renamer rejects \cases{}
+ [] -> panic "tcMatches: no arguments in EmptyCase"
+ _t1:(_t2:_ts) -> panic "tcMatches: multiple arguments in EmptyCase"
; rhs_ty <- expTypeToType rhs_ty
; return (MG { mg_alts = L l []
- , mg_ext = MatchGroupTc pat_tys rhs_ty origin
+ , mg_ext = MatchGroupTc [pat_ty] rhs_ty origin
}) }
| otherwise
=====================================
testsuite/tests/typecheck/should_fail/T25004.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE RequiredTypeArguments, EmptyCase, LambdaCase #-}
+{-# OPTIONS -Wincomplete-patterns #-}
+
+module T25004 where
+
+import Data.Kind
+
+f :: forall (xs :: Type) -> ()
+f = \case {}
=====================================
testsuite/tests/typecheck/should_fail/T25004.stderr
=====================================
@@ -0,0 +1,6 @@
+T25004.hs:9:5: error: [GHC-48010]
+ • Empty list of alternatives in \case expression
+ checked against a forall-type: forall xs -> ...
+ • In the expression: \case
+ In an equation for ‘f’: f = \case
+
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -730,3 +730,4 @@ test('T23739c', normal, compile_fail, [''])
test('T24868', normal, compile_fail, [''])
test('T24938', normal, compile_fail, [''])
test('T25325', normal, compile_fail, [''])
+test('T25004', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b4999d0e99fe6edcaac1ca808796bc4c0b54a86c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b4999d0e99fe6edcaac1ca808796bc4c0b54a86c
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/20250306/0f046f2d/attachment-0001.html>
More information about the ghc-commits
mailing list