Skip to content
GitLab
Commit 26a3d0fe authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Rename Untouchables to TcLevel 

This is a long-overdue renaming
   Untouchables  -->   TcLevel
It is renaming only; no change in functionality.

We really wanted to get this done before the 7.10 fork.
parent 668a1379
Hide whitespace changes
Inline Side-by-side
compiler/typecheck/TcBinds.lhs
View file @ 26a3d0fe
......@@ -606,15 +606,15 @@ tcPolyInfer
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list
= do { (((binds', mono_infos), untch), wanted)
= do { (((binds', mono_infos), tclvl), wanted)
<- captureConstraints $
captureUntouchables $
captureTcLevel $
tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
; traceTc "simplifyInfer call" (ppr name_taus $$ ppr wanted)
; (qtvs, givens, mr_bites, ev_binds)
<- simplifyInfer untch mono name_taus wanted
<- simplifyInfer tclvl mono name_taus wanted
; inferred_theta <- zonkTcThetaType (map evVarPred givens)
; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs inferred_theta)
......@@ -1375,7 +1375,7 @@ tcTySig (L _ (IdSig id))
; return ([sig], []) }
tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty wcs))
= setSrcSpan loc $
pushUntouchablesM $
pushTcLevelM $
do { nwc_tvs <- mapM newWildcardVarMetaKind wcs -- Generate fresh meta vars for the wildcards
; sigma_ty <- tcExtendTyVarEnv nwc_tvs $ tcHsSigType (FunSigCtxt name1) hs_ty
; sigs <- mapM (instTcTySig hs_ty sigma_ty (extra_cts hs_ty) (zip wcs nwc_tvs))
......
compiler/typecheck/TcCanonical.lhs
View file @ 26a3d0fe
......@@ -805,8 +805,8 @@ canEqTyVarTyVar ev swapped tv1 tv2 co2
-- If tv1 is touchable, swap only if tv2 is also
-- touchable and it's strictly better to update the latter
-- But see Note [Avoid unnecessary swaps]
| Just lvl1 <- metaTyVarUntouchables_maybe tv1
= case metaTyVarUntouchables_maybe tv2 of
| Just lvl1 <- metaTyVarTcLevel_maybe tv1
= case metaTyVarTcLevel_maybe tv2 of
Nothing -> False
Just lvl2 | lvl2 `strictlyDeeperThan` lvl1 -> True
| lvl1 `strictlyDeeperThan` lvl2 -> False
......
compiler/typecheck/TcErrors.lhs
View file @ 26a3d0fe
......@@ -793,7 +793,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
| (implic:_) <- cec_encl ctxt -- Get the innermost context
, Implic { ic_env = env, ic_given = given, ic_info = skol_info } <- implic
= do { let msg = misMatchMsg oriented ty1 ty2
untch_extra
tclvl_extra
= nest 2 $
sep [ quotes (ppr tv1) <+> ptext (sLit "is untouchable")
, nest 2 $ ptext (sLit "inside the constraints") <+> pprEvVarTheta given
......@@ -801,7 +801,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
, nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ]
tv_extra = extraTyVarInfo ctxt tv1 ty2
add_sig = suggestAddSig ctxt ty1 ty2
; mkErrorMsg ctxt ct (vcat [msg, untch_extra, tv_extra, add_sig, extra]) }
; mkErrorMsg ctxt ct (vcat [msg, tclvl_extra, tv_extra, add_sig, extra]) }
| otherwise
= reportEqErr ctxt extra ct oriented (mkTyVarTy tv1) ty2
......
compiler/typecheck/TcFlatten.lhs
View file @ 26a3d0fe
......@@ -1055,7 +1055,7 @@ We must solve both!
unflatten :: Cts -> Cts -> TcS Cts
unflatten tv_eqs funeqs
= do { dflags <- getDynFlags
; untch <- getUntouchables
; tclvl <- getTcLevel
; traceTcS "Unflattening" $ braces $
vcat [ ptext (sLit "Funeqs =") <+> pprCts funeqs
......@@ -1067,7 +1067,7 @@ unflatten tv_eqs funeqs
; traceTcS "Unflattening 1" $ braces (pprCts funeqs)
-- Step 2: unify the irreds, if possible
; tv_eqs <- foldrBagM (unflatten_eq dflags untch) emptyCts tv_eqs
; tv_eqs <- foldrBagM (unflatten_eq dflags tclvl) emptyCts tv_eqs
; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs)
-- Step 3: fill any remaining fmvs with fresh unification variables
......@@ -1102,12 +1102,12 @@ unflatten tv_eqs funeqs
finalise_funeq ct = pprPanic "finalise_funeq" (ppr ct)
----------------
unflatten_eq :: DynFlags -> Untouchables -> Ct -> Cts -> TcS Cts
unflatten_eq dflags untch ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv, cc_rhs = rhs }) rest
unflatten_eq :: DynFlags -> TcLevel -> Ct -> Cts -> TcS Cts
unflatten_eq dflags tclvl ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv, cc_rhs = rhs }) rest
| isFmvTyVar tv
= do { lhs_elim <- tryFill dflags tv rhs ev
; if lhs_elim then return rest else
do { rhs_elim <- try_fill dflags untch ev rhs (mkTyVarTy tv)
do { rhs_elim <- try_fill dflags tclvl ev rhs (mkTyVarTy tv)
; if rhs_elim then return rest else
return (ct `consCts` rest) } }
......@@ -1133,9 +1133,9 @@ unflatten tv_eqs funeqs
finalise_eq ct _ = pprPanic "finalise_irred" (ppr ct)
----------------
try_fill dflags untch ev ty1 ty2
try_fill dflags tclvl ev ty1 ty2
| Just tv1 <- tcGetTyVar_maybe ty1
, isTouchableOrFmv untch tv1
, isTouchableOrFmv tclvl tv1
, typeKind ty1 `isSubKind` tyVarKind tv1
= tryFill dflags tv1 ty2 ev
| otherwise
......
compiler/typecheck/TcInteract.lhs
View file @ 26a3d0fe
......@@ -829,8 +829,8 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv, cc_rhs = rhs , cc_ev
; stopWith ev "Solved from inert (r)" }
| otherwise
= do { untch <- getUntouchables
; if canSolveByUnification untch ev tv rhs
= do { tclvl <- getTcLevel
; if canSolveByUnification tclvl ev tv rhs
then do { solveByUnification ev tv rhs
; n_kicked <- kickOutRewritable givenFlavour tv
-- givenFlavour because the tv := xi is given
......@@ -839,10 +839,10 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv, cc_rhs = rhs , cc_ev
else do { traceTcS "Can't solve tyvar equality"
(vcat [ text "LHS:" <+> ppr tv <+> dcolon <+> ppr (tyVarKind tv)
, ppWhen (isMetaTyVar tv) $
nest 4 (text "Untouchable level of" <+> ppr tv
<+> text "is" <+> ppr (metaTyVarUntouchables tv))
nest 4 (text "TcLevel of" <+> ppr tv
<+> text "is" <+> ppr (metaTyVarTcLevel tv))
, text "RHS:" <+> ppr rhs <+> dcolon <+> ppr (typeKind rhs)
, text "Untouchables =" <+> ppr untch ])
, text "TcLevel =" <+> ppr tclvl ])
; n_kicked <- kickOutRewritable ev tv
; updInertCans (\ ics -> addInertCan ics workItem)
; return (Stop ev (ptext (sLit "Kept as inert") <+> ppr_kicked n_kicked)) } }
......@@ -852,12 +852,12 @@ interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi)
-- @trySpontaneousSolve wi@ solves equalities where one side is a
-- touchable unification variable.
-- Returns True <=> spontaneous solve happened
canSolveByUnification :: Untouchables -> CtEvidence -> TcTyVar -> Xi -> Bool
canSolveByUnification untch gw tv xi
canSolveByUnification :: TcLevel -> CtEvidence -> TcTyVar -> Xi -> Bool
canSolveByUnification tclvl gw tv xi
| isGiven gw -- See Note [Touchables and givens]
= False
| isTouchableMetaTyVar untch tv
| isTouchableMetaTyVar tclvl tv
= case metaTyVarInfo tv of
SigTv -> is_tyvar xi
_ -> True
......@@ -1993,10 +1993,10 @@ matchClassInst _ clas [ _k, ty1, ty2 ] loc
matchClassInst inerts clas tys loc
= do { dflags <- getDynFlags
; untch <- getUntouchables
; tclvl <- getTcLevel
; traceTcS "matchClassInst" $ vcat [ text "pred =" <+> ppr pred
, text "inerts=" <+> ppr inerts
, text "untouchables=" <+> ppr untch ]
, text "untouchables=" <+> ppr tclvl ]
; instEnvs <- getInstEnvs
; case lookupInstEnv instEnvs clas tys of
([], _, _) -- Nothing matches
......@@ -2006,7 +2006,7 @@ matchClassInst inerts clas tys loc
([(ispec, inst_tys)], [], _) -- A single match
| not (xopt Opt_IncoherentInstances dflags)
, given_overlap untch
, given_overlap tclvl
-> -- See Note [Instance and Given overlap]
do { traceTcS "Delaying instance application" $
vcat [ text "Workitem=" <+> pprType (mkClassPred clas tys)
......@@ -2051,14 +2051,14 @@ matchClassInst inerts clas tys loc
givens_for_this_clas
= filterBag isGivenCt (findDictsByClass (inert_dicts $ inert_cans inerts) clas)
given_overlap :: Untouchables -> Bool
given_overlap untch = anyBag (matchable untch) givens_for_this_clas
given_overlap :: TcLevel -> Bool
given_overlap tclvl = anyBag (matchable tclvl) givens_for_this_clas
matchable untch (CDictCan { cc_class = clas_g, cc_tyargs = sys
matchable tclvl (CDictCan { cc_class = clas_g, cc_tyargs = sys
, cc_ev = fl })
| isGiven fl
= ASSERT( clas_g == clas )
case tcUnifyTys (\tv -> if isTouchableMetaTyVar untch tv &&
case tcUnifyTys (\tv -> if isTouchableMetaTyVar tclvl tv &&
tv `elemVarSet` tyVarsOfTypes tys
then BindMe else Skolem) tys sys of
-- We can't learn anything more about any variable at this point, so the only
......
compiler/typecheck/TcMType.lhs
View file @ 26a3d0fe
......@@ -343,8 +343,8 @@ newSigTyVar name kind
newMetaDetails :: MetaInfo -> TcM TcTyVarDetails
newMetaDetails info
= do { ref <- newMutVar Flexi
; untch <- getUntouchables
; return (MetaTv { mtv_info = info, mtv_ref = ref, mtv_untch = untch }) }
; tclvl <- getTcLevel
; return (MetaTv { mtv_info = info, mtv_ref = ref, mtv_tclvl = tclvl }) }
cloneMetaTyVar :: TcTyVar -> TcM TcTyVar
cloneMetaTyVar tv
......
compiler/typecheck/TcPatSyn.lhs
View file @ 26a3d0fe
......@@ -66,9 +66,9 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
; let (arg_names, is_infix) = case details of
PrefixPatSyn names -> (map unLoc names, False)
InfixPatSyn name1 name2 -> (map unLoc [name1, name2], True)
; (((lpat', (args, pat_ty)), untch), wanted)
<- captureConstraints $
captureUntouchables $
; (((lpat', (args, pat_ty)), tclvl), wanted)
<- captureConstraints $
captureTcLevel $
do { pat_ty <- newFlexiTyVarTy openTypeKind
; tcPat PatSyn lpat pat_ty $
do { args <- mapM tcLookupId arg_names
......@@ -76,7 +76,7 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args
; (qtvs, req_dicts, _mr_bites, ev_binds) <- simplifyInfer untch False named_taus wanted
; (qtvs, req_dicts, _mr_bites, ev_binds) <- simplifyInfer tclvl False named_taus wanted
; (ex_vars, prov_dicts) <- tcCollectEx lpat'
; let univ_tvs = filter (not . (`elemVarSet` ex_vars)) qtvs
......
compiler/typecheck/TcRnDriver.lhs
View file @ 26a3d0fe
......@@ -1760,12 +1760,12 @@ tcRnExpr hsc_env rdr_expr
-- it might have a rank-2 type (e.g. :t runST)
uniq <- newUnique ;
let { fresh_it = itName uniq (getLoc rdr_expr) } ;
(((_tc_expr, res_ty), untch), lie) <- captureConstraints $
captureUntouchables $
(((_tc_expr, res_ty), tclvl), lie) <- captureConstraints $
captureTcLevel $
tcInferRho rn_expr ;
((qtvs, dicts, _, _), lie_top) <- captureConstraints $
{-# SCC "simplifyInfer" #-}
simplifyInfer untch
simplifyInfer tclvl
False {- No MR for now -}
[(fresh_it, res_ty)]
lie ;
......
compiler/typecheck/TcRnMonad.lhs
View file @ 26a3d0fe
......@@ -179,7 +179,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
tcl_tidy = emptyTidyEnv,
tcl_tyvars = tvs_var,
tcl_lie = lie_var,
tcl_untch = noUntouchables
tcl_tclvl = topTcLevel
} ;
} ;
......@@ -1156,33 +1156,33 @@ captureConstraints thing_inside
lie <- readTcRef lie_var ;
return (res, lie) }
captureUntouchables :: TcM a -> TcM (a, Untouchables)
captureUntouchables thing_inside
captureTcLevel :: TcM a -> TcM (a, TcLevel)
captureTcLevel thing_inside
= do { env <- getLclEnv
; let untch' = pushUntouchables (tcl_untch env)
; res <- setLclEnv (env { tcl_untch = untch' })
; let tclvl' = pushTcLevel (tcl_tclvl env)
; res <- setLclEnv (env { tcl_tclvl = tclvl' })
thing_inside
; return (res, untch') }
; return (res, tclvl') }
pushUntouchablesM :: TcM a -> TcM a
pushUntouchablesM thing_inside
pushTcLevelM :: TcM a -> TcM a
pushTcLevelM thing_inside
= do { env <- getLclEnv
; let untch' = pushUntouchables (tcl_untch env)
; setLclEnv (env { tcl_untch = untch' })
; let tclvl' = pushTcLevel (tcl_tclvl env)
; setLclEnv (env { tcl_tclvl = tclvl' })
thing_inside }
getUntouchables :: TcM Untouchables
getUntouchables = do { env <- getLclEnv
; return (tcl_untch env) }
getTcLevel :: TcM TcLevel
getTcLevel = do { env <- getLclEnv
; return (tcl_tclvl env) }
setUntouchables :: Untouchables -> TcM a -> TcM a
setUntouchables untch thing_inside
= updLclEnv (\env -> env { tcl_untch = untch }) thing_inside
setTcLevel :: TcLevel -> TcM a -> TcM a
setTcLevel tclvl thing_inside
= updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside
isTouchableTcM :: TcTyVar -> TcM Bool
isTouchableTcM tv
= do { env <- getLclEnv
; return (isTouchableMetaTyVar (tcl_untch env) tv) }
; return (isTouchableMetaTyVar (tcl_tclvl env) tv) }
getLclTypeEnv :: TcM TcTypeEnv
getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
......
compiler/typecheck/TcRnTypes.lhs
View file @ 26a3d0fe
......@@ -541,7 +541,7 @@ data TcLclEnv -- Changes as we move inside an expression
= TcLclEnv {
tcl_loc :: SrcSpan, -- Source span
tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top
tcl_untch :: Untouchables, -- Birthplace for new unification variables
tcl_tclvl :: TcLevel, -- Birthplace for new unification variables
tcl_th_ctxt :: ThStage, -- Template Haskell context
tcl_th_bndrs :: ThBindEnv, -- Binding level of in-scope Names
......@@ -1392,7 +1392,7 @@ ppr_bag doc bag
\begin{code}
data Implication
= Implic {
ic_untch :: Untouchables, -- Untouchables: unification variables
ic_tclvl :: TcLevel, -- TcLevel: unification variables
-- free in the environment
ic_skols :: [TcTyVar], -- Introduced skolems
......@@ -1418,12 +1418,12 @@ data Implication
}
instance Outputable Implication where
ppr (Implic { ic_untch = untch, ic_skols = skols
ppr (Implic { ic_tclvl = tclvl, ic_skols = skols
, ic_given = given, ic_no_eqs = no_eqs
, ic_wanted = wanted, ic_insol = insol
, ic_binds = binds, ic_info = info })
= hang (ptext (sLit "Implic") <+> lbrace)
2 (sep [ ptext (sLit "Untouchables =") <+> ppr untch
2 (sep [ ptext (sLit "TcLevel =") <+> ppr tclvl
, ptext (sLit "Skolems =") <+> pprTvBndrs skols
, ptext (sLit "No-eqs =") <+> ppr no_eqs
, ptext (sLit "Insol =") <+> ppr insol
......@@ -1711,12 +1711,12 @@ data CtLoc = CtLoc { ctl_origin :: CtOrigin
-- source location: tcl_loc :: SrcSpan
-- context: tcl_ctxt :: [ErrCtxt]
-- binder stack: tcl_bndrs :: [TcIdBinders]
-- level: tcl_untch :: Untouchables
-- level: tcl_tclvl :: TcLevel
mkGivenLoc :: Untouchables -> SkolemInfo -> TcLclEnv -> CtLoc
mkGivenLoc untch skol_info env
mkGivenLoc :: TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc
mkGivenLoc tclvl skol_info env
= CtLoc { ctl_origin = GivenOrigin skol_info
, ctl_env = env { tcl_untch = untch }
, ctl_env = env { tcl_tclvl = tclvl }
, ctl_depth = initialSubGoalDepth }
ctLocEnv :: CtLoc -> TcLclEnv
......
compiler/typecheck/TcRules.lhs
View file @ 26a3d0fe
......@@ -167,7 +167,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
-- Simplify the RHS constraints
; lcl_env <- getLclEnv
; rhs_binds_var <- newTcEvBinds
; emitImplication $ Implic { ic_untch = noUntouchables
; emitImplication $ Implic { ic_tclvl = topTcLevel
, ic_skols = qtkvs
, ic_no_eqs = False
, ic_given = lhs_evs
......@@ -181,7 +181,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
-- (a) so that we report insoluble ones
-- (b) so that we bind any soluble ones
; lhs_binds_var <- newTcEvBinds
; emitImplication $ Implic { ic_untch = noUntouchables
; emitImplication $ Implic { ic_tclvl = topTcLevel
, ic_skols = qtkvs
, ic_no_eqs = False
, ic_given = lhs_evs
......
compiler/typecheck/TcSMonad.lhs
View file @ 26a3d0fe
......@@ -58,7 +58,7 @@ module TcSMonad (
setWantedTyBind, reportUnifications,
getInstEnvs, getFamInstEnvs, -- Getting the environments
getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
getTopEnv, getGblEnv, getTcEvBinds, getTcLevel,
getTcEvBindsMap,
lookupFlatCache, newFlattenSkolem, -- Flatten skolems
......@@ -87,7 +87,7 @@ module TcSMonad (
newFlexiTcSTy, instFlexiTcS, instFlexiTcSHelperTcS,
cloneMetaTyVar, demoteUnfilledFmv,
Untouchables, isTouchableMetaTyVarTcS,
TcLevel, isTouchableMetaTyVarTcS,
isFilledMetaTyVar_maybe, isFilledMetaTyVar,
zonkTyVarsAndFV, zonkTcType, zonkTcTyVar, zonkFlats,
......@@ -610,11 +610,11 @@ getUnsolvedInerts
is_unsolved ct = not (isGivenCt ct) -- Wanted or Derived
getNoGivenEqs :: Untouchables -- Untouchables of this implication
getNoGivenEqs :: TcLevel -- TcLevel of this implication
-> [TcTyVar] -- Skolems of this implication
-> TcS Bool -- True <=> definitely no residual given equalities
-- See Note [When does an implication have given equalities?]
getNoGivenEqs untch skol_tvs
getNoGivenEqs tclvl skol_tvs
= do { inerts@(IC { inert_eqs = ieqs, inert_irreds = iirreds, inert_funeqs = funeqs })
<- getInertCans
; let local_fsks = foldFunEqs add_fsk funeqs emptyVarSet
......@@ -636,7 +636,7 @@ getNoGivenEqs untch skol_tvs
-- i.e. the current level
ev_given_here ev
= isGiven ev
&& untch == tcl_untch (ctl_env (ctEvLoc ev))
&& tclvl == tcl_tclvl (ctl_env (ctEvLoc ev))
add_fsk :: Ct -> VarSet -> VarSet
add_fsk ct fsks | CFunEqCan { cc_fsk = tv, cc_ev = ev } <- ct
......@@ -666,8 +666,8 @@ any equalities among them, the calculation of has_given_eqs. There
are some wrinkles:
* We must know which ones are bound in *this* implication and which
are bound further out. We can find that out from the Untouchable
level of the Given, which is itself recorded in the tcl_untch field
are bound further out. We can find that out from the TcLevel
of the Given, which is itself recorded in the tcl_tclvl field
of the TcLclEnv stored in the Given (ev_given_here).
What about interactions between inner and outer givens?
......@@ -1086,8 +1086,8 @@ traceFireTcS :: CtEvidence -> SDoc -> TcS ()
traceFireTcS ev doc
= TcS $ \env -> csTraceTcM 1 $
do { n <- TcM.readTcRef (tcs_count env)
; untch <- TcM.getUntouchables
; return (hang (int n <> brackets (ptext (sLit "U:") <> ppr untch
; tclvl <- TcM.getTcLevel
; return (hang (int n <> brackets (ptext (sLit "U:") <> ppr tclvl
<> ppr (ctLocDepth (ctEvLoc ev)))
<+> doc <> colon)
4 (ppr ev)) }
......@@ -1160,8 +1160,8 @@ checkForCyclicBinds ev_binds
edges = [(bind, bndr, varSetElems (evVarsOfTerm rhs)) | bind@(EvBind bndr rhs) <- bagToList ev_binds]
#endif
nestImplicTcS :: EvBindsVar -> Untouchables -> TcS a -> TcS a
nestImplicTcS ref inner_untch (TcS thing_inside)
nestImplicTcS :: EvBindsVar -> TcLevel -> TcS a -> TcS a
nestImplicTcS ref inner_tclvl (TcS thing_inside)
= TcS $ \ TcSEnv { tcs_unified = unified_var
, tcs_inerts = old_inert_var
, tcs_count = count } ->
......@@ -1175,7 +1175,7 @@ nestImplicTcS ref inner_untch (TcS thing_inside)
, tcs_count = count
, tcs_inerts = new_inert_var
, tcs_worklist = new_wl_var }
; res <- TcM.setUntouchables inner_untch $
; res <- TcM.setTcLevel inner_tclvl $
thing_inside nest_env
#ifdef DEBUG
......@@ -1307,8 +1307,8 @@ emitInsoluble ct
getTcEvBinds :: TcS EvBindsVar
getTcEvBinds = TcS (return . tcs_ev_binds)
getUntouchables :: TcS Untouchables
getUntouchables = wrapTcS TcM.getUntouchables
getTcLevel :: TcS TcLevel
getTcLevel = wrapTcS TcM.getTcLevel
\end{code}
\begin{code}
......@@ -1385,8 +1385,8 @@ pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2
isTouchableMetaTyVarTcS :: TcTyVar -> TcS Bool
isTouchableMetaTyVarTcS tv
= do { untch <- getUntouchables
; return $ isTouchableMetaTyVar untch tv }
= do { tclvl <- getTcLevel
; return $ isTouchableMetaTyVar tclvl tv }
isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type)
isFilledMetaTyVar_maybe tv
......@@ -1489,7 +1489,7 @@ newFlattenSkolem ctxt_ev fam_ty
; ref <- TcM.newMutVar Flexi
; let details = MetaTv { mtv_info = FlatMetaTv
, mtv_ref = ref
, mtv_untch = fskUntouchables }
, mtv_tclvl = fskTcLevel }
name = TcM.mkTcTyVarName uniq (fsLit "s")
; return (mkTcTyVar name (typeKind fam_ty) details) }
; ev <- newWantedEvVarNC loc (mkTcEqPred fam_ty (mkTyVarTy fuv))
......@@ -1983,11 +1983,11 @@ deferTcSForAllEq role loc (tvs1,body1) (tvs2,body2)
; let ev_binds = TcEvBinds ev_binds_var
new_ct = mkNonCanonical ctev
new_co = ctEvCoercion ctev
new_untch = pushUntouchables (tcl_untch env)
new_tclvl = pushTcLevel (tcl_tclvl env)
; let wc = WC { wc_flat = singleCt new_ct
, wc_impl = emptyBag
, wc_insol = emptyCts }
imp = Implic { ic_untch = new_untch
imp = Implic { ic_tclvl = new_tclvl
, ic_skols = skol_tvs
, ic_no_eqs = True
, ic_given = []
......
compiler/typecheck/TcSimplify.lhs
View file @ 26a3d0fe
......@@ -246,19 +246,19 @@ Consider
To infer f's type we do the following:
* Gather the constraints for the RHS with ambient level *one more than*
the current one. This is done by the call
captureConstraints (captureUntouchables (tcMonoBinds...))
captureConstraints (captureTcLevel (tcMonoBinds...))
in TcBinds.tcPolyInfer
* Call simplifyInfer to simplify the constraints and decide what to
quantify over. We pass in the level used for the RHS constraints,
here called rhs_untch.
here called rhs_tclvl.
This ensures that the implication constraint we generate, if any,
has a strictly-increased level compared to the ambient level outside
the let binding.
\begin{code}
simplifyInfer :: Untouchables -- Used when generating the constraints
simplifyInfer :: TcLevel -- Used when generating the constraints
-> Bool -- Apply monomorphism restriction
-> [(Name, TcTauType)] -- Variables to be generalised,
-- and their tau-types
......@@ -269,7 +269,7 @@ simplifyInfer :: Untouchables -- Used when generating the constraints
-- so the results type is not as general as
-- it could be
TcEvBinds) -- ... binding these evidence variables
simplifyInfer rhs_untch apply_mr name_taus wanteds
simplifyInfer rhs_tclvl apply_mr name_taus wanteds
| isEmptyWC wanteds
= do { gbl_tvs <- tcGetGlobalTyVars
; qtkvs <- quantifyTyVars gbl_tvs (tyVarsOfTypes (map snd name_taus))
......@@ -279,7 +279,7 @@ simplifyInfer rhs_untch apply_mr name_taus wanteds
| otherwise
= do { traceTc "simplifyInfer {" $ vcat
[ ptext (sLit "binds =") <+> ppr name_taus
, ptext (sLit "rhs_untch =") <+> ppr rhs_untch
, ptext (sLit "rhs_tclvl =") <+> ppr rhs_tclvl
, ptext (sLit "apply_mr =") <+> ppr apply_mr
, ptext (sLit "(unzonked) wanted =") <+> ppr wanteds
]
......@@ -300,7 +300,7 @@ simplifyInfer rhs_untch apply_mr name_taus wanteds
-- constraint.
; ev_binds_var <- TcM.newTcEvBinds
; wanted_transformed_incl_derivs <- setUntouchables rhs_untch $
; wanted_transformed_incl_derivs <- setTcLevel rhs_tclvl $
runTcSWithEvBinds ev_binds_var (solveWanteds wanteds)
; wanted_transformed_incl_derivs <- zonkWC wanted_transformed_incl_derivs
......@@ -331,9 +331,9 @@ simplifyInfer rhs_untch apply_mr name_taus wanteds
; WC { wc_flat = flats }
<- setUntouchables rhs_untch $
<- setTcLevel rhs_tclvl $
runTcSWithEvBinds null_ev_binds_var $
do { mapM_ (promoteAndDefaultTyVar rhs_untch gbl_tvs) meta_tvs
do { mapM_ (promoteAndDefaultTyVar rhs_tclvl gbl_tvs) meta_tvs
-- See Note [Promote _and_ default when inferring]
; solveFlatWanteds quant_cand }
......@@ -348,9 +348,9 @@ simplifyInfer rhs_untch apply_mr name_taus wanteds
; let zonked_tau_tvs = tyVarsOfTypes zonked_taus
; (promote_tvs, qtvs, bound, mr_bites) <- decideQuantification apply_mr quant_pred_candidates zonked_tau_tvs
; outer_untch <- TcRnMonad.getUntouchables
; outer_tclvl <- TcRnMonad.getTcLevel
; runTcSWithEvBinds null_ev_binds_var $ -- runTcS just to get the types right :-(
mapM_ (promoteTyVar outer_untch) (varSetElems promote_tvs)
mapM_ (promoteTyVar outer_tclvl) (varSetElems promote_tvs)
; let minimal_flat_preds = mkMinimalBySCs bound
-- See Note [Minimize by Superclasses]
......@@ -361,7 +361,7 @@ simplifyInfer rhs_untch apply_mr name_taus wanteds
-- tidied uniformly
; minimal_bound_ev_vars <- mapM TcM.newEvVar minimal_flat_preds
; let implic = Implic { ic_untch = rhs_untch
; let implic = Implic { ic_tclvl = rhs_tclvl
, ic_skols = qtvs
, ic_no_eqs = False
, ic_given = minimal_bound_ev_vars
......@@ -641,7 +641,7 @@ simplifyRule :: RuleName
-- See Note [Simplifying RULE constraints] in TcRule
simplifyRule name lhs_wanted rhs_wanted
= do { -- We allow ourselves to unify environment
-- variables: runTcS runs with NoUntouchables
-- variables: runTcS runs with topTcLevel
(resid_wanted, _) <- solveWantedsTcM (lhs_wanted `andWC` rhs_wanted)
-- Post: these are zonked and unflattened
......@@ -861,7 +861,7 @@ solveImplication :: Implication -- Wanted
Bag Implication) -- Unsolved rest (always empty or singleton)
-- Precondition: The TcS monad contains an empty worklist and given-only inerts
-- which after trying to solve this implication we must restore to their original value
solveImplication imp@(Implic { ic_untch = untch
solveImplication imp@(Implic { ic_tclvl = tclvl
, ic_binds = ev_binds
, ic_skols = skols
, ic_given = givens
......@@ -873,15 +873,15 @@ solveImplication imp@(Implic { ic_untch = untch
-- Solve the nested constraints
; (no_given_eqs, residual_wanted)
<- nestImplicTcS ev_binds untch $
do { solveFlatGivens (mkGivenLoc untch info env) givens
<- nestImplicTcS ev_binds tclvl $
do { solveFlatGivens (mkGivenLoc tclvl info env) givens
; residual_wanted <- solveWanteds wanteds
-- solveWanteds, *not* solveWantedsAndDrop, because
-- we want to retain derived equalities so we can float
-- them out in floatEqualities
; no_eqs <- getNoGivenEqs untch skols
; no_eqs <- getNoGivenEqs tclvl skols
; return (no_eqs, residual_wanted) }
......@@ -947,25 +947,25 @@ Consider floated_eqs (all wanted or derived):
simpl_loop. So we iterate if there any of these
\begin{code}
promoteTyVar :: Untouchables -> TcTyVar -> TcS ()
promoteTyVar :: TcLevel -> TcTyVar -> TcS ()
-- When we float a constraint out of an implication we must restore
-- invariant (MetaTvInv) in Note [Untouchable type variables] in TcType
-- invariant (MetaTvInv) in Note [TcLevel and untouchable type variables] in TcType
-- See Note [Promoting unification variables]
promoteTyVar untch tv
| isFloatedTouchableMetaTyVar untch tv
promoteTyVar tclvl tv
| isFloatedTouchableMetaTyVar tclvl tv
= do { cloned_tv <- TcS.cloneMetaTyVar tv
; let rhs_tv = setMetaTyVarUntouchables cloned_tv untch
; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl
; setWantedTyBind tv (mkTyVarTy rhs_tv) }
| otherwise
= return ()
promoteAndDefaultTyVar :: Untouchables -> TcTyVarSet -> TyVar -> TcS ()
promoteAndDefaultTyVar :: TcLevel -> TcTyVarSet -> TyVar -> TcS ()
-- See Note [Promote _and_ default when inferring]
promoteAndDefaultTyVar untch gbl_tvs tv
promoteAndDefaultTyVar tclvl gbl_tvs tv
= do { tv1 <- if tv `elemVarSet` gbl_tvs
then return tv
else defaultTyVar tv
; promoteTyVar untch tv1 }
; promoteTyVar tclvl tv1 }
defaultTyVar :: TcTyVar -> TcS TcTyVar
-- Precondition: MetaTyVars only
......@@ -979,7 +979,7 @@ defaultTyVar the_tv
; return new_tv }
-- Why not directly derived_pred = mkTcEqPred k default_k?