[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
Tue Mar 4 02:07:44 UTC 2025
Vladislav Zavialov pushed to branch wip/int-index/vdq-emptycase-errmsg at Glasgow Haskell Compiler / GHC
Commits:
177148f7 by Vladislav Zavialov at 2025-03-04T05:07:27+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.
* XMG GhcRn now carries HsMatchContextRn, 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.
- - - - -
16 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Arrow.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/TyCl/PatSyn.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/Hs/Expr.hs
=====================================
@@ -1538,10 +1538,16 @@ instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where
************************************************************************
-}
-type instance XMG GhcPs b = Origin
-type instance XMG GhcRn b = Origin -- See Note [Generated code and pattern-match checking]
+type instance XMG GhcPs b = Origin -- See Note [Generated code and pattern-match checking]
+type instance XMG GhcRn b = MatchGroupRn
type instance XMG GhcTc b = MatchGroupTc
+data MatchGroupRn
+ = MatchGroupRn
+ { mg_rn_ctxt :: HsMatchContextRn
+ , mg_rn_origin :: Origin -- Origin (Generated vs FromSource)
+ }
+
data MatchGroupTc
= MatchGroupTc
{ mg_arg_tys :: [Scaled Type] -- Types of the arguments, t1..tn
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -400,6 +400,8 @@ deriving instance Data HsArrowMatchContext
deriving instance Data fn => Data (HsStmtContext fn)
deriving instance Data fn => Data (HsMatchContext fn)
+deriving instance Data MatchGroupRn
+
-- deriving instance (DataIdLR p p) => Data (HsUntypedSplice p)
deriving instance Data (HsUntypedSplice GhcPs)
deriving instance Data (HsUntypedSplice GhcRn)
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -268,14 +268,18 @@ mkHsAppType e t = addCLocA t_body e (HsAppType noExtField e paren_wct)
mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
mkHsAppTypes = foldl' mkHsAppType
-mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
+mkHsLam :: forall p. (IsPass p, p ~ NoGhcTcPass p)
=> LocatedE [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> LHsExpr (GhcPass p)
mkHsLam (L l pats) body = mkHsPar (L (getLoc body) (HsLam noAnn LamSingle matches))
where
- matches = mkMatchGroup (Generated OtherExpansion SkipPmc)
- (noLocA [mkSimpleMatch (LamAlt LamSingle) (L l pats') body])
+ ctxt = LamAlt LamSingle
+ origin = Generated OtherExpansion SkipPmc
+ mg_ext = case ghcPass @p of
+ GhcPs -> origin
+ GhcRn -> MatchGroupRn ctxt origin
+ matches = MG { mg_ext, mg_alts = noLocA [mkSimpleMatch ctxt (L l pats') body] }
pats' = map (parenthesizePat appPrec) pats
mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
@@ -837,7 +841,8 @@ mkTopFunBind :: Origin -> LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]
-> HsBind GhcRn
-- ^ In Name-land, with empty bind_fvs
mkTopFunBind origin fn ms = FunBind { fun_id = fn
- , fun_matches = mkMatchGroup origin (noLocA ms)
+ , fun_matches = MG { mg_ext = MatchGroupRn (mkPrefixFunRhs fn noAnn) origin
+ , mg_alts = noLocA ms }
, fun_ext = emptyNameSet -- NB: closed
-- binding
}
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -910,7 +910,7 @@ instance ( HiePass p
, toHie alts
]
where origin = case hiePass @p of
- HieRn -> mg_ext mg
+ HieRn -> mg_rn_origin $ mg_ext mg
HieTc -> mg_origin $ mg_ext mg
setOrigin :: Origin -> NodeOrigin -> NodeOrigin
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -1323,14 +1323,24 @@ 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) }
+ ; return (MG { mg_ext = MatchGroupRn ctxt origin
+ , mg_alts = 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/Rename/Utils.hs
=====================================
@@ -770,22 +770,30 @@ genFunBind :: LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]
-> HsBind GhcRn
genFunBind fn ms
= FunBind { fun_id = fn
- , fun_matches = mkMatchGroup (Generated OtherExpansion SkipPmc) (wrapGenSpan ms)
+ , fun_matches = MG { mg_ext = MatchGroupRn ctxt origin
+ , mg_alts = wrapGenSpan ms }
, fun_ext = emptyNameSet
}
+ where
+ ctxt = mkPrefixFunRhs fn noAnn
+ origin = Generated OtherExpansion SkipPmc
genHsLet :: HsLocalBindsLR GhcRn GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
genHsLet bindings body = HsLet noExtField bindings body
-genHsLamDoExp :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
+genHsLamDoExp :: forall p. (IsPass p, p ~ NoGhcTcPass p)
=> HsDoFlavour
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> LHsExpr (GhcPass p)
genHsLamDoExp doFlav pats body = mkHsPar (wrapGenSpan $ HsLam noAnn LamSingle matches)
where
- matches = mkMatchGroup (doExpansionOrigin doFlav)
- (wrapGenSpan [genSimpleMatch (StmtCtxt (HsDoStmt doFlav)) pats' body])
+ ctxt = StmtCtxt (HsDoStmt doFlav)
+ origin = doExpansionOrigin doFlav
+ mg_ext = case ghcPass @p of
+ GhcPs -> origin
+ GhcRn -> MatchGroupRn ctxt origin
+ matches = MG { mg_ext, mg_alts = wrapGenSpan [genSimpleMatch ctxt pats' body] }
pats' = map (parenthesizePat appPrec) pats
=====================================
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
=====================================
@@ -331,7 +331,7 @@ tcCmdMatchLambda :: CmdEnv
-> CmdType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc))
tcCmdMatchLambda env ctxt arity
- mg at MG { mg_alts = L l matches, mg_ext = origin }
+ mg at MG { mg_alts = L l matches, mg_ext = MatchGroupRn _ origin }
(cmd_stk, res_ty)
= do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs arity cmd_stk
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -214,7 +214,8 @@ mk_failable_expr doFlav pat@(L loc _) expr fail_op =
mk_fail_block :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn)
mk_fail_block doFlav pat@(L ploc _) e (Just (SyntaxExprRn fail_op)) =
do dflags <- getDynFlags
- return $ HsLam noAnn LamCases $ mkMatchGroup (doExpansionOrigin doFlav) -- \
+ return $ HsLam noAnn LamCases $ MG
+ (MatchGroupRn (LamAlt LamCases) (doExpansionOrigin doFlav)) -- \
(wrapGenSpan [ genHsCaseAltDoExp doFlav pat e -- pat -> expr
, fail_alt_case dflags pat fail_op -- _ -> fail "fail pattern"
])
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -1456,7 +1456,8 @@ expandRecordUpd record_expr possible_parents rbnds res_ty
case_expr :: HsExpr GhcRn
case_expr = HsCase RecUpd record_expr
- $ mkMatchGroup (Generated OtherExpansion DoPmc) (wrapGenSpan matches)
+ $ MG (MatchGroupRn CaseAlt (Generated OtherExpansion DoPmc))
+ (wrapGenSpan matches)
matches :: [LMatch GhcRn (LHsExpr GhcRn)]
matches = map make_pat (NE.toList relevant_cons)
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -164,7 +164,7 @@ tcLambdaMatches e lam_variant matches invis_pat_tys res_ty
herald = ExpectedFunTyLam lam_variant e
-- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify
- tc_body | isDoExpansionGenerated (mg_ext matches)
+ tc_body | isDoExpansionGenerated (mg_rn_origin $ mg_ext matches)
-- See Part 3. B. of Note [Expanding HsDo with XXExprGhcRn] in
-- `GHC.Tc.Gen.Do`. Testcase: Typeable1
= tcBodyNC -- NB: Do not add any error contexts
@@ -229,16 +229,21 @@ tcMatches :: (AnnoBody body, Outputable (body GhcTc))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
tcMatches tc_body pat_tys rhs_ty (MG { mg_alts = L l matches
- , mg_ext = origin })
+ , mg_ext = MatchGroupRn ctxt 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
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -943,11 +943,13 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
Unidirectional -> panic "tcPatSynBuilderBind"
mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
- mk_mg body = mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA [builder_match])
+ mk_mg body = MG (MatchGroupRn ctxt origin) (noLocA [builder_match])
where
+ ctxt = mkPrefixFunRhs ps_lname noAnn
+ origin = Generated OtherExpansion SkipPmc
builder_args = noLocA [(L (l2l loc) (VarPat noExtField (L loc n)))
| L loc n <- args]
- builder_match = mkMatch (mkPrefixFunRhs ps_lname noAnn)
+ builder_match = mkMatch ctxt
builder_args body
(EmptyLocalBinds noExtField)
=====================================
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/177148f778c4a3fc6f7b566aab145c0f7203ba27
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/177148f778c4a3fc6f7b566aab145c0f7203ba27
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/20250303/e4c566fa/attachment-0001.html>
More information about the ghc-commits
mailing list