Apoorv Ingle pushed to branch wip/T27154 at Glasgow Haskell Compiler / GHC
Commits:
-
87ad4b80
by Simon Peyton Jones at 2026-04-06T13:30:20-05:00
5 changed files:
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Zonk/TcType.hs
Changes:
| ... | ... | @@ -7710,12 +7710,8 @@ pprHsCtxt = \case |
| 7710 | 7710 | PatSigErrCtxt sig_ty res_ty ->
|
| 7711 | 7711 | vcat [ hang (text "When checking that the pattern signature:")
|
| 7712 | 7712 | 4 (ppr sig_ty)
|
| 7713 | - , nest 2 (hang (text "fits the type of its context:") 2 pp_res_ty) ]
|
|
| 7714 | - where
|
|
| 7715 | - -- Zonking will have turned Infer into Check
|
|
| 7716 | - pp_res_ty = case res_ty of
|
|
| 7717 | - Check ty -> ppr ty
|
|
| 7718 | - Infer ir -> text "OOPS" <+> ppr ir
|
|
| 7713 | + , nest 2 (hang (text "fits the type of its context:")
|
|
| 7714 | + 2 (ppr (getCheckExpType res_ty))) ]
|
|
| 7719 | 7715 | |
| 7720 | 7716 | PatCtxt pat ->
|
| 7721 | 7717 | hang (text "In the pattern:") 2 (ppr pat)
|
| ... | ... | @@ -7777,7 +7773,7 @@ pprHsCtxt = \case |
| 7777 | 7773 | full_herald = pprExpectedFunTyHerald herald
|
| 7778 | 7774 | <+> speakNOf n_vis_args_in_call (text "visible argument")
|
| 7779 | 7775 | -- What are "visible" arguments? See Note [Visibility and arity] in GHC.Types.Basic
|
| 7780 | - FunResCtxt fun n_val_args res_fun res_env n_fun n_env
|
|
| 7776 | + FunResCtxt fun n_val_args fun_res_ty env_ty
|
|
| 7781 | 7777 | | -- Check for too few args
|
| 7782 | 7778 | -- fun_tau = a -> b, res_tau = Int
|
| 7783 | 7779 | n_fun > n_env
|
| ... | ... | @@ -7801,6 +7797,18 @@ pprHsCtxt = \case |
| 7801 | 7797 | -> empty
|
| 7802 | 7798 | -- text "Debug" <+> vcat [ppr fun, ppr n_val_args, ppr res_fun, ppr res_env, ppr n_fun, ppr n_env]
|
| 7803 | 7799 | where
|
| 7800 | + -- See Note [Splitting nested sigma types in mismatched
|
|
| 7801 | + -- function types]
|
|
| 7802 | + -- env_ty is an ExpRhoTy, but with simple subsumption it
|
|
| 7803 | + -- is not /deeply/ skolemised, so still use tcSplitNestedSigmaTys
|
|
| 7804 | + |
|
| 7805 | + (_,_,fun_tau) = tcSplitNestedSigmaTys fun_res_ty
|
|
| 7806 | + (_, _, env_tau) = tcSplitNestedSigmaTys (getCheckExpType env_ty)
|
|
| 7807 | + (args_fun, res_fun) = tcSplitFunTys fun_tau
|
|
| 7808 | + (args_env, res_env) = tcSplitFunTys env_tau
|
|
| 7809 | + n_fun = length args_fun
|
|
| 7810 | + n_env = length args_env
|
|
| 7811 | + |
|
| 7804 | 7812 | not_fun ty -- ty is definitely not an arrow type,
|
| 7805 | 7813 | -- and cannot conceivably become one
|
| 7806 | 7814 | = case tcSplitTyConApp_maybe ty of
|
| ... | ... | @@ -68,7 +68,6 @@ import GHC.Builtin.Names |
| 68 | 68 | import GHC.Driver.DynFlags
|
| 69 | 69 | import GHC.Utils.Misc
|
| 70 | 70 | import GHC.Utils.Outputable as Outputable
|
| 71 | -import GHC.Utils.Panic
|
|
| 72 | 71 | |
| 73 | 72 | import GHC.Data.Maybe
|
| 74 | 73 | |
| ... | ... | @@ -961,7 +960,8 @@ See Note [-fno-code mode]. |
| 961 | 960 | * *
|
| 962 | 961 | ********************************************************************* -}
|
| 963 | 962 | |
| 964 | -addFunResCtxt :: HsExpr GhcTc -> [HsExprArg p]
|
|
| 963 | +addFunResCtxt :: HasDebugCallStack
|
|
| 964 | + => HsExpr GhcTc -> [HsExprArg p]
|
|
| 965 | 965 | -> TcType -> ExpRhoType
|
| 966 | 966 | -> TcM a -> TcM a
|
| 967 | 967 | -- When we have a mis-match in the return type of a function
|
| ... | ... | @@ -969,33 +969,10 @@ addFunResCtxt :: HsExpr GhcTc -> [HsExprArg p] |
| 969 | 969 | -- But not in generated code, where we don't want
|
| 970 | 970 | -- to mention internal (rebindable syntax) function names
|
| 971 | 971 | addFunResCtxt fun args fun_res_ty env_ty thing_inside
|
| 972 | - = do { env_tv <- newFlexiTyVarTy liftedTypeKind
|
|
| 973 | - ; dumping <- doptM Opt_D_dump_tc_trace
|
|
| 974 | - ; msg <- mk_msg dumping env_tv
|
|
| 975 | - ; addErrCtxt msg thing_inside }
|
|
| 972 | + = addErrCtxt (FunResCtxt fun (count isValArg args) fun_res_ty env_ty) $
|
|
| 973 | + thing_inside
|
|
| 976 | 974 | -- NB: use a landmark error context, so that an empty context
|
| 977 | 975 | -- doesn't suppress some more useful context
|
| 978 | - where
|
|
| 979 | - mk_msg dumping env_tv
|
|
| 980 | - = do { mb_env_ty <- readExpType_maybe env_ty
|
|
| 981 | - -- by the time the message is rendered, the ExpType
|
|
| 982 | - -- will be filled in (except if we're debugging)
|
|
| 983 | - ; env' <- case mb_env_ty of
|
|
| 984 | - Just env_ty -> return env_ty
|
|
| 985 | - Nothing -> do { massert dumping; return env_tv }
|
|
| 986 | - ; let -- See Note [Splitting nested sigma types in mismatched
|
|
| 987 | - -- function types]
|
|
| 988 | - (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res_ty
|
|
| 989 | - (_, _, env_tau) = tcSplitNestedSigmaTys env'
|
|
| 990 | - -- env_ty is an ExpRhoTy, but with simple subsumption it
|
|
| 991 | - -- is not deeply skolemised, so still use tcSplitNestedSigmaTys
|
|
| 992 | - (args_fun, res_fun) = tcSplitFunTys fun_tau
|
|
| 993 | - (args_env, res_env) = tcSplitFunTys env_tau
|
|
| 994 | - info =
|
|
| 995 | - FunResCtxt fun (count isValArg args) res_fun res_env
|
|
| 996 | - (length args_fun) (length args_env)
|
|
| 997 | - ; return info }
|
|
| 998 | - |
|
| 999 | 976 | |
| 1000 | 977 | {-
|
| 1001 | 978 | Note [Splitting nested sigma types in mismatched function types]
|
| ... | ... | @@ -251,7 +251,10 @@ data HsCtxt |
| 251 | 251 | -- | In the instance type signature of a class method.
|
| 252 | 252 | | MethSigCtxt !Name !TcType !TcType
|
| 253 | 253 | -- | In a pattern type signature.
|
| 254 | + |
|
| 254 | 255 | | PatSigErrCtxt !TcType !ExpType
|
| 256 | + -- ExpType: see Note [ExpType in HsCtxt]
|
|
| 257 | + |
|
| 255 | 258 | -- | In a pattern.
|
| 256 | 259 | | PatCtxt !(Pat GhcRn)
|
| 257 | 260 | -- | In a pattern synonym declaration.
|
| ... | ... | @@ -268,7 +271,10 @@ data HsCtxt |
| 268 | 271 | -- | In a function call.
|
| 269 | 272 | | FunTysCtxt !ExpectedFunTyCtxt !Type !Int !Int
|
| 270 | 273 | -- | In the result of a function call.
|
| 271 | - | FunResCtxt !(HsExpr GhcTc) !Int !Type !Type !Int !Int
|
|
| 274 | + |
|
| 275 | + | FunResCtxt !(HsExpr GhcTc) !Int !TcType !ExpType
|
|
| 276 | + -- ExpType: see Note [ExpType in HsCtxt]
|
|
| 277 | + |
|
| 272 | 278 | -- | In the declaration of a type constructor.
|
| 273 | 279 | | TyConDeclCtxt !Name !(TyConFlavour TyCon)
|
| 274 | 280 | -- | In a type or data family instance (or default instance).
|
| ... | ... | @@ -377,3 +383,14 @@ isHsCtxtLandmark (DerivBindCtxt{}) = True |
| 377 | 383 | isHsCtxtLandmark (FunResCtxt{}) = True
|
| 378 | 384 | isHsCtxtLandmark (VDQWarningCtxt{}) = True
|
| 379 | 385 | isHsCtxtLandmark _ = False
|
| 386 | + |
|
| 387 | +{- Note [ExpType in HsCtxt]
|
|
| 388 | +~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
| 389 | +A couple of HsCtxt constructors have ExpTypes in them. When zonking the
|
|
| 390 | +Infer{} case we read the hole, which should be filled in by now, and zonk
|
|
| 391 | +that type. Now we want to put it back: we use (Check ty') for this, so that
|
|
| 392 | +clients of a zonked HsCtxt don't need to be monadic.
|
|
| 393 | + |
|
| 394 | +Result: after zonking, these ExpTypes are always (Check ty). It woudl be nice
|
|
| 395 | +to guarantee this statically, but it's hard to do so.
|
|
| 396 | +-} |
| ... | ... | @@ -28,7 +28,7 @@ module GHC.Tc.Utils.TcType ( |
| 28 | 28 | ExpType(..), ExpKind, InferResult(..), InferInstFlag(..), InferFRRFlag(..),
|
| 29 | 29 | ExpTypeFRR, ExpSigmaType, ExpSigmaTypeFRR,
|
| 30 | 30 | ExpRhoType, ExpRhoTypeFRR,
|
| 31 | - mkCheckExpType,
|
|
| 31 | + mkCheckExpType, getCheckExpType,
|
|
| 32 | 32 | checkingExpType_maybe, checkingExpType,
|
| 33 | 33 | |
| 34 | 34 | ExpPatType(..), mkCheckExpFunPatTy, mkInvisExpPatType,
|
| ... | ... | @@ -440,11 +440,12 @@ data InferInstFlag -- Specifies whether the inference should return an uninstan |
| 440 | 440 | |
| 441 | 441 | | IIF_ShallowRho -- Trying to infer a shallow RhoType (no foralls or => at the top)
|
| 442 | 442 | -- Top-instantiate (only, regardless of DeepSubsumption) before filling the hole
|
| 443 | - -- Typically used when inferring the type of an expression
|
|
| 443 | + -- Used only for view patterns; see Note [View patterns and polymorphism]
|
|
| 444 | 444 | |
| 445 | 445 | | IIF_DeepRho -- Trying to infer a possibly-deep RhoType (depending on DeepSubsumption)
|
| 446 | 446 | -- If DeepSubsumption is off, same as IIF_ShallowRho
|
| 447 | 447 | -- If DeepSubsumption is on, instantiate deeply before filling the hole
|
| 448 | + -- Typically used when inferring the type of an expression
|
|
| 448 | 449 | |
| 449 | 450 | type ExpSigmaType = ExpType
|
| 450 | 451 | type ExpRhoType = ExpType
|
| ... | ... | @@ -490,6 +491,12 @@ instance Outputable InferResult where |
| 490 | 491 | mkCheckExpType :: TcType -> ExpType
|
| 491 | 492 | mkCheckExpType = Check
|
| 492 | 493 | |
| 494 | +getCheckExpType :: HasDebugCallStack => ExpType -> TcType
|
|
| 495 | +-- Expect a (Check ty).
|
|
| 496 | +-- See Note [ExpType in HsCtxt] in GHC.Tc.Types.ErrCtxt
|
|
| 497 | +getCheckExpType (Check ty) = ty
|
|
| 498 | +getCheckExpType (Infer ir) = pprPanic "getCheckExpType" (ppr ir)
|
|
| 499 | + |
|
| 493 | 500 | -- | Returns the expected type when in checking mode.
|
| 494 | 501 | checkingExpType_maybe :: ExpType -> Maybe TcType
|
| 495 | 502 | checkingExpType_maybe (Check ty) = Just ty
|
| ... | ... | @@ -818,19 +818,26 @@ zonkTidyHsCtxt env e@(FunAppCtxt{}) = return (env, e) |
| 818 | 818 | zonkTidyHsCtxt env (FunTysCtxt ctxt ty i1 i2) = do
|
| 819 | 819 | (env', ty') <- zonkTidyTcType env ty
|
| 820 | 820 | return $ (env', FunTysCtxt ctxt ty' i1 i2)
|
| 821 | -zonkTidyHsCtxt env (FunResCtxt e i1 ty1 ty2 i2 i3) = do
|
|
| 822 | - (env', ty1') <- zonkTidyTcType env ty1
|
|
| 823 | - (env', ty2') <- zonkTidyTcType env' ty2
|
|
| 824 | - return $ (env', FunResCtxt e i1 ty1' ty2' i2 i3)
|
|
| 821 | +zonkTidyHsCtxt env (FunResCtxt e n ty1 env_ty) = do
|
|
| 822 | + (env', ty1') <- zonkTidyTcType env ty1
|
|
| 823 | + (env', env_ty') <- zonkExpType env' env_ty
|
|
| 824 | + return $ (env', FunResCtxt e n ty1' env_ty')
|
|
| 825 | 825 | zonkTidyHsCtxt env (PatSigErrCtxt sig_ty res_ty) = do
|
| 826 | 826 | (env', sig_ty') <- zonkTidyTcType env sig_ty
|
| 827 | - (env', res_ty') <-
|
|
| 828 | - case res_ty of
|
|
| 829 | - Check ty -> zonkTidyTcType env' ty
|
|
| 830 | - Infer (IR {ir_ref = ref}) -> do -- inlining readExpTyp_maybe to avoid module dep loops
|
|
| 831 | - mb_ty <- liftIO $ readIORef ref
|
|
| 832 | - case mb_ty of
|
|
| 833 | - Nothing -> error "zonkTidyHsCtxt PatSigErrCtxt"
|
|
| 834 | - Just ty -> zonkTidyTcType env' ty
|
|
| 835 | - return (env', PatSigErrCtxt sig_ty' (Check res_ty'))
|
|
| 827 | + (env', res_ty') <- zonkExpType env' res_ty
|
|
| 828 | + return (env', PatSigErrCtxt sig_ty' res_ty')
|
|
| 836 | 829 | zonkTidyHsCtxt env p = return (env, p)
|
| 830 | + |
|
| 831 | +zonkExpType :: TidyEnv -> ExpType -> ZonkM (TidyEnv, ExpType)
|
|
| 832 | +-- Zonk Infer{} to Check. The hole should have been filled in by now
|
|
| 833 | +zonkExpType env (Check ty)
|
|
| 834 | + = do { (env', ty') <- zonkTidyTcType env ty
|
|
| 835 | + ; return (env', Check ty') }
|
|
| 836 | +zonkExpType env (Infer ir@(IR { ir_ref = ref }))
|
|
| 837 | + = do { -- inlining readExpTyp_maybe to avoid module dep loops
|
|
| 838 | + ; mb_ty <- liftIO $ readIORef ref
|
|
| 839 | + ; case mb_ty of
|
|
| 840 | + Nothing -> pprPanic "zonkTidyHsCtxt PatSigErrCtxt" (ppr ir)
|
|
| 841 | + Just ty -> do { (env', ty') <- zonkTidyTcType env ty
|
|
| 842 | + ; return (env', Check ty') } }
|
|
| 843 | + |