Apoorv Ingle pushed to branch wip/ani/no-ds-flag-cache at Glasgow Haskell Compiler / GHC Commits: 97ca9953 by Apoorv Ingle at 2026-03-29T23:02:17-05:00 some comments and review changes - - - - - 50f0aaae by Apoorv Ingle at 2026-03-30T14:14:47-05:00 revert back rep-poly err messages - - - - - 43f1db4a by Apoorv Ingle at 2026-03-30T15:12:20-05:00 haddock comments for `tcValArg` and `cleanup getDeepSubsumption_flag` function - - - - - 4581bea6 by Apoorv Ingle at 2026-03-30T17:24:00-05:00 do not recurse in ExpandedThingTc HsApp etc in getDeepSubsumptionFlag - - - - - 63d6d3c3 by Apoorv Ingle at 2026-03-30T17:24:07-05:00 simplify get_Deepsubsumption_flag - - - - - 1de1038e by Simon Peyton Jones at 2026-03-30T17:24:45-05:00 Wibbles from Simon - - - - - f027edfc by Simon Peyton Jones at 2026-03-30T17:24:52-05:00 More wibbles - - - - - 12 changed files: - compiler/GHC/Tc/Gen/App.hs - − compiler/GHC/Tc/Gen/App.hs-boot - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs-boot - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/Unify.hs - testsuite/tests/rep-poly/RepPolyDoBind.stderr - testsuite/tests/rep-poly/RepPolyDoBody1.stderr - testsuite/tests/rep-poly/RepPolyDoBody2.stderr Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -11,7 +11,6 @@ module GHC.Tc.Gen.App ( tcApp - , tcExprSigma , tcExprPrag ) where import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr ) @@ -165,34 +164,6 @@ Note [Instantiation variables are short lived] -} -{- ********************************************************************* -* * - tcInferSigma -* * -********************************************************************* -} - --- Very similar to tcApp, but returns a sigma (uninstantiated) type --- CAUTION: Any changes to tcApp should be reflected here --- cf. T19167. the head is an expanded expression applied to a type --- Caution: Currently we assume that the expression is compiler generated/expanded --- Because that is what T19167 test case expects. --- This function should go away after MR!15778 lands -tcExprSigma :: Bool -> CtOrigin -> HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) -tcExprSigma inst fun_orig rn_expr - = do { (fun@(rn_fun,fun_lspan), rn_args) <- splitHsApps rn_expr - ; do_ql <- wantQuickLook rn_fun - ; (tc_fun, fun_sigma) <- tcInferAppHead fun - ; inGenCode <- inGeneratedCode - ; traceTc "tcExprSigma" (vcat [ text "rn_expr:" <+> ppr rn_expr - , text "tc_fun" <+> ppr tc_fun - , text "inGeneratedCode:" <+> ppr inGenCode]) - ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst (fun_orig, rn_fun, fun_lspan) - tc_fun fun_sigma rn_args - ; tc_args <- tcValArgs do_ql (rn_fun, fun_lspan) inst_args - ; let tc_expr = rebuildHsApps (tc_fun, fun_lspan) tc_args - ; return (tc_expr, app_res_sigma) } - - {- ********************************************************************* * * Typechecking n-ary applications @@ -488,8 +459,8 @@ checkResultTy :: HsExpr GhcRn -- expose foralls, but maybe not /deeply/ instantiated -> ExpRhoType -- Expected type; this is deeply skolemised -> TcM HsWrapper -checkResultTy rn_expr (tc_fun, _) _ app_res_rho (Infer inf_res) - = do { ds_flag <- getDeepSubsumptionFlag_DataConHead tc_fun +checkResultTy rn_expr _ _ app_res_rho (Infer inf_res) + = do { ds_flag <- getDeepSubsumptionFlag ; fillInferResult ds_flag (exprCtOrigin rn_expr) app_res_rho inf_res } @@ -539,7 +510,10 @@ checkResultTy rn_expr (tc_fun, fun_loc) inst_args app_res_rho (Check res_ty) thing_inside ---------------- -tcValArgs :: QLFlag -> (HsExpr GhcRn, SrcSpan) -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc] +tcValArgs :: QLFlag + -> (HsExpr GhcRn, SrcSpan) -- Head of the application chain (used only for error message generation) + -> [HsExprArg 'TcpInst] + -> TcM [HsExprArg 'TcpTc] -- Importantly, tcValArgs works left-to-right, so that by the time we -- encounter an argument, we have monomorphised all the instantiation -- variables that its type contains. All that is left to do is an ordinary @@ -553,7 +527,7 @@ tcValArgs do_ql (fun, fun_lspan) args = go do_ql 0 args ; return (arg' : args') } where -- increment position if the argument is user written type or value argument - pos' | EValArg{} <- arg + !pos' | EValArg{} <- arg = pos + 1 | EValArgQL{} <- arg = pos + 1 @@ -564,8 +538,11 @@ tcValArgs do_ql (fun, fun_lspan) args = go do_ql 0 args = pos -tcValArg :: QLFlag -> Int -> (HsExpr GhcRn, SrcSpan) -> HsExprArg 'TcpInst -- Actual argument - -> TcM (HsExprArg 'TcpTc) -- Resulting argument +tcValArg :: QLFlag -- ^ Are we typechecking with Quick Look turned on? + -> Int -- ^ Argument position (used only for error message generation) + -> (HsExpr GhcRn, SrcSpan) -- ^ Head of the application chain (used only for error message generation) + -> HsExprArg 'TcpInst -- ^ Actual argument + -> TcM (HsExprArg 'TcpTc) -- ^ Resulting argument tcValArg _ _ _ (EPrag l p) = return (EPrag l (tcExprPrag p)) tcValArg _ _ _ (ETypeArg l hty ty) = return (ETypeArg l hty ty) tcValArg do_ql _ _ (EWrap (EHsWrap w)) = do { whenQL do_ql $ qlMonoHsWrapper w @@ -630,7 +607,8 @@ tcValArg _ pos (fun, fun_lspan) (EValArgQL { , text "app_lspan" <+> ppr lspan , text "head_lspan" <+> ppr fun_lspan , text "tc_head" <+> ppr tc_head]) - ; ds_flag <- getDeepSubsumptionFlag_DataConHead (fst tc_head) + ; ds_flag <- getDeepSubsumptionFlag + -- NB: whether to do deep /skolemisation/ is independent of data constructors ; (wrap, arg') <- tcScalingUsage mult $ tcSkolemise ds_flag GenSigCtxt exp_arg_ty $ \ exp_arg_rho -> @@ -888,8 +866,7 @@ tcInstFun do_ql inst_final (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigma rn_arg matchActualFunTy herald (Just $ HsExprTcThing tc_fun) (n_val_args, fun_sigma) fun_ty - ; ds_flag <- getDeepSubsumptionFlag_DataConHead tc_fun - ; arg' <- quickLookArg ds_flag do_ql pos ctxt (rn_fun, fun_lspan) arg arg_ty + ; arg' <- quickLookArg do_ql pos ctxt (rn_fun, fun_lspan) arg arg_ty ; let acc' = arg' : addArgWrap (mkWpCastN fun_co) acc ; go (pos+1) acc' res_ty rest_args } @@ -910,7 +887,7 @@ tcInstFun do_ql inst_final (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigma rn_arg mk_herald :: HsExpr GhcTc -> HsExpr GhcRn -> ExpectedFunTyCtxt mk_herald tc_fun arg = case fun_orig of - DoStmtOrigin -> ExpectedTySyntax DoStmtOrigin arg + DoStmtOrigin -> ExpectedFunTySyntaxOp DoStmtOrigin tc_fun _ -> ExpectedFunTyArg (HsExprTcThing tc_fun) arg -- Is the argument supposed to instantiate a forall? @@ -1877,17 +1854,18 @@ This turned out to be more subtle than I expected. Wrinkles: -} -quickLookArg :: DeepSubsumptionFlag -> QLFlag -> Int +quickLookArg :: QLFlag -> Int -> SrcSpan -- ^ location span of the whole application -> (HsExpr GhcRn, SrcSpan) -- ^ Head of the application chain and its source span -> LHsExpr GhcRn -- ^ Argument -> Scaled TcSigmaTypeFRR -- ^ Type expected by the function -> TcM (HsExprArg 'TcpInst) -- See Note [Quick Look at value arguments] -quickLookArg _ NoQL _ app_lspan _ larg orig_arg_ty +quickLookArg NoQL _ app_lspan _ larg orig_arg_ty = skipQuickLook app_lspan larg orig_arg_ty -quickLookArg ds_flag DoQL pos app_lspan fun_and_lspan larg orig_arg_ty - = do { is_rho <- tcIsDeepRho ds_flag (scaledThing orig_arg_ty) +quickLookArg DoQL pos app_lspan fun_and_lspan larg orig_arg_ty + = do { ds_flag <- getDeepSubsumptionFlag + ; is_rho <- tcIsDeepRho ds_flag (scaledThing orig_arg_ty) ; traceTc "qla" (ppr orig_arg_ty $$ ppr is_rho) ; if not is_rho then skipQuickLook app_lspan larg orig_arg_ty ===================================== compiler/GHC/Tc/Gen/App.hs-boot deleted ===================================== @@ -1,12 +0,0 @@ -module GHC.Tc.Gen.App where - -import GHC.Hs ( HsExpr ) -import GHC.Tc.Types ( TcM ) -import GHC.Tc.Types.Origin ( CtOrigin ) -import GHC.Tc.Utils.TcType ( TcSigmaType ) -import GHC.Hs.Extension ( GhcRn, GhcTc ) - - -import GHC.Prelude (Bool) - -tcExprSigma :: Bool -> CtOrigin -> HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -13,7 +13,7 @@ module GHC.Tc.Gen.Expr ( tcCheckPolyExpr, tcCheckPolyExprNC, tcCheckMonoExpr, tcCheckMonoExprNC, - tcInferExpr, tcInferSigma, + tcInferExpr, tcInferSigma, tcInferExprSigma, tcInferRho, tcInferRhoNC, tcMonoLExpr, tcMonoLExprNC, tcInferRhoFRR, tcInferRhoFRRNC, @@ -237,6 +237,9 @@ tcPolyExprCheck expr res_ty tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType) tcInferSigma = tcInferExpr IIF_Sigma +tcInferExprSigma :: HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) +tcInferExprSigma e = runInfer IIF_Sigma IFRR_Any (tcExpr e) + tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) -- Infer a *rho*-type. The return type is always instantiated. tcInferRho = tcInferExpr IIF_DeepRho @@ -306,22 +309,25 @@ tcExpr :: HsExpr GhcRn -- - HsAppType type applications -- - ExprWithTySig (e :: type) -- - HsRecSel overloaded record fields --- - ExpandedThingRn renamer/pre-typechecker expansions -- - HsOpApp operator applications -- - HsOverLit overloaded literals -- These constructors are the union of -- - ones taken apart by GHC.Tc.Gen.Head.splitHsApps -- - ones understood by GHC.Tc.Gen.Head.tcInferAppHead_maybe -- See Note [Application chains and heads] in GHC.Tc.Gen.App --- Se Note [Typechecking by expansion: overview] tcExpr e@(HsVar {}) res_ty = tcApp e res_ty tcExpr e@(HsApp {}) res_ty = tcApp e res_ty tcExpr e@(OpApp {}) res_ty = tcApp e res_ty tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty +tcExpr e@(XExpr (HsRecSelRn{})) res_ty = tcApp e res_ty +-- Renamer expanded expressions (eg. Right/Left sections) +-- or tcExpr expanded expressions (eg. Do statements and Record updates) +-- are type checked using tcHsExpansion. +-- See Note [Typechecking by expansion: overview] tcExpr (XExpr (ExpandedThingRn hse)) res_ty = tcHsExpansion hse res_ty -tcExpr e@(XExpr{}) res_ty = tcApp e res_ty + -- Typecheck an occurrence of an unbound Id -- @@ -527,8 +533,9 @@ tcExpr (HsCase ctxt scrut matches) res_ty tcExpr (HsIf x pred b1 b2) res_ty = do { pred' <- tcCheckMonoExpr pred boolTy - ; (u1,b1') <- tcCollectingUsage $ tcMonoLExpr b1 res_ty - ; (u2,b2') <- tcCollectingUsage $ tcMonoLExpr b2 res_ty + ; let res_ty' = adjustExpTypeForCaseBranches res_ty [b1,b2] + ; (u1,b1') <- tcCollectingUsage $ tcMonoLExpr b1 res_ty' + ; (u2,b2') <- tcCollectingUsage $ tcMonoLExpr b2 res_ty' ; tcEmitBindingUsage (supUE u1 u2) ; return (HsIf x pred' b1' b2') } ===================================== compiler/GHC/Tc/Gen/Expr.hs-boot ===================================== @@ -35,6 +35,8 @@ tcInferRho, tcInferRhoNC :: tcInferRhoFRR, tcInferRhoFRRNC :: FixedRuntimeRepContext -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) +tcInferExprSigma :: HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) + tcInferExpr :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType) tcSyntaxOp :: CtOrigin ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -21,15 +21,14 @@ module GHC.Tc.Gen.Head , pprArgInst, addFunResCtxt ) where -import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig ) +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckPolyExprNC, tcPolyLExprSig, tcInferExprSigma ) import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody ) -import {-# SOURCE #-} GHC.Tc.Gen.App( tcExprSigma ) import GHC.Prelude import GHC.Hs import GHC.Hs.Syn.Type -import GHC.Rename.Utils (mkExpandedTc, mkExpandedExprTc) +import GHC.Rename.Utils (mkExpandedExprTc) import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Bind( chooseInferredQuantifiers ) @@ -446,8 +445,7 @@ tcInferAppHead (fun,fun_lspan) do { mb_tc_fun <- tcInferAppHead_maybe fun ; case mb_tc_fun of Just (fun', fun_sigma) -> return (fun', fun_sigma) - Nothing -> runInferRho (tcExpr fun) - + Nothing -> tcInferExprSigma fun } tcInferAppHead_maybe :: HsExpr GhcRn @@ -457,23 +455,11 @@ tcInferAppHead_maybe :: HsExpr GhcRn -- XExpr's although complicated needs to be looked through, useful for QL things when -- the argument is an XExpr tcInferAppHead_maybe fun = case fun of - HsVar _ nm - -> Just <$> tcInferId nm - ExprWithTySig _ e hs_ty - -> Just <$>tcExprWithSig e hs_ty - HsOverLit _ lit - -> Just <$> tcInferOverLit lit - XExpr (HsRecSelRn f) - -> Just <$> tcInferRecSelId f - XExpr (ExpandedThingRn (HSE o (L loc e))) - -> setSrcSpan (locA loc) $ Just <$> - do { (e', ty) <- tcExprSigma False (hsCtxtCtOrigin o) e - ; return (mkExpandedTc o (L loc e'), ty) } - -- We do not want to instantiate the type of the head as there may be - -- visible type applications in the argument. - -- c.f. T19167 - _ - -> return Nothing + HsVar _ nm -> Just <$> tcInferId nm + ExprWithTySig _ e hs_ty -> Just <$>tcExprWithSig e hs_ty + HsOverLit _ lit -> Just <$> tcInferOverLit lit + XExpr (HsRecSelRn f) -> Just <$> tcInferRecSelId f + _ -> return Nothing {- ********************************************************************* * * ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -219,10 +219,10 @@ tcMatches :: (AnnoBody body, Outputable (body GhcTc)) -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) -tcMatches ctxt tc_body pat_tys rhs_ty (MG { mg_alts = L l matches +tcMatches ctxt tc_body pat_tys exp_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 + -- Since there are no branches, no one else will fill in exp_ty -- when in inference mode, so we must do it ourselves, -- here, using expTypeToType = do { tcEmitBindingUsage bottomUE @@ -233,17 +233,19 @@ tcMatches ctxt tc_body pat_tys rhs_ty (MG { mg_alts = L l matches [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 + ; rhs_ty <- expTypeToType exp_ty ; return (MG { mg_alts = L l [] , mg_ext = MatchGroupTc [pat_ty] rhs_ty origin }) } | otherwise - = do { umatches <- mapM (tcCollectingUsage . tcMatch tc_body pat_tys rhs_ty) matches - ; let (usages, matches') = unzip umatches + = do { let exp_ty' = adjustExpTypeForCaseBranches exp_ty matches + tc_match match = tcCollectingUsage $ + tcMatch tc_body pat_tys exp_ty' match + ; (usages, matches') <- mapAndUnzipM tc_match matches ; tcEmitBindingUsage $ supUEs usages ; pat_tys <- mapM readScaledExpType (filter_out_forall_pat_tys pat_tys) - ; rhs_ty <- readExpType rhs_ty + ; rhs_ty <- readExpType exp_ty ; traceTc "tcMatches" (ppr matches' $$ ppr pat_tys $$ ppr rhs_ty) ; return (MG { mg_alts = L l matches' , mg_ext = MatchGroupTc pat_tys rhs_ty origin ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -1530,15 +1530,12 @@ data ExpectedFunTyCtxt -- | A rebindable syntax operator is expected to have a function type. -- -- Test cases for representation-polymorphism checks: - -- RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK + -- RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK = forall (p :: Pass) . (OutputableBndrId p) => ExpectedFunTySyntaxOp !CtOrigin !(HsExpr (GhcPass p)) -- ^ rebindable syntax operator - -- | - | ExpectedTySyntax !CtOrigin !(HsExpr GhcRn) - -- | A view pattern must have a function type. -- -- Test cases for representation-polymorphism checks: @@ -1594,9 +1591,6 @@ pprExpectedFunTyCtxt funTy_origin i = , text "the rebindable syntax operator" , quotes (ppr op) ] , nest 2 (ppr orig) ] - ExpectedTySyntax orig arg -> - vcat [ text "The expression" <+> quotes (ppr arg) - , nest 2 (ppr orig) ] ExpectedFunTyViewPat expr -> vcat [ the_arg_of <+> text "the view pattern" , nest 2 (ppr expr) ] @@ -1625,8 +1619,6 @@ pprExpectedFunTyCtxt funTy_origin i = pprExpectedFunTyHerald :: ExpectedFunTyCtxt -> SDoc pprExpectedFunTyHerald (ExpectedFunTySyntaxOp {}) = text "This rebindable syntax expects a function with" -pprExpectedFunTyHerald (ExpectedTySyntax orig _) - = pprCtOriginBriefly orig pprExpectedFunTyHerald (ExpectedFunTyViewPat {}) = text "A view pattern expression expects" pprExpectedFunTyHerald (ExpectedFunTyArg fun _) ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -63,7 +63,7 @@ module GHC.Tc.Utils.TcMType ( mkCheckExpType, newInferExpType, newInferExpTypeFRR, runInfer, runInferRho, runInferSigma, runInferKind, runInferRhoFRR, runInferSigmaFRR, readExpType, readExpType_maybe, readScaledExpType, - expTypeToType, scaledExpTypeToType, + expTypeToType, scaledExpTypeToType, adjustExpTypeForCaseBranches, checkingExpType_maybe, checkingExpType, inferResultToType, ensureMonoType, promoteTcType, @@ -499,6 +499,17 @@ inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr ; return tau } +adjustExpTypeForCaseBranches :: ExpRhoType -> [branch] -> ExpRhoType +-- See Note [fillInferResult: multiple branches] +adjustExpTypeForCaseBranches exp_ty branches + = case exp_ty of + Infer ir | IR { ir_inst = IIF_Sigma } <- ir + , branches `lengthAtLeast` 2 + -> Infer (ir { ir_inst = IIF_DeepRho }) + | otherwise + -> exp_ty + Check {} -> exp_ty + {- Note [inferResultToType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ expTypeToType and inferResultType convert an InferResult to a monotype. ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -426,7 +426,7 @@ Some examples: tcSkolemiseGeneral :: HasDebugCallStack - => DeepSubsumptionFlag + => DeepSubsumptionFlag -- Ignores the DeepSubsumptionDepth -> UserTypeCtxt -> TcType -> TcType -- top_ty and expected_ty -- Here, top_ty is the type we started to skolemise; used only in SigSkol @@ -1169,7 +1169,7 @@ fillInferResultNoInst act_res_ty (IR { ir_uniq = u ; return final_co } } -fillInferResult :: DeepSubsumptionFlag -> CtOrigin -> TcType -> InferResult -> TcM HsWrapper +fillInferResult :: DeepSubsumptionFlag -> CtOrigin -> TcSigmaType -> InferResult -> TcM HsWrapper -- See Note [Instantiation of InferResult] fillInferResult ds_flag ct_orig res_ty ires@(IR { ir_inst = iif }) = case iif of @@ -1203,7 +1203,7 @@ There are two things to worry about: T1 -> e1 T2 -> e2 -Our typing rules are: +In general our typing rules are: * The RHS of a existential or GADT alternative must always be a monotype, regardless of the number of alternatives. @@ -1218,17 +1218,13 @@ Our typing rules are: We use choice (2) in that Section. (GHC 8.10 and earlier used choice (1).) - But note that - case e of - True -> hr - False -> \x -> hr x - will fail, because we still /infer/ both branches, so the \x will get - a (monotype) unification variable, which will fail to unify with - (forall a. a->a) +Note [fillInferResult: GADTs and existentials] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can detect the GADT/existential situation, case (1) of Note [fillInferResult], +by seeing that the current TcLevel is greater than that stored in ir_lvl of the +Infer ExpType. We bump the level whenever we go past a GADT/existential match. -For (1) we can detect the GADT/existential situation by seeing that -the current TcLevel is greater than that stored in ir_lvl of the Infer -ExpType. We bump the level whenever we go past a GADT/existential match. +We insist that the RHS has a monotype, regardless of the number of alternatives. Then, before filling the hole use promoteTcType to promote the type to the outer ir_lvl. promoteTcType does this @@ -1239,11 +1235,6 @@ That forces the type to be a monotype (since unification variables can only unify with monotypes); and catches skolem-escapes because the alpha is untouchable until the equality floats out. -For (2), we simply look to see if the hole is filled already. - - if not, we promote (as above) and fill the hole - - if it is filled, we simply unify with the type that is - already there - (FIR1) There is one wrinkle. Suppose we have case e of T1 -> e1 :: (forall a. a->a) -> Int @@ -1258,7 +1249,47 @@ For (2), we simply look to see if the hole is filled already. So if we check G2 second, we still want to emit a constraint that restricts the RHS to be a monotype. This is done by ensureMonoType, and it works by simply generating a constraint (alpha ~ ty), where alpha is a fresh -unification variable. We discard the evidence. + unification variable. We discard the evidence. + +Note [fillInferResult: multiple branches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If there are multiple case branches, case (2) of Note [fillInferResult] +we simply look to see if the hole is filled already. + - if not, we promote (as above) and fill the hole + - if it is filled, we simply unify with the type that is already there + +But consider + case x of + True -> True + False -> undefined +and suppose we call `tcInferSigma` on this expression, so that the `ir_inst` +field of the expected result type is `IIF_Sigma`. The danger is that we'll +fill the hole with `Bool` (from the `True`) and then reject when we try to +unify that with `forall a. a->a`, from the call to `undefined`. + +Another example: + case x of + True -> (e1 :: forall a b. a->b) + False -> (e3 :: forall b a. a->b) + +To avoid this, we never infer a sigma-type from a multi-branch `case`. Instead +we just zap the `IIF_Sigma` to `IIF_DeepRho` when walking inside the branches +of multi-arm case-expression, or an if-expression. See calls to +`adjustExpTypeForCaseBranches`. + +This does mean that this would work: + (let x = 77+55 in h x x) @Int +where + h :: Int -> Int -> forall a. a->a +The `@Int` would instantiate the `forall a`. + +Note that + case e of + True -> hr + False -> \x -> hr x + where hr :: (forall a. a->a) -> Int +will fail, because we still /infer/ both branches, so the \x will get a +(monotype) unification variable, which will fail to unify with (forall a. a->a) Note [Instantiation of InferResult] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2068,37 +2099,19 @@ getDeepSubsumptionFlag = -- | Variant of 'getDeepSubsumptionFlag' which enables a top-level subsumption -- in order to implement the plan of Note [Typechecking data constructors]. getDeepSubsumptionFlag_DataConHead :: HsExpr GhcTc -> TcM DeepSubsumptionFlag -getDeepSubsumptionFlag_DataConHead app_head = - do { user_ds <- xoptM LangExt.DeepSubsumption - ; traceTc "getDeepSubsumptionFlag_DataConHead" (ppr app_head) - ; return $ - if | user_ds - -> Deep DeepSub - | otherwise - -> go app_head - } +getDeepSubsumptionFlag_DataConHead app_head + = do { user_ds <- xoptM LangExt.DeepSubsumption + ; return $ if | user_ds -> Deep DeepSub + | dc_head app_head -> Deep TopSub + | otherwise -> Shallow } where - go :: HsExpr GhcTc -> DeepSubsumptionFlag - go app_head - | XExpr (ConLikeTc (RealDataCon {})) <- app_head - = Deep TopSub - | XExpr (ExpandedThingTc (HSE _ (L _ f))) <- app_head - = go f - | XExpr (WrapExpr _ f) <- app_head - = go f - | HsVar _ f <- app_head - , isDataConId (unLoc f) - = Deep TopSub - | HsApp _ f _ <- app_head - = go (unLoc f) - | HsAppType _ f _ <- app_head - = go (unLoc f) - | OpApp _ _ f _ <- app_head - = go (unLoc f) - | HsPar _ f <- app_head - = go (unLoc f) - | otherwise - = Shallow + dc_head (XExpr (ConLikeTc (RealDataCon {}))) = True + dc_head (XExpr (WrapExpr _ f)) = dc_head f + dc_head (HsApp _ (L _ f) _) = dc_head f + dc_head (HsAppType _ (L _ f) _) = dc_head f + dc_head (OpApp _ _ (L _ f) _) = dc_head f + dc_head (HsPar _ (L _ f)) = dc_head f + dc_head _ = False -- | 'tc_sub_type_deep' is where the actual work happens for deep subsumption. ===================================== testsuite/tests/rep-poly/RepPolyDoBind.stderr ===================================== @@ -1,5 +1,5 @@ RepPolyDoBind.hs:26:3: error: [GHC-55287] - • The expression ‘undefined’ + • The first argument of the rebindable syntax operator ‘(>>=)’ arising from a do statement does not have a fixed runtime representation. Its type is: ===================================== testsuite/tests/rep-poly/RepPolyDoBody1.stderr ===================================== @@ -1,5 +1,5 @@ RepPolyDoBody1.hs:24:3: error: [GHC-55287] - • The expression ‘undefined :: ma’ + • The first argument of the rebindable syntax operator ‘(>>)’ arising from a do statement does not have a fixed runtime representation. Its type is: ===================================== testsuite/tests/rep-poly/RepPolyDoBody2.stderr ===================================== @@ -1,5 +1,5 @@ RepPolyDoBody2.hs:23:3: error: [GHC-55287] - • The expression ‘return ()’ + • The first argument of the rebindable syntax operator ‘(>>)’ arising from a do statement does not have a fixed runtime representation. Its type is: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b5adc452444e2fd8ea668fac5bd67fc... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b5adc452444e2fd8ea668fac5bd67fc... You're receiving this email because of your account on gitlab.haskell.org.