import TcErrors ( typeExtraInfoMsg, unifyCtxt )
import TcMType
-import TcEnv
import TcIface
import TcRnMonad
import TcType
-- Returns a wrapper of shape ty_actual ~ ty_expected
tcSubType origin skol_info ty_actual ty_expected
| isSigmaTy ty_actual
- = do { let extra_tvs = tyVarsOfType ty_actual
- ; (sk_wrap, inst_wrap)
- <- tcGen skol_info extra_tvs ty_expected $ \ _ sk_rho -> do
+ = do { (sk_wrap, inst_wrap)
+ <- tcGen skol_info ty_expected $ \ _ sk_rho -> do
{ (in_wrap, in_rho) <- deeplyInstantiate origin ty_actual
; coi <- unifyType in_rho sk_rho
; return (coiToHsWrapper coi <.> in_wrap) }
%************************************************************************
\begin{code}
-tcGen :: SkolemInfo -> TcTyVarSet -> TcType
+tcGen :: SkolemInfo -> TcType
-> ([TcTyVar] -> TcRhoType -> TcM result)
-> TcM (HsWrapper, result)
-- The expression has type: spec_ty -> expected_ty
-tcGen skol_info extra_tvs
- expected_ty thing_inside -- We expect expected_ty to be a forall-type
- -- If not, the call is a no-op
+tcGen skol_info expected_ty thing_inside
+ -- We expect expected_ty to be a forall-type
+ -- If not, the call is a no-op
= do { traceTc "tcGen" empty
; (wrap, tvs', given, rho') <- deeplySkolemise skol_info expected_ty
text "expected_ty" <+> ppr expected_ty,
text "inst ty" <+> ppr tvs' <+> ppr rho' ]
- -- In 'free_tvs' we must check that the "forall_tvs" havn't been constrained
+ -- Generally we must check that the "forall_tvs" havn't been constrained
-- The interesting bit here is that we must include the free variables
-- of the expected_ty. Here's an example:
-- runST (newVar True)
-- for (newVar True), with s fresh. Then we unify with the runST's arg type
-- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
-- So now s' isn't unconstrained because it's linked to a.
- -- Conclusion: pass the free vars of the expected_ty to checkConsraints
- ; let free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs
+ --
+ -- However [Oct 10] now that the untouchables are a range of
+ -- TcTyVars, all tihs is handled automatically with no need for
+ -- extra faffing around
- ; (ev_binds, result) <- checkConstraints skol_info free_tvs tvs' given $
+ ; (ev_binds, result) <- checkConstraints skol_info tvs' given $
thing_inside tvs' rho'
; return (wrap <.> mkWpLet ev_binds, result) }
-- often empty, in which case mkWpLet is a no-op
checkConstraints :: SkolemInfo
- -> TcTyVarSet -- Free variables (other than the type envt)
- -- for the skolem escape check
-> [TcTyVar] -- Skolems
-> [EvVar] -- Given
-> TcM result
-> TcM (TcEvBinds, result)
-checkConstraints skol_info free_tvs skol_tvs given thing_inside
+checkConstraints skol_info skol_tvs given thing_inside
| null skol_tvs && null given
= do { res <- thing_inside; return (emptyTcEvBinds, res) }
-- Just for efficiency. We check every function argument with
-- tcPolyExpr, which uses tcGen and hence checkConstraints.
| otherwise
- = do { (ev_binds, wanted, result) <- newImplication skol_info free_tvs
- skol_tvs given thing_inside
- ; emitConstraints wanted
- ; return (ev_binds, result) }
+ = newImplication skol_info skol_tvs given thing_inside
-newImplication :: SkolemInfo -> TcTyVarSet -> [TcTyVar]
+newImplication :: SkolemInfo -> [TcTyVar]
-> [EvVar] -> TcM result
- -> TcM (TcEvBinds, WantedConstraints, result)
-newImplication skol_info free_tvs skol_tvs given thing_inside
+ -> TcM (TcEvBinds, result)
+newImplication skol_info skol_tvs given thing_inside
= ASSERT2( all isTcTyVar skol_tvs, ppr skol_tvs )
ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs )
- do { gbl_tvs <- tcGetGlobalTyVars
- ; free_tvs <- zonkTcTyVarsAndFV free_tvs
- ; let untch = gbl_tvs `unionVarSet` free_tvs
-
- ; (result, wanted) <- getConstraints $
- setUntouchables untch $
- thing_inside
+ do { ((result, untch), wanted) <- captureConstraints $
+ captureUntouchables $
+ thing_inside
; if isEmptyBag wanted && not (hasEqualities given)
-- Optimisation : if there are no wanteds, and the givens
-- we don't want to lose the "inaccessible alternative"
-- error check
then
- return (emptyTcEvBinds, emptyWanteds, result)
+ return (emptyTcEvBinds, result)
else do
{ ev_binds_var <- newTcEvBinds
; lcl_env <- getLclTypeEnv
, ic_binds = ev_binds_var
, ic_loc = loc }
- ; return (TcEvBinds ev_binds_var, unitBag (WcImplic implic), result) } }
+ ; emitConstraint (WcImplic implic)
+ ; return (TcEvBinds ev_binds_var, result) } }
\end{code}
%************************************************************************
go _ ty1 ty2
| tcIsForAllTy ty1 || tcIsForAllTy ty2
-{-- | isSigmaTy ty1 || isSigmaTy ty2 --}
= unifySigmaTy origin ty1 ty2
-- Anything else fails
in_scope = mkInScopeSet (mkVarSet skol_tvs)
phi1 = substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1
phi2 = substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2
- untch = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
-
- ; (coi, lie) <- getConstraints $
- setUntouchables untch $
- uType origin phi1 phi2
+-- untch = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
+ ; ((coi, _untch), lie) <- captureConstraints $
+ captureUntouchables $
+ uType origin phi1 phi2
-- Check for escape; e.g. (forall a. a->b) ~ (forall a. a->a)
; let bad_lie = filterBag is_bad lie
is_bad w = any (`elemVarSet` tyVarsOfWanted w) skol_tvs
projects / ghc-hetmet.git / blobdiff