[Git][ghc/ghc][wip/T24676] Wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue May 28 16:04:02 UTC 2024
Simon Peyton Jones pushed to branch wip/T24676 at Glasgow Haskell Compiler / GHC
Commits:
e44e27e3 by Simon Peyton Jones at 2024-05-28T17:03:43+01:00
Wibbles
- - - - -
3 changed files:
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Utils/TcType.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -341,7 +341,7 @@ tcApp rn_expr exp_res_ty
; (tc_fun, fun_sigma) <- tcInferAppHead fun
-- Instantiate
- ; do_ql <- wantQuickLook rn_fun
+ ; do_ql <- wantQuickLook rn_fun
; (inst_args, app_res_rho, res_wrap)
<- setQLInstLevel do_ql $
do { (inst_args, app_res_rho) <- tcInstFun do_ql True fun_ctxt tc_fun fun_sigma rn_args
@@ -349,18 +349,19 @@ tcApp rn_expr exp_res_ty
; return (inst_args, app_res_rho, res_wrap) }
-- Monomorphise any leftover instantiation variables
- ; when do_ql (monomorphiseQLInstVars inst_args app_res_rho)
+ ; case do_ql of
+ DoQL -> monomorphiseQLInstVars inst_args app_res_rho
+ NoQL -> return ()
-- Typecheck the arguments
; tc_app <- finishApp do_ql fun_ctxt tc_fun inst_args app_res_rho
; return (mkHsWrap res_wrap tc_app) }
-setQLInstLevel :: Bool -> TcM a -> TcM a
-setQLInstLevel do_ql thing_inside
- | do_ql = setTcLevel QLInstVar thing_inside
- | otherwise = thing_inside
+setQLInstLevel :: QLFlag -> TcM a -> TcM a
+setQLInstLevel DoQL thing_inside = setTcLevel QLInstVar thing_inside
+setQLInstLevel NoQL thing_inside = thing_inside
-finishApp :: Bool -> AppCtxt
+finishApp :: QLFlag -> AppCtxt
-> HsExpr GhcTc -> [HsExprArg 'TcpInst]
-> TcRhoType
-> TcM (HsExpr GhcTc)
@@ -430,29 +431,16 @@ unifyResTy rn_expr fun_ctxt tc_fun inst_args app_res_rho exp_res_ty
--------------------
-wantQuickLook :: HsExpr GhcRn -> TcM Bool
+wantQuickLook :: HsExpr GhcRn -> TcM QLFlag
wantQuickLook (HsVar _ (L _ f))
- | getUnique f `elem` quickLookKeys = return True
-wantQuickLook _ = xoptM LangExt.ImpredicativeTypes
+ | getUnique f `elem` quickLookKeys = return DoQL
+wantQuickLook _ = do { impred <- xoptM LangExt.ImpredicativeTypes
+ ; if impred then return DoQL else return NoQL }
quickLookKeys :: [Unique]
-- See Note [Quick Look for particular Ids]
quickLookKeys = [dollarIdKey, leftSectionKey, rightSectionKey]
-zonkQuickLook :: Bool -> TcType -> ZonkM TcType
--- After all Quick Look unifications are done, zonk to ensure that all
--- instantiation variables are substituted away
---
--- So far as the paper is concerned, this step applies
--- the poly-substitution Theta, learned by QL, so that we
--- "see" the polymorphism in that type
---
--- In implementation terms this ensures that no unification variable
--- linger on that have been filled in with a polytype
-zonkQuickLook do_ql ty
- | do_ql = zonkTcType ty
- | otherwise = return ty
-
-- zonkArg is used *only* during debug-tracing, to make it easier to
-- see what is going on. For that reason, it is not a full zonk: add
-- more if you need it.
@@ -476,9 +464,9 @@ tcValArg (EPrag l p) = return (EPrag l (tcExprPrag p))
tcValArg (EWrap w) = return (EWrap w)
tcValArg (ETypeArg l hs_ty ty) = return (ETypeArg l hs_ty ty)
-tcValArg eva@(EValArg { ea_ctxt = ctxt
- , ea_arg = larg@(L arg_loc arg)
- , ea_arg_ty = (do_zonk, Scaled mult arg_ty) })
+tcValArg (EValArg { ea_ctxt = ctxt
+ , ea_arg = larg@(L arg_loc arg)
+ , ea_arg_ty = (do_zonk, Scaled mult arg_ty) })
= addArgCtxt ctxt larg $
do { traceTc "tcValArg" $
vcat [ ppr ctxt
@@ -494,14 +482,17 @@ tcValArg eva@(EValArg { ea_ctxt = ctxt
-- Then Theta = [p :-> forall a. a->a], and we want
-- to check 'e' with expected type (forall a. a->a)
-- See Note [Instantiation variables are short lived]
- ; arg_ty <- if do_zonk then liftZonkM $ zonkTcType arg_ty
- else return arg_ty
+ ; arg_ty <- case do_zonk of
+ DoQL -> liftZonkM $ zonkTcType arg_ty
+ NoQL -> return arg_ty
-- Now check the argument
; arg' <- tcScalingUsage mult $
tcPolyExpr arg (mkCheckExpType arg_ty)
- ; return (eva { ea_arg = L arg_loc arg' }) }
+ ; return (EValArg { ea_ctxt = ctxt
+ , ea_arg = L arg_loc arg'
+ , ea_arg_ty = noExtField }) }
tcValArg (EValArgQL { eaql_status = ql_status
, eaql_ctxt = ctxt
@@ -515,14 +506,14 @@ tcValArg (EValArgQL { eaql_status = ql_status
tcScalingUsage mult $
case ql_status of
QLUnified res_wrap
- -> do { tc_app <- finishApp True ctxt tc_fun inst_args res_rho
+ -> do { tc_app <- finishApp DoQL ctxt tc_fun inst_args res_rho
; return (EValArg { ea_ctxt = ctxt
, ea_arg = L arg_loc (mkHsWrap res_wrap tc_app)
- , ea_arg_ty = (True, Scaled mult arg_ty) }) }
+ , ea_arg_ty = noExtField }) }
QLIndependent wc
-> do { -- Expose QL results, as in the EValArg case
- ; arg_ty <- liftZonkM $ zonkQuickLook True arg_ty
+ ; arg_ty <- liftZonkM $ zonkTcType arg_ty
; traceTc "tcEValArgQL {" (vcat [ ppr rn_head
, text "status:" <+> ppr ql_status
@@ -536,7 +527,7 @@ tcValArg (EValArgQL { eaql_status = ql_status
do { emitConstraints wc
; res_wrap <- unifyResTy rn_expr ctxt tc_fun inst_args res_rho (mkCheckExpType arg_rho)
; monomorphiseQLInstVars inst_args res_rho
- ; tc_app <- finishApp True ctxt tc_fun inst_args res_rho
+ ; tc_app <- finishApp DoQL ctxt tc_fun inst_args res_rho
; return (mkHsWrap res_wrap tc_app) }
; traceTc "tcEValArgQL }" $
@@ -545,7 +536,7 @@ tcValArg (EValArgQL { eaql_status = ql_status
; return (EValArg { ea_ctxt = ctxt
, ea_arg = L arg_loc (mkHsWrap wrap arg')
- , ea_arg_ty = (True, Scaled mult arg_ty) }) }
+ , ea_arg_ty = noExtField }) }
-- Tricky point: with deep subsumption, even if ql_status=QLUnified
@@ -565,7 +556,7 @@ tcValArg (EValArgQL { eaql_status = ql_status
type Delta = Bool -- True <=> at least one instantiation variable
-tcInstFun :: Bool -- True <=> Do quick-look
+tcInstFun :: QLFlag
-> Bool -- False <=> Instantiate only /inferred/ variables at the end
-- so may return a sigma-type
-- True <=> Instantiate all type variables at the end:
@@ -590,7 +581,7 @@ tcInstFun do_ql inst_final fun_ctxt tc_fun fun_sigma rn_args
, text "fun_ctxt" <+> ppr fun_ctxt
, text "args:" <+> ppr rn_args
, text "do_ql" <+> ppr do_ql ])
- ; (_delta, inst_args, res_rho) <- go False [] [] fun_sigma rn_args
+ ; (_delta, inst_args, res_rho) <- go 1 False [] fun_sigma rn_args
-- ToDo: remove delta from go
; return (inst_args, res_rho) }
where
@@ -635,35 +626,35 @@ tcInstFun do_ql inst_final fun_ctxt tc_fun fun_sigma rn_args
inst_fun _ = isInferredForAllTyFlag
-----------
- go, go1 :: Delta -- True <=> at least one instantiation variable
+ go, go1 :: Int -- Value-argument position of next arg
+ -> Delta -- True <=> at least one instantiation variable
-> [HsExprArg 'TcpInst] -- Accumulator, reversed
- -> [Scaled TcSigmaTypeFRR] -- Value args to which applied so far
-> TcSigmaType -> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcSigmaType)
-- go: If fun_ty=kappa, look it up in Theta
- go delta acc so_far fun_ty args
+ go pos delta acc fun_ty args
| Just kappa <- getTyVar_maybe fun_ty
, isQLInstTyVar kappa
= do { cts <- readMetaTyVar kappa
; case cts of
- Indirect fun_ty' -> go delta acc so_far fun_ty' args
- Flexi -> go1 delta acc so_far fun_ty args }
+ Indirect fun_ty' -> go pos delta acc fun_ty' args
+ Flexi -> go1 pos delta acc fun_ty args }
| otherwise
- = go1 delta acc so_far fun_ty args
+ = go1 pos delta acc fun_ty args
-- go1: fun_ty is not filled-in instantiation variable
-- ('go' dealt with that case)
-- Handle out-of-scope functions gracefully
- go1 delta acc so_far fun_ty (arg : rest_args)
+ go1 pos delta acc fun_ty (arg : rest_args)
| fun_is_out_of_scope, looks_like_type_arg arg -- See Note [VTA for out-of-scope functions]
- = go delta acc so_far fun_ty rest_args
+ = go pos delta acc fun_ty rest_args
-- Rule IALL from Fig 4 of the QL paper; applies even if args = []
-- Instantiate invisible foralls and dictionaries.
-- c.f. GHC.Tc.Utils.Instantiate.topInstantiate
- go1 delta acc so_far fun_ty args
+ go1 pos delta acc fun_ty args
| (tvs, body1) <- tcSplitSomeForAllTyVars (inst_fun args) fun_ty
, (theta, body2) <- if inst_fun args Inferred
then tcSplitPhiTy body1
@@ -691,41 +682,41 @@ tcInstFun do_ql inst_final fun_ctxt tc_fun fun_sigma rn_args
-- argument of (#,#) to @LiftedRep, but want to rule out the
-- second instantiation @r.
- ; go (delta || not no_tvs)
- (addArgWrap wrap acc) so_far fun_rho args }
+ ; go pos (delta || not no_tvs)
+ (addArgWrap wrap acc) fun_rho args }
-- Going around again means we deal easily with
-- nested forall a. Eq a => forall b. Show b => blah
-- Rule ITVDQ from the GHC Proposal #281
- go1 delta acc so_far fun_ty ((EValArg { ea_arg = arg }) : rest_args)
+ go1 pos delta acc fun_ty ((EValArg { ea_arg = arg }) : rest_args)
| Just (tvb, body) <- tcSplitForAllTyVarBinder_maybe fun_ty
= assertPpr (binderFlag tvb == Required) (ppr fun_ty $$ ppr arg) $
-- Any invisible binders have been instantiated by IALL above,
-- so this forall must be visible (i.e. Required)
do { (ty_arg, inst_body) <- tcVDQ fun_conc_tvs (tvb, body) arg
; let wrap = mkWpTyApps [ty_arg]
- ; go delta (addArgWrap wrap acc) so_far inst_body rest_args }
+ ; go (pos+1) delta (addArgWrap wrap acc) inst_body rest_args }
-- Rule IRESULT from Fig 4 of the QL paper
- go1 delta acc _ fun_ty []
+ go1 _pos delta acc fun_ty []
= do { traceTc "tcInstFun:ret" (ppr fun_ty)
; return (delta, reverse acc, fun_ty) }
- go1 delta acc so_far fun_ty (EWrap w : args)
- = go1 delta (EWrap w : acc) so_far fun_ty args
+ go1 pos delta acc fun_ty (EWrap w : args)
+ = go1 pos delta (EWrap w : acc) fun_ty args
- go1 delta acc so_far fun_ty (EPrag sp prag : args)
- = go1 delta (EPrag sp prag : acc) so_far fun_ty args
+ go1 pos delta acc fun_ty (EPrag sp prag : args)
+ = go1 pos delta (EPrag sp prag : acc) fun_ty args
-- Rule ITYARG from Fig 4 of the QL paper
- go1 delta acc so_far fun_ty ( ETypeArg { ea_ctxt = ctxt, ea_hs_ty = hs_ty }
- : rest_args )
+ go1 pos delta acc fun_ty ( ETypeArg { ea_ctxt = ctxt, ea_hs_ty = hs_ty }
+ : rest_args )
= do { (ty_arg, inst_ty) <- tcVTA fun_conc_tvs fun_ty hs_ty
; let arg' = ETypeArg { ea_ctxt = ctxt, ea_hs_ty = hs_ty, ea_ty_arg = ty_arg }
- ; go delta (arg' : acc) so_far inst_ty rest_args }
+ ; go pos delta (arg' : acc) inst_ty rest_args }
-- Rule IVAR from Fig 4 of the QL paper:
- go1 _ acc so_far fun_ty args@(EValArg {} : _)
+ go1 pos _ acc fun_ty args@(EValArg {} : _)
| Just kappa <- getTyVar_maybe fun_ty
, isQLInstTyVar kappa
= -- Function type was of form f :: forall a b. t1 -> t2 -> b
@@ -743,7 +734,7 @@ tcInstFun do_ql inst_final fun_ctxt tc_fun fun_sigma rn_args
-- - We need the freshly allocated unification variables, to extend
-- delta with.
-- It's easier just to do the job directly here.
- do { arg_tys <- zipWithM new_arg_ty (leadingValArgs args) [length so_far + 1 ..]
+ do { arg_tys <- zipWithM new_arg_ty (leadingValArgs args) [pos..]
; res_ty <- newOpenFlexiTyVarTy
; let fun_ty' = mkScaledFunTys arg_tys res_ty
@@ -759,11 +750,11 @@ tcInstFun do_ql inst_final fun_ctxt tc_fun fun_sigma rn_args
-- Then fun_ty :: kk, fun_ty' :: Type, kind_co :: Type ~ kk
-- co_wrap :: (fun_ty' |> kind_co) ~ fun_ty'
- ; go True acc' so_far fun_ty' args }
+ ; go pos True acc' fun_ty' args }
-- Rule IARG from Fig 4 of the QL paper:
- go1 delta acc so_far fun_ty
- (eva@(EValArg { ea_arg = arg, ea_ctxt = ctxt }) : rest_args)
+ go1 pos delta acc fun_ty
+ (EValArg { ea_arg = arg, ea_ctxt = ctxt } : rest_args)
= do { let herald = case fun_ctxt of
VAExpansion (OrigStmt{}) _ _ -> ExpectedFunTySyntaxOp DoOrigin tc_fun
_ -> ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)
@@ -777,14 +768,9 @@ tcInstFun do_ql inst_final fun_ctxt tc_fun fun_sigma rn_args
(Just $ HsExprTcThing tc_fun)
(n_val_args, fun_sigma) fun_ty
- ; arg' <- if do_ql
- then addArgCtxt ctxt arg $
- -- Context needed for constraints
- -- generated by calls in arg
- quickLookArg delta ctxt arg arg_ty
- else return (eva { ea_arg_ty = (False, arg_ty) })
+ ; arg' <- quickLookArg do_ql ctxt arg arg_ty
; let acc' = arg' : addArgWrap wrap acc
- ; go delta acc' (arg_ty:so_far) res_ty rest_args }
+ ; go (pos+1) delta acc' res_ty rest_args }
new_arg_ty :: LHsExpr GhcRn -> Int -> TcM (Scaled TcType)
-- Make a fresh nus for each argument in rule IVAR
@@ -1632,8 +1618,7 @@ This turned out to be more subtle than I expected. Wrinkles:
no-op; see the `when` short-cut in `demoteQLDelta`.
-}
-quickLookArg :: Delta
- -> AppCtxt
+quickLookArg :: QLFlag -> AppCtxt
-> LHsExpr GhcRn -- ^ Argument
-> Scaled TcSigmaTypeFRR -- ^ Type expected by the function
-> TcM (HsExprArg 'TcpInst)
@@ -1643,55 +1628,72 @@ quickLookArg :: Delta
-- with added instantiation variables from
-- (a) the call itself
-- (b) the arguments of the call
-quickLookArg some_ql_inst_var ctxt larg orig_arg_ty
- | some_ql_inst_var = go orig_arg_ty
- | otherwise = skipQuickLook ctxt larg orig_arg_ty
+quickLookArg NoQL ctxt larg orig_arg_ty
+ = skipQuickLook NoQL ctxt larg orig_arg_ty
+quickLookArg DoQL ctxt larg orig_arg_ty
+ = do { is_rho <- tcIsDeepRho (scaledThing orig_arg_ty)
+ ; traceTc "qla" (ppr orig_arg_ty $$ ppr is_rho)
+ ; if not is_rho
+ then skipQuickLook DoQL ctxt larg orig_arg_ty
+ else quickLookArg1 ctxt larg orig_arg_ty }
+
+skipQuickLook :: QLFlag -> AppCtxt -> LHsExpr GhcRn -> Scaled TcRhoType
+ -> TcM (HsExprArg 'TcpInst)
+skipQuickLook do_ql ctxt larg arg_ty
+ = return (EValArg { ea_ctxt = ctxt
+ , ea_arg = larg
+ , ea_arg_ty = (do_ql, arg_ty) })
+ -- do_ql <=> remember to zonk this argumet in tcValArg
+
+tcIsDeepRho :: TcType -> TcM Bool
+-- This top-level zonk step, which is the reason we need a local 'go' loop,
+-- is subtle. See Section 9 of the QL paper
+
+tcIsDeepRho ty
+ = do { ds_flag <- getDeepSubsumptionFlag
+ ; go ds_flag ty }
where
- guarded = isGuardedTy orig_arg_ty
- -- NB: guardedness is computed based on the original,
- -- unzonked arg_ty (before calling `go`), so that we deliberately do
- -- not exploit guardedness that emerges a result of QL on earlier args
-
- go sc_arg_ty@(Scaled mult arg_ty)
- | not (isRhoTy arg_ty)
- = skipQuickLook ctxt larg sc_arg_ty
-
- -- This top-level zonk step, which is the reason we need a local 'go' loop,
- -- is subtle. See Section 9 of the QL paper
- | Just kappa <- getTyVar_maybe arg_ty
+ go ds_flag ty
+ | isSigmaTy ty = return False
+
+ | Just kappa <- getTyVar_maybe ty
, isQLInstTyVar kappa
= do { info <- readMetaTyVar kappa
; case info of
- Indirect arg_ty'' -> go (Scaled mult arg_ty'')
- Flexi -> quickLookArg1 guarded ctxt larg sc_arg_ty }
+ Indirect arg_ty' -> go ds_flag arg_ty'
+ Flexi -> return True }
- | otherwise
- = quickLookArg1 guarded ctxt larg sc_arg_ty
+ | Deep <- ds_flag
+ , Just (_, res_ty) <- tcSplitFunTy_maybe ty
+ = go ds_flag res_ty
-isGuardedTy :: Scaled TcType -> Bool
-isGuardedTy (Scaled _ ty)
+ | otherwise = return True
+
+isGuardedTy :: TcType -> Bool
+isGuardedTy ty
| Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal
| Just {} <- tcSplitAppTy_maybe ty = True
| otherwise = False
-quickLookArg1 :: Bool -- Guarded
- -> AppCtxt -> LHsExpr GhcRn
- -> Scaled TcRhoType -- Not deeply skolemised, even with -XDeepSubsumption
+quickLookArg1 :: AppCtxt -> LHsExpr GhcRn
+ -> Scaled TcRhoType -- Deeply skolemised
-> TcM (HsExprArg 'TcpInst)
-- quickLookArg1 implements the "QL Argument" judgement in Fig 5 of the paper
-quickLookArg1 guarded ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ arg_ty)
- = do { (rn_head@(rn_fun, fun_ctxt), rn_args) <- splitHsApps arg
+quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
+ = addArgCtxt ctxt larg $ -- Context needed for constraints
+ -- generated by calls in arg
+ do { (rn_head@(rn_fun, fun_ctxt), rn_args) <- splitHsApps arg
-- Step 1: get the type of the head of the argument
; mb_fun_ty <- tcInferAppHead_maybe rn_fun
; traceTc "quickLookArg 1" $
vcat [ text "arg:" <+> ppr arg
- , text "arg_ty:" <+> ppr arg_ty
+ , text "orig_arg_rho:" <+> ppr orig_arg_rho
, text "head:" <+> ppr rn_fun <+> dcolon <+> ppr mb_fun_ty
, text "args:" <+> ppr rn_args ]
; case mb_fun_ty of {
- Nothing -> skipQuickLook ctxt larg sc_arg_ty ; -- fun is too complicated
+ Nothing -> skipQuickLook DoQL ctxt larg sc_arg_ty ; -- fun is too complicated
Just (tc_fun, fun_sigma) ->
-- Step 2: use |-inst to instantiate the head applied to the arguments
@@ -1712,9 +1714,14 @@ quickLookArg1 guarded ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ arg_ty)
, eaql_args = inst_args
, eaql_res_rho = app_res_rho }
+ guarded = isGuardedTy orig_arg_rho
+ -- NB: guardedness is computed based on the original,
+ -- unzonked orig_arg_rho, so that we deliberately do
+ -- not exploit guardedness that emerges a result of QL on earlier args
+
; traceTc "quickLookArg 2" $
vcat [ text "arg:" <+> ppr arg
- , text "arg_ty:" <+> ppr arg_ty
+ , text "orig_arg_rho:" <+> ppr orig_arg_rho
, text "app_res_rho:" <+> ppr app_res_rho ]
-- Step 3: Check the two other premises of APP-lightning-bolt (Fig 5 in the paper)
@@ -1728,16 +1735,16 @@ quickLookArg1 guarded ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ arg_ty)
-- For (B) see Note [The fiv test in quickLookArg]
-- Step 4: do quick-look unification if either (A) or (B) hold
- -- NB: arg_ty may not be zonked, but that's ok
+ -- NB: orig_arg_rho may not be zonked, but that's ok
; if arg_influences_enclosing_call
then -- No generalisation will take place for this argument! So we can:
-- * emit the constraints from the argument right now, and
-- * unify with the expected type
- -- No skolemisation of arg_ty needed here:
- -- either arg_ty is guarded (meaning no foralls at top)
- -- or ...ToDo...
+ -- No skolemisation of orig_arg_ty needed here:
+ -- tcIsDeepRho checked that there are no foralls to skolemise
do { emitConstraints wanted
- ; res_wrap <- unifyResTy arg fun_ctxt tc_fun inst_args app_res_rho (mkCheckExpType arg_ty)
+ ; res_wrap <- unifyResTy arg fun_ctxt tc_fun inst_args app_res_rho
+ (mkCheckExpType orig_arg_rho)
; traceTc "quickLookArg unify" (ppr rn_fun)
; return (mk_ql_arg (QLUnified res_wrap)) }
@@ -1749,14 +1756,6 @@ quickLookArg1 guarded ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ arg_ty)
; return (mk_ql_arg (QLIndependent wanted)) }
}}}
-skipQuickLook :: AppCtxt -> LHsExpr GhcRn -> Scaled TcRhoType
- -> TcM (HsExprArg 'TcpInst)
-skipQuickLook ctxt larg arg_ty
- -- ToDo: kill Delta
- = return (EValArg { ea_ctxt = ctxt
- , ea_arg = larg
- , ea_arg_ty = (True, arg_ty) })
- -- True <=> remember to zonk this argumet in tcValArg
{- *********************************************************************
@@ -1780,7 +1779,7 @@ monomorphiseQLInstVars inst_args res_rho
go_val_arg_ql inst_args rho = do { mapM_ go_arg inst_args; go_ty rho }
go_arg :: HsExprArg 'TcpInst -> TcM ()
- go_arg (EValArg { ea_arg_ty = (True, arg_ty) })
+ go_arg (EValArg { ea_arg_ty = (DoQL, arg_ty) })
= go_ty (scaledThing arg_ty)
go_arg (EValArgQL { eaql_status = QLUnified {}, eaql_args = args, eaql_res_rho = rho })
= go_val_arg_ql args rho
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -16,7 +16,7 @@
-}
module GHC.Tc.Gen.Head
- ( HsExprArg(..), TcPass(..), QLArgStatus(..)
+ ( HsExprArg(..), TcPass(..), QLArgStatus(..), QLFlag(..)
, AppCtxt(..), appCtxtLoc, insideExpansion
, splitHsApps, rebuildHsApps
, addArgWrap, isHsValArg
@@ -197,12 +197,15 @@ type family XETAType (p :: TcPass) where -- Type arguments
XETAType _ = Type
type family XEVAType (p :: TcPass) where -- Value arguments
- XEVAType 'TcpRn = NoExtField
- XEVAType _ = (Bool, Scaled TcSigmaType)
- -- The Bool = True if we /are/ doing Quick Look,
- -- but this particular arg did not contribute; in this case
- -- we must zonk the type to expose the foralls from other args
- -- (If it did contribute, we'd be in EValArgQL.)
+ XEVAType 'TcpInst = (QLFlag, Scaled TcSigmaType)
+ -- QLFlag = DoQL => we /are/ doing Quick Look,
+ -- but this particular arg did not contribute; in this case
+ -- we must zonk the type to expose the foralls from other args
+ -- (If it did contribute, we'd be in EValArgQL.)
+
+ XEVAType _ = NoExtField
+
+data QLFlag = DoQL | NoQL
data QLArgStatus -- See (QLA2) in Note [Quick Look at value arguments] in GHC.Tc.Gen.App
= QLUnified HsWrapper -- Unified with caller
@@ -223,6 +226,7 @@ data AppCtxt
SrcSpan -- The SrcSpan of the application (f e1 e2 e3)
-- noSrcSpan if outermost; see Note [AppCtxt]
+
{- Note [AppCtxt]
~~~~~~~~~~~~~~~~~
In a call (f e1 ... en), we pair up each argument with an AppCtxt. For
@@ -258,6 +262,10 @@ insideExpansion :: AppCtxt -> Bool
insideExpansion (VAExpansion {}) = True
insideExpansion (VACall {}) = False -- but what if the VACall has a generated context?
+instance Outputable QLFlag where
+ ppr DoQL = text "DoQL"
+ ppr NoQL = text "NoQL"
+
instance Outputable AppCtxt where
ppr (VAExpansion e l _) = text "VAExpansion" <+> ppr e <+> ppr l
ppr (VACall f n l) = text "VACall" <+> int n <+> ppr f <+> ppr l
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -1941,10 +1941,7 @@ isSigmaTy _ = False
isRhoTy :: TcType -> Bool -- True of TcRhoTypes; see Note [TcRhoType]
-isRhoTy (ForAllTy (Bndr _ af) _) = isVisibleForAllTyFlag af
-isRhoTy (FunTy { ft_af = af }) = isVisibleFunArg af
-isRhoTy ty | Just ty' <- coreView ty = isRhoTy ty'
-isRhoTy _ = True
+isRhoTy ty = not (isSigmaTy ty)
-- | Like 'isRhoTy', but also says 'True' for 'Infer' types
isRhoExpTy :: ExpType -> Bool
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e44e27e345c77df1e78e1fd7a5f2424b8d64b0c3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e44e27e345c77df1e78e1fd7a5f2424b8d64b0c3
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240528/57e2fda2/attachment-0001.html>
More information about the ghc-commits
mailing list