Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: b312c7ba by Apoorv Ingle at 2025-06-02T11:34:36-05:00 pass CtOrigin to tcApp for instantiateSigma - - - - - 7 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/Head.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Types/Origin.hs - testsuite/tests/typecheck/should_fail/T8603.stderr Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -179,17 +179,17 @@ tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcSigmaType tcInferSigma inst (L loc rn_expr) = addExprCtxt rn_expr $ setSrcSpanA loc $ - do { (_, app_res_sigma) <- tcExprSigma inst rn_expr + do { (_, app_res_sigma) <- tcExprSigma inst (exprCtOrigin rn_expr) rn_expr ; return app_res_sigma } --- Very similar to tcApp, but returns a sigma type +-- Very similar to tcApp, but returns a sigma (uninstantiated) type -- cf. T19167. the head is an expanded expression applied to a type -tcExprSigma :: Bool -> HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) -tcExprSigma inst rn_expr +tcExprSigma :: Bool -> CtOrigin -> HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) +tcExprSigma inst fun_orig rn_expr = do { (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr ; do_ql <- wantQuickLook rn_fun ; (tc_fun, fun_sigma) <- tcInferAppHead fun - ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args + ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst fun_orig (tc_fun, fun_ctxt) fun_sigma rn_args ; tc_args <- tcValArgs do_ql inst_args ; let tc_expr = rebuildHsApps (tc_fun, fun_ctxt) tc_args ; return (tc_expr, app_res_sigma) } @@ -397,11 +397,12 @@ Unify result type /before/ typechecking the args The latter is much better. That is why we call checkResultType before tcValArgs. -} -tcApp :: HsExpr GhcRn +tcApp :: CtOrigin + -> HsExpr GhcRn -> ExpRhoType -- When checking, -XDeepSubsumption <=> deeply skolemised -> TcM (HsExpr GhcTc) -- See Note [tcApp: typechecking applications] -tcApp rn_expr exp_res_ty +tcApp fun_orig rn_expr exp_res_ty = do { -- Step 1: Split the application chain (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr ; traceTc "tcApp {" $ @@ -421,7 +422,7 @@ tcApp rn_expr exp_res_ty , text "do_ql:" <+> ppr do_ql] ; (inst_args, app_res_rho) - <- tcInstFun do_ql True (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args + <- tcInstFun do_ql True fun_orig (tc_fun, fun_ctxt) fun_sigma rn_args ; case do_ql of NoQL -> do { traceTc "tcApp:NoQL" (ppr rn_fun $$ ppr app_res_rho) @@ -654,15 +655,17 @@ tcInstFun :: QLFlag -- in tcInferSigma, which is used only to implement :type -- Otherwise we do eager instantiation; in Fig 5 of the paper -- |-inst returns a rho-type - -> (HsExpr GhcTc, HsExpr GhcRn, AppCtxt) + -> CtOrigin + -> (HsExpr GhcTc, AppCtxt) -> TcSigmaType -> [HsExprArg 'TcpRn] -> TcM ( [HsExprArg 'TcpInst] , TcSigmaType ) -- This crucial function implements the |-inst judgement in Fig 4, plus the -- modification in Fig 5, of the QL paper: -- "A quick look at impredicativity" (ICFP'20). -tcInstFun do_ql inst_final (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args - = do { traceTc "tcInstFun" (vcat [ text "tc_fun" <+> ppr tc_fun +tcInstFun do_ql inst_final fun_orig (tc_fun, fun_ctxt) fun_sigma rn_args + = do { traceTc "tcInstFun" (vcat [ text "origin" <+> ppr fun_orig + , text "tc_fun" <+> ppr tc_fun , text "fun_sigma" <+> ppr fun_sigma , text "args:" <+> ppr rn_args , text "do_ql" <+> ppr do_ql @@ -671,8 +674,6 @@ tcInstFun do_ql inst_final (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args -- Note [tcApp: typechecking applications] go 1 [] fun_sigma rn_args } where - fun_orig = exprCtOrigin rn_fun - -- These are the type variables which must be instantiated to concrete -- types. See Note [Representation-polymorphic Ids with no binding] -- in GHC.Tc.Utils.Concrete @@ -1775,7 +1776,7 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) ; do_ql <- wantQuickLook rn_fun ; ((inst_args, app_res_rho), wanted) <- captureConstraints $ - tcInstFun do_ql True (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args + tcInstFun do_ql True (exprCtOrigin arg) (tc_fun, fun_ctxt) fun_sigma rn_args -- We must capture type-class and equality constraints here, but -- not equality constraints. See (QLA6) in Note [Quick Look at -- value arguments] ===================================== compiler/GHC/Tc/Gen/App.hs-boot ===================================== @@ -2,9 +2,10 @@ 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 -> HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) \ No newline at end of file +tcExprSigma :: Bool -> CtOrigin -> HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) \ No newline at end of file ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -175,7 +175,7 @@ tcPolyExprCheck expr res_ty -- The special case for lambda: go to tcLambdaMatches, passing pat_tys tc_body e@(HsLam x lam_variant matches) - = do { (wrap, matches') <- tcLambdaMatches e lam_variant matches pat_tys + = do { (wrap, matches') <- tcLambdaMatches e lam_variant matches pat_tys (mkCheckExpType rho_ty) -- NB: tcLambdaMatches concludes with deep skolemisation, -- if DeepSubsumption is on; hence no need to do that here @@ -265,6 +265,15 @@ tcMonoExprNC (L loc expr) res_ty do { expr' <- tcExpr expr res_ty ; return (L loc expr') } + +routes_via_tcApp :: HsExpr GhcRn -> Bool +routes_via_tcApp (HsVar {}) = True +routes_via_tcApp (HsApp {}) = True +routes_via_tcApp (OpApp {}) = True +routes_via_tcApp (HsAppType {}) = True +routes_via_tcApp (ExprWithTySig {}) = True +routes_via_tcApp _ = False + --------------- tcExpr :: HsExpr GhcRn -> ExpRhoType -- DeepSubsumption <=> when checking, this type @@ -286,14 +295,14 @@ tcExpr :: HsExpr GhcRn -- 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 -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 +-- See Note [Application chains and heads] in GHC.Tc.Gen.Ap +tcExpr e@(HsVar {}) res_ty = tcApp (exprCtOrigin e) e res_ty +tcExpr e@(HsApp {}) res_ty = tcApp (exprCtOrigin e) e res_ty +tcExpr e@(OpApp {}) res_ty = tcApp (exprCtOrigin e) e res_ty +tcExpr e@(HsAppType {}) res_ty = tcApp (exprCtOrigin e) e res_ty +tcExpr e@(ExprWithTySig {}) res_ty = tcApp (exprCtOrigin e) e res_ty -tcExpr (XExpr e) res_ty = tcXExpr e res_ty +tcExpr (XExpr e') res_ty = tcXExpr e' res_ty -- Typecheck an occurrence of an unbound Id -- @@ -362,7 +371,7 @@ tcExpr e@(HsOverLit _ lit) res_ty -- See Note [Short cut for overloaded literals] in GHC.Tc.Utils.TcMType ; case mb_res of Just lit' -> return (HsOverLit noExtField lit') - Nothing -> tcApp e res_ty } + Nothing -> tcApp (exprCtOrigin e) e res_ty } -- Why go via tcApp? See Note [Typechecking overloaded literals] {- Note [Typechecking overloaded literals] @@ -743,16 +752,19 @@ tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty) tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) tcXExpr (PopErrCtxt e) res_ty - = popErrCtxt $ -- See Part 3 of Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` - addExprCtxt e $ - tcExpr e res_ty + = do popErrCtxt $ -- See Part 3 of Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` + addExprCtxt e $ + tcExpr e res_ty -tcXExpr (ExpandedThingRn o e) res_ty +tcXExpr xe@(ExpandedThingRn o e) res_ty = mkExpandedTc o <$> -- necessary for breakpoints - do setInGeneratedCode $ tcExpr e res_ty + do setInGeneratedCode $ + if routes_via_tcApp e + then tcApp (exprCtOrigin (XExpr xe)) e res_ty + else tcExpr e res_ty -- For record selection, same as HsVar case -tcXExpr xe res_ty = tcApp (XExpr xe) res_ty +tcXExpr xe res_ty = tcApp (exprCtOrigin (XExpr xe)) (XExpr xe) res_ty {- ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -17,7 +17,7 @@ module GHC.Tc.Gen.Head ( HsExprArg(..), TcPass(..), QLFlag(..), EWrap(..) - , AppCtxt(..), appCtxtLoc, insideExpansion + , AppCtxt(..), appCtxtLoc, insideExpansion, appCtxtExpr , splitHsApps, rebuildHsApps , addArgWrap, isHsValArg , leadingValArgs, isVisibleArg @@ -247,7 +247,10 @@ appCtxtLoc :: AppCtxt -> SrcSpan appCtxtLoc (VACall _ _ l) = l insideExpansion :: AppCtxt -> Bool -insideExpansion (VACall _ _ loc) = isGeneratedSrcSpan loc +insideExpansion ctxt = isGeneratedSrcSpan (appCtxtLoc ctxt) + +appCtxtExpr :: AppCtxt -> HsExpr GhcRn +appCtxtExpr (VACall e _ _) = e instance Outputable QLFlag where ppr DoQL = text "DoQL" @@ -531,14 +534,15 @@ tcInferAppHead_maybe :: HsExpr GhcRn -> TcM (Maybe (HsExpr GhcTc, TcSigmaType)) -- See Note [Application chains and heads] in GHC.Tc.Gen.App -- Returns Nothing for a complicated head -tcInferAppHead_maybe fun - = case fun of +tcInferAppHead_maybe fun = + case fun of HsVar _ nm -> Just <$> tcInferId nm XExpr (HsRecSelRn f) -> Just <$> tcInferRecSelId f - XExpr (ExpandedThingRn _ e) -> Just <$> (setInGeneratedCode $ tcExprSigma False e) -- We do not want to instantiate e c.f. T19167 + XExpr (ExpandedThingRn _ e) -> Just <$> (setInGeneratedCode $ -- We do not want to instantiate c.f. T19167 + tcExprSigma False (exprCtOrigin fun) e) XExpr (PopErrCtxt e) -> tcInferAppHead_maybe e ExprWithTySig _ e hs_ty -> Just <$> tcExprWithSig e hs_ty - HsOverLit _ lit -> Just <$> tcInferOverLit lit -- TODO: Do we need this? + HsOverLit _ lit -> Just <$> tcInferOverLit lit _ -> return Nothing addHeadCtxt :: AppCtxt -> TcM a -> TcM a ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -22,7 +22,7 @@ import GHC.Tc.Instance.Typeable import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence import GHC.Tc.Types.CtLoc -import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(OccurrenceOf) ) +import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(GetFieldOrigin) ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst, FamInstEnvs ) import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) ) @@ -1327,7 +1327,8 @@ warnIncompleteRecSel dflags sel_id ct_loc -- GHC.Tc.Gen.App.tcInstFun arranges that the CtOrigin of (r.x) is GetFieldOrigin, -- despite the expansion to (getField @"x" r) - isGetFieldOrigin (OccurrenceOf f) = f `hasKey` getFieldClassOpKey + isGetFieldOrigin (GetFieldOrigin {}) = True + -- isGetFieldOrigin (OccurrenceOf f) = f `hasKey` getFieldClassOpKey isGetFieldOrigin _ = False lookupHasFieldLabel ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -758,8 +758,9 @@ exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole expression" exprCtOrigin (HsForAll {}) = Shouldn'tHappenOrigin "forall telescope" -- See Note [Types in terms] exprCtOrigin (HsQual {}) = Shouldn'tHappenOrigin "constraint context" -- See Note [Types in terms] exprCtOrigin (HsFunArr {}) = Shouldn'tHappenOrigin "function arrow" -- See Note [Types in terms] -exprCtOrigin (XExpr (ExpandedThingRn{})) = Shouldn'tHappenOrigin "XExpr ExpandedThingRn" -exprCtOrigin (XExpr (PopErrCtxt {})) = Shouldn'tHappenOrigin "PopErrCtxt" +exprCtOrigin (XExpr (ExpandedThingRn (OrigStmt {}) _)) = DoOrigin +exprCtOrigin (XExpr (ExpandedThingRn (OrigExpr e) _)) = exprCtOrigin e +exprCtOrigin (XExpr (PopErrCtxt e)) = exprCtOrigin e exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f) -- | Extract a suitable CtOrigin from a MatchGroup ===================================== testsuite/tests/typecheck/should_fail/T8603.stderr ===================================== @@ -14,15 +14,3 @@ T8603.hs:33:17: error: [GHC-18872] do prize <- lift uniform [1, 2, ....] return False -T8603.hs:33:22: error: [GHC-83865] - • Couldn't match type: RV a1 - with: StateT s RV a0 - Expected: [a1] -> StateT s RV a0 - Actual: [a1] -> RV a1 - • In the first argument of ‘lift’, namely ‘uniform’ - In the expression: lift uniform [1, 2, 3] - In the expression: - do prize <- lift uniform [1, 2, ....] - return False - • Relevant bindings include - testRVState1 :: RVState s Bool (bound at T8603.hs:32:1) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b312c7ba5b6b358c124e2c633fecd6f6... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b312c7ba5b6b358c124e2c633fecd6f6... You're receiving this email because of your account on gitlab.haskell.org.