Zubin pushed to branch wip/9.10.3-backports at Glasgow Haskell Compiler / GHC Commits: c6f8e88b by Vladislav Zavialov at 2025-07-16T17:59:21+05:30 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. (cherry picked from commit cce869ea2439bb16c284ce7ed71a173d54a8c9ad) - - - - - 7b1dbd0c by Vladislav Zavialov at 2025-07-16T18:04:08+05:30 Fix EmptyCase panic in tcMatches (#25960) Due to faulty reasoning in Note [Pattern types for EmptyCase], tcMatches was too keen to panic. * Old (incorrect) assumption: pat_tys is a singleton list. This does not hold when \case{} is checked against a function type preceded by invisible forall. See the new T25960 test case. * New (hopefully correct) assumption: vis_pat_tys is a singleton list. This should follow from: checkArgCounts :: MatchGroup GhcRn ... -> TcM VisArity checkArgCounts (MG { mg_alts = L _ [] }) = return 1 ... (cherry picked from commit b34890c7d4803041caff060391eec298e2b0a098) - - - - - 16bde049 by Andreas Klebinger at 2025-07-16T18:04:08+05:30 Add since tag and more docs for do-clever-arg-eta-expansion Fixes #26113 (cherry picked from commit 699deef58bf89ef2f111b35f72d303a3624d219d) - - - - - 14 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 - docs/users_guide/using-optimisation.rst - + testsuite/tests/typecheck/should_compile/T25960.hs - testsuite/tests/typecheck/should_compile/all.T - + testsuite/tests/typecheck/should_fail/T25004.hs - + testsuite/tests/typecheck/should_fail/T25004.stderr - + testsuite/tests/typecheck/should_fail/T25004k.hs - + testsuite/tests/typecheck/should_fail/T25004k.stderr - testsuite/tests/typecheck/should_fail/all.T Changes: ===================================== compiler/GHC/Rename/Bind.hs ===================================== @@ -1303,14 +1303,38 @@ 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) } + +-- Check the validity of a MatchGroup with an empty list of alternatives. +-- +-- 1. Normal `case x of {}` passes this check as long as EmptyCase is enabled. +-- Ditto lambda-case `\case {}`. +-- +-- 2. Multi-case with no alternatives `\cases {}` is never valid. +-- +-- 3. Other MatchGroup contexts (FunRhs, LamAlt LamSingle, etc) are not +-- considered here because there is no syntax to construct them with +-- no alternatives. +-- +-- Test case: rename/should_fail/RnEmptyCaseFail +-- +-- Validation continues in the type checker, namely in tcMatches. +-- See Note [Pattern types for EmptyCase] in GHC.Tc.Gen.Match +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 ===================================== @@ -55,7 +55,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 @@ -1299,24 +1299,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) @@ -2988,10 +2991,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(..) , TypeApplication(..) + , BadEmptyCaseReason(..) , HsTypeOrSigType(..) , HsTyVarBndrExistentialFlag(..) , TySynCycleTyCons @@ -204,7 +205,8 @@ 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) import GHC.Unit.State (UnitState) import GHC.Utils.Misc (filterOut) @@ -3005,13 +3007,27 @@ data TcRnMessage where a case expression with an empty list of alternatives without enabling the EmptyCase extension. - Example(s): + Example for EmptyCaseWithoutFlag: + + {-# LANGUAGE NoEmptyCase #-} + f :: Void -> a + f = \case {} -- extension not enabled + + Example for EmptyCaseDisallowedCtxt: - case () of + f = \cases {} -- multi-case requires n>0 alternatives + + Example for EmptyCaseForall: + + f :: forall (xs :: Type) -> () + f = \case {} -- can't match on a type argument Test cases: rename/should_fail/RnEmptyCaseFail + 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 @@ -6083,6 +6099,12 @@ data TypeApplication | TypeApplicationInPattern !(HsConPatTyArg GhcPs) 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 ===================================== @@ -319,8 +319,9 @@ tcCmdMatches :: CmdEnv -> CmdType -> TcM (HsWrapper, 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 ===================================== @@ -457,7 +457,7 @@ tcExpr (HsCase ctxt scrut matches) res_ty ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut ; hasFixedRuntimeRep_syntactic FRRCase scrut_ty - ; (mult_co_wrap, matches') <- tcCaseMatches tcBody (Scaled mult scrut_ty) matches res_ty + ; (mult_co_wrap, matches') <- tcCaseMatches ctxt tcBody (Scaled mult scrut_ty) matches res_ty ; return (HsCase ctxt (mkLHsWrap mult_co_wrap scrut') matches') } tcExpr (HsIf x pred b1 b2) res_ty ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -122,11 +122,12 @@ tcFunBindMatches ctxt fun_name mult matches invis_pat_tys exp_ty do { traceTc "tcFunBindMatches 2" (vcat [ pprUserTypeCtxt ctxt, ppr invis_pat_tys , ppr pat_tys $$ 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 <.> wrap_mult, r) } where - herald = ExpectedFunTyMatches (NameThing fun_name) matches + herald = ExpectedFunTyMatches (NameThing fun_name) matches + mctxt = mkPrefixFunRhs (noLocA fun_name) funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool funBindPrecondition (MG { mg_alts = L _ alts }) @@ -146,10 +147,11 @@ tcLambdaMatches e lam_variant matches invis_pat_tys res_ty ; (wrapper, (mult_co_wrap, 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 <.> mult_co_wrap, r) } where + ctxt = LamAlt lam_variant herald = ExpectedFunTyLam lam_variant e -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify @@ -167,7 +169,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 @@ -175,8 +178,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@. tcGRHSsPat :: Mult -> GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType @@ -223,23 +226,30 @@ 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 (HsWrapper, 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) + -- See Note [Pattern types for EmptyCase] + ; let vis_pat_tys = filter isVisibleExpPatType pat_tys + ; pat_ty <- case vis_pat_tys of + [ExpFunPatTy t] -> scaledExpTypeToType t + [ExpForAllPatTy tvb] -> failWithTc $ TcRnEmptyCase ctxt (EmptyCaseForall tvb) + [] -> panic "tcMatches: no arguments in EmptyCase" + _t1:(_t2:_ts) -> panic "tcMatches: multiple arguments in EmptyCase" ; rhs_ty <- expTypeToType rhs_ty ; return (idHsWrapper, MG { mg_alts = L l [] - , mg_ext = MatchGroupTc pat_tys rhs_ty origin + , mg_ext = MatchGroupTc [pat_ty] rhs_ty origin }) } | otherwise @@ -262,6 +272,43 @@ tcMatches tc_body pat_tys rhs_ty (MG { mg_alts = L l matches match_fun_pat_ty (ExpFunPatTy t) = Just t match_fun_pat_ty ExpForAllPatTy{} = Nothing +{- Note [Pattern types for EmptyCase] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In tcMatches, we might encounter an empty list of matches if the user wrote +`case x of {}` or `\case {}`. + +* First of all, both `case x of {}` and `\case {}` match on exactly one visible + argument, which follows from + + checkArgCounts :: MatchGroup GhcRn ... -> TcM VisArity + checkArgCounts (MG { mg_alts = L _ [] }) + = return 1 + ... + + So we expect vis_pat_tys to be a singleton list [pat_ty] and panic otherwise. + + Multi-case `\cases {}` can't violate this assumption in `tcMatches` because it + must have been rejected earlier in `rnMatchGroup`. + + Other MatchGroup contexts (function equations `f x = ...`, lambdas `\a b -> ...`, + etc) are not considered here because there is no syntax to construct them with + an empty list of alternatives. + +* With lambda-case, we run the risk of trying to match on a type argument: + + f :: forall (xs :: Type) -> () + f = \case {} + + This is not valid and it used to trigger a panic in pmcMatches (#25004). + We reject it by inspecting the expected pattern type: + + ; pat_ty <- case vis_pat_tys of + [ExpFunPatTy t] -> ... -- value argument, ok + [ExpForAllPatTy tvb] -> ... -- type argument, error! + + Test case: typecheck/should_fail/T25004 +-} + ------------- tcMatch :: (AnnoBody body) => TcMatchAltChecker body ===================================== docs/users_guide/using-optimisation.rst ===================================== @@ -517,16 +517,24 @@ as such you shouldn't need to set any of them explicitly. A flag Eta-expand let-bindings to increase their arity. .. ghc-flag:: -fdo-clever-arg-eta-expansion - :shortdesc: Enable sophisticated argument eta-expansion. Implied by :ghc-flag:`-O2`. + :shortdesc: Enable sophisticated argument eta-expansion. Implied by :ghc-flag:`-O`. :type: dynamic :reverse: -fno-do-clever-arg-eta-expansion :category: :default: off + :since: 9.10.1 Eta-expand arguments to increase their arity to avoid allocating unnecessary thunks for them. + For example in code like `foo = f (g x)` this flag will determine which analysis + is used to decide the arity of `g x`, with the goal of avoiding a thunk for `g x` + in cases where `g` is a function with an arity higher than one. + + Enabling the flag enables a more sophisticated analysis, resulting in better + runtime but longer compile time. + .. ghc-flag:: -feager-blackholing :shortdesc: Turn on :ref:`eager blackholing <parallel-compile-options>` :type: dynamic ===================================== testsuite/tests/typecheck/should_compile/T25960.hs ===================================== @@ -0,0 +1,12 @@ +{-# LANGUAGE LambdaCase #-} + +module T25960 where + +import Data.Void (Void) + +f :: (forall a. Void -> a) -> (forall a. Void -> a) +f g = g + +absurd :: Void -> a +absurd = f (\case) + ===================================== testsuite/tests/typecheck/should_compile/all.T ===================================== @@ -926,3 +926,4 @@ test('T24566', [], makefile_test, []) test('T23739a', normal, compile, ['']) test('T24810', normal, compile, ['']) test('T25597', normal, compile, ['']) +test('T25960', normal, compile, ['']) ===================================== 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/T25004k.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE RequiredTypeArguments, EmptyCase, LambdaCase #-} +{-# OPTIONS -Wincomplete-patterns #-} + +module T25004k where + +import Data.Kind + +f :: ((forall k. forall (xs :: k) -> ()) -> r) -> r +f cont = cont (\case {}) ===================================== testsuite/tests/typecheck/should_fail/T25004k.stderr ===================================== @@ -0,0 +1,7 @@ +T25004k.hs:9:16: error: [GHC-48010] + • Empty list of alternatives in \case expression + checked against a forall-type: forall (xs :: k) -> ... + • In the first argument of ‘cont’, namely ‘(\case)’ + In the expression: cont (\case) + In an equation for ‘f’: f cont = cont (\case) + ===================================== testsuite/tests/typecheck/should_fail/all.T ===================================== @@ -727,4 +727,6 @@ test('T24470a', normal, compile_fail, ['']) test('T24553', normal, compile_fail, ['']) test('T23739b', normal, compile_fail, ['']) -test('T25325', normal, compile_fail, ['']) \ No newline at end of file +test('T25325', normal, compile_fail, ['']) +test('T25004', normal, compile_fail, ['']) +test('T25004k', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/777810c8f32542d8486b5a53248225e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/777810c8f32542d8486b5a53248225e... You're receiving this email because of your account on gitlab.haskell.org.