TcEvBinds) -- ... binding these evidence variables
simplifyInfer apply_mr tau_tvs wanted
| isEmptyBag wanted -- Trivial case is quite common
- = do { zonked_tau_tvs <- zonkTcTyVarsAndFV (varSetElems tau_tvs)
+ = do { zonked_tau_tvs <- zonkTcTyVarsAndFV tau_tvs
; gbl_tvs <- tcGetGlobalTyVars -- Already zonked
; qtvs <- zonkQuantifiedTyVars (varSetElems (zonked_tau_tvs `minusVarSet` gbl_tvs))
; return (qtvs, [], emptyTcEvBinds) }
, ptext (sLit "tau_tvs =") <+> ppr tau_tvs
]
- ; (simple_wanted, tc_binds)
- <- simplifyAsMuchAsPossible SimplInfer zonked_wanted
-
+ -- Make a guess at the quantified type variables
+ -- Then split the constraints on the baisis of those tyvars
+ -- to avoid unnecessarily simplifying a class constraint
+ -- See Note [Avoid unecessary constraint simplification]
+ ; gbl_tvs <- tcGetGlobalTyVars
+ ; zonked_tau_tvs <- zonkTcTyVarsAndFV tau_tvs
+ ; let proto_qtvs = growWanteds gbl_tvs zonked_wanted $
+ zonked_tau_tvs `minusVarSet` gbl_tvs
+ (perhaps_bound, surely_free)
+ = partitionBag (quantifyMeWC proto_qtvs) zonked_wanted
+ ; emitConstraints surely_free
+ ; traceTc "sinf" (ppr proto_qtvs $$ ppr perhaps_bound $$ ppr surely_free)
+
+ -- Now simplify the possibly-bound constraints
+ ; (simplified_perhaps_bound, tc_binds)
+ <- simplifyAsMuchAsPossible SimplInfer perhaps_bound
+
+ -- Sigh: must re-zonk because because simplifyAsMuchAsPossible
+ -- may have done some unification
; gbl_tvs <- tcGetGlobalTyVars
- ; zonked_tau_tvs <- zonkTcTyVarsAndFV (varSetElems tau_tvs)
- ; zonked_simples <- mapBagM zonkWantedEvVar simple_wanted
- ; let qtvs = findQuantifiedTyVars apply_mr zonked_simples zonked_tau_tvs gbl_tvs
- (bound, free) | apply_mr = (emptyBag, zonked_simples)
- | otherwise = partitionBag (quantifyMe qtvs) zonked_simples
+ ; zonked_tau_tvs <- zonkTcTyVarsAndFV tau_tvs
+ ; zonked_simples <- mapBagM zonkWantedEvVar simplified_perhaps_bound
+ ; let init_tvs = zonked_tau_tvs `minusVarSet` gbl_tvs
+ mr_qtvs = init_tvs `minusVarSet` constrained_tvs
+ constrained_tvs = tyVarsOfWantedEvVars zonked_simples
+ qtvs = growWantedEVs gbl_tvs zonked_simples init_tvs
+ (final_qtvs, (bound, free))
+ | apply_mr = (mr_qtvs, (emptyBag, zonked_simples))
+ | otherwise = (qtvs, partitionBag (quantifyMe qtvs) zonked_simples)
; traceTc "end simplifyInfer }" $
vcat [ ptext (sLit "apply_mr =") <+> ppr apply_mr
, text "wanted = " <+> ppr zonked_wanted
- , text "qtvs = " <+> ppr qtvs
+ , text "qtvs = " <+> ppr final_qtvs
, text "free = " <+> ppr free
, text "bound = " <+> ppr bound ]
-- Turn the quantified meta-type variables into real type variables
; emitConstraints (mapBag WcEvVar free)
- ; qtvs_to_return <- zonkQuantifiedTyVars (varSetElems qtvs)
+ ; qtvs_to_return <- zonkQuantifiedTyVars (varSetElems final_qtvs)
; let bound_evvars = bagToList $ mapBag wantedEvVarToVar bound
; return (qtvs_to_return, bound_evvars, EvBinds tc_binds) }
simplifyApproxLoop 0 wanteds
-- Report any errors
- ; mapBagM_ reportUnsolvedImplication unsolved_implics
+ ; reportUnsolved (emptyBag, unsolved_implics)
; let final_wanted_evvars = mapBag deCanonicaliseWanted unsolved_flats
; return (final_wanted_evvars, ev_binds) }
\end{code}
\begin{code}
-findQuantifiedTyVars :: Bool -- Apply the MR
- -> Bag WantedEvVar -- Simplified constraints from RHS
- -> TyVarSet -- Free in tau-type of definition
- -> TyVarSet -- Free in the envt
- -> TyVarSet -- Quantify over these
-
-findQuantifiedTyVars apply_mr wanteds tau_tvs gbl_tvs
- | isEmptyBag wanteds = init_tvs
- | apply_mr = init_tvs `minusVarSet` constrained_tvs
- | otherwise = fixVarSet mk_next init_tvs
+growWantedEVs :: TyVarSet -> Bag WantedEvVar -> TyVarSet -> TyVarSet
+growWanteds :: TyVarSet -> Bag WantedConstraint -> TyVarSet -> TyVarSet
+growWanteds gbl_tvs ws tvs
+ | isEmptyBag ws = tvs
+ | otherwise = fixVarSet (\tvs -> foldrBag (growWanted gbl_tvs) tvs ws) tvs
+growWantedEVs gbl_tvs ws tvs
+ | isEmptyBag ws = tvs
+ | otherwise = fixVarSet (\tvs -> foldrBag (growWantedEV gbl_tvs) tvs ws) tvs
+
+growWantedEV :: TyVarSet -> WantedEvVar -> TyVarSet -> TyVarSet
+growWanted :: TyVarSet -> WantedConstraint -> TyVarSet -> TyVarSet
+-- (growX gbls wanted tvs) grows a seed 'tvs' against the
+-- X-constraint 'wanted', nuking the 'gbls' at each stage
+growWantedEV gbl_tvs wev tvs
+ = tvs `unionVarSet` (ev_tvs `minusVarSet` gbl_tvs)
where
- init_tvs = tau_tvs `minusVarSet` gbl_tvs
- mk_next tvs = foldrBag grow_one tvs wanteds
-
- grow_one wev tvs = tvs `unionVarSet` (extra_tvs `minusVarSet` gbl_tvs)
- where
- extra_tvs = growPredTyVars (wantedEvVarPred wev) tvs
+ ev_tvs = growPredTyVars (wantedEvVarPred wev) tvs
- constrained_tvs = tyVarsOfWantedEvVars wanteds
+growWanted gbl_tvs (WcEvVar wev) tvs
+ = growWantedEV gbl_tvs wev tvs
+growWanted gbl_tvs (WcImplic implic) tvs
+ = foldrBag (growWanted (gbl_tvs `unionVarSet` ic_skols implic))
+ tvs (ic_wanted implic)
--------------------
quantifyMe :: TyVarSet -- Quantifying over these
| otherwise = tyVarsOfPred pred `intersectsVarSet` qtvs
where
pred = wantedEvVarPred wev
+
+quantifyMeWC :: TyVarSet -> WantedConstraint -> Bool
+quantifyMeWC qtvs (WcImplic implic)
+ = anyBag (quantifyMeWC (qtvs `minusVarSet` ic_skols implic)) (ic_wanted implic)
+quantifyMeWC qtvs (WcEvVar wev)
+ = quantifyMe qtvs wev
\end{code}
+Note [Avoid unecessary constraint simplification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When inferring the type of a let-binding, with simplifyInfer,
+try to avoid unnecessariliy simplifying class constraints.
+Doing so aids sharing, but it also helps with delicate
+situations like
+ instance C t => C [t] where ..
+ f :: C [t] => ....
+ f x = let g y = ...(constraint C [t])...
+ in ...
+When inferring a type for 'g', we don't want to apply the
+instance decl, because then we can't satisfy (C t). So we
+just notice that g isn't quantified over 't' and partition
+the contraints before simplifying.
+
+This only half-works, but then let-generalisation only half-works.
+
+
Note [Inheriting implicit parameters]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this:
; (unsolved, ev_binds)
<- runTcS SimplCheck emptyVarSet $
do { can_self <- canGivens loc [self]
- ; let inert = foldlBag extendInertSet emptyInert can_self
+ ; let inert = foldlBag updInertSet emptyInert can_self
-- No need for solveInteract; we know it's inert
; solveWanteds inert wanteds }
; rhs_binds_var@(EvBindsVar evb_ref _) <- newTcEvBinds
; loc <- getCtLoc (RuleSkol name)
; rhs_binds1 <- simplifyCheck SimplCheck $ unitBag $ WcImplic $
- Implic { ic_env_tvs = emptyVarSet -- No untouchables
+ Implic { ic_untch = emptyVarSet -- No untouchables
, ic_env = emptyNameEnv
, ic_skols = mkVarSet tv_bndrs
, ic_scoped = panic "emitImplication"
--
-- Precondition: everything is zonked by now
solveImplication inert
- imp@(Implic { ic_env_tvs = untch
- , ic_binds = ev_binds
- , ic_skols = skols
- , ic_given = givens
+ imp@(Implic { ic_untch = untch
+ , ic_binds = ev_binds
+ , ic_skols = skols
+ , ic_given = givens
, ic_wanted = wanteds
- , ic_loc = loc })
+ , ic_loc = loc })
= nestImplicTcS ev_binds untch $
do { traceTcS "solveImplication {" (ppr imp)
-> CanonicalCts -> (CanonicalCts, CanonicalCts)
floatEqualities skols can_given wanteds
| hasEqualities can_given = (emptyBag, wanteds)
- | otherwise = partitionBag is_floatable wanteds
+ | otherwise = partitionBag is_floatable wanteds
where
is_floatable :: CanonicalCt -> Bool
is_floatable (CTyEqCan { cc_tyvar = tv, cc_rhs = ty })