Simon Peyton Jones pushed to branch wip/26543 at Glasgow Haskell Compiler / GHC Commits: b6dea5cf by Simon Peyton Jones at 2025-11-23T23:36:03+00:00 Expose results of result-type unification - - - - - 1 changed file: - compiler/GHC/Tc/Gen/App.hs Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -405,11 +405,12 @@ tcApp rn_expr exp_res_ty -- Step 5.1: Take a quick look at the result type ; quickLookResultType app_res_rho exp_res_ty - ; inst_args' <- mapM quickLookArg inst_args + ; inst_args' <- mapM zonkValArgType inst_args + ; inst_args'' <- mapM quickLookArg inst_args' -- Step 5.2: typecheck the arguments, and monomorphise -- any un-unified instantiation variables - ; tc_args <- tcValArgs DoQL inst_args' + ; tc_args <- tcValArgs DoQL inst_args'' -- Step 5.3: zonk to expose the polymorphism hidden under -- QuickLook instantiation variables in `app_res_rho` @@ -1843,8 +1844,7 @@ This turned out to be more subtle than I expected. Wrinkles: -} -quickLookArg :: HsExprArg 'TcpInst - -> TcM (HsExprArg 'TcpInst) +quickLookArg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpInst) -- quickLookArg1 implements the "QL Argument" judgement in Fig 5 of the paper -- See Note [Quick Look at value arguments] quickLookArg e_arg@(EValArg { ea_ctxt = ctxt @@ -1917,8 +1917,9 @@ quickLookArg e_arg@(EValArg { ea_ctxt = ctxt ; (arg_influences_call, inst_args') <- if isGuardedTy orig_arg_rho then do { qlUnify app_res_rho orig_arg_rho - ; inst_args' <- mapM quickLookArg inst_args - ; return (True, inst_args') } + ; inst_args' <- mapM zonkValArgType inst_args + ; inst_args'' <- mapM quickLookArg inst_args' + ; return (True, inst_args'') } else do { inst_args' <- mapM quickLookArg inst_args ; has_free_inst_vars <- anyFreeKappa app_res_rho ; if has_free_inst_vars @@ -1940,6 +1941,15 @@ quickLookArg e_arg@(EValArg { ea_ctxt = ctxt quickLookArg other_arg = return other_arg +zonkValArgType :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpInst) +zonkValArgType arg@(EValArg { ea_arg_ty = Scaled mult arg_rho }) + = do { arg_rho' <- liftZonkM $ zonkTcType arg_rho + ; return (arg { ea_arg_ty = Scaled mult arg_rho' }) } +zonkValArgType arg@(EValArgQL {}) + = pprPanic "zonkValArgType" (ppr arg) +zonkValArgType arg + = return arg + whenQL :: QLFlag -> ZonkM () -> TcM () whenQL DoQL thing_inside = liftZonkM thing_inside whenQL NoQL _ = return () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b6dea5cf14d690a961047db13944701b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b6dea5cf14d690a961047db13944701b... You're receiving this email because of your account on gitlab.haskell.org.