Commit debb7b80 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Beautiful new approach to the skolem-escape check and untouchable

Instead of keeping a *set* of untouchable variables in each
implication contraints, we keep a *range* of uniques for the
*touchable* variables of an implication.  This are precisely
the ones we would call the "existentials" if we were French.

It turns out that the code is more efficient, and vastly easier
to get right, than the set-based approach.

Fixes Trac #4355 among others
parent cd2f5397
......@@ -591,7 +591,7 @@ addConstraint actual expected = do
recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
text "with", ppr expected])
(congruenceNewtypes actual expected >>=
(getConstraints . uncurry unifyType) >> return ())
(captureConstraints . uncurry unifyType) >> return ())
-- TOMDO: what about the coercion?
-- we should consider family instances
......@@ -862,7 +862,7 @@ improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do
(ty_tvs, _, _) <- tcInstType return ty
(ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
(_, _, rtti_ty') <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
_ <- getConstraints(unifyType rtti_ty' ty')
_ <- captureConstraints (unifyType rtti_ty' ty')
tvs1_contents <- zonkTcTyVars ty_tvs'
let subst = (uncurry zipTopTvSubst . unzip)
[(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
......
......@@ -271,7 +271,7 @@ bindLocalInsts top_lvl thing_inside
-- leave them to the tcSimplifyTop, and quite a bit faster too
| otherwise -- Nested case
= do { ((binds, ids, thing), lie) <- getConstraints thing_inside
= do { ((binds, ids, thing), lie) <- captureConstraints thing_inside
; lie_binds <- bindLocalMethods lie ids
; return (binds, lie_binds, thing) }
-}
......@@ -417,7 +417,7 @@ tcPolyInfer
-> TcM (LHsBinds TcId, [TcId])
tcPolyInfer top_lvl mono sig_fn prag_fn rec_tc bind_list
= do { ((binds', mono_infos), wanted)
<- getConstraints $
<- captureConstraints $
tcMonoBinds sig_fn LetLclBndr rec_tc bind_list
; unifyCtxts [sig | (_, Just sig, _) <- mono_infos]
......
......@@ -300,7 +300,7 @@ tcInstSigTyVars = mapM (\tv -> instMetaTyVar (SigTv (tyVarName tv)) tv)
newMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar
-- Make a new meta tyvar out of thin air
newMetaTyVar meta_info kind
= do { uniq <- newUnique
= do { uniq <- newMetaUnique
; ref <- newMutVar Flexi
; let name = mkSysTvName uniq fs
fs = case meta_info of
......@@ -312,7 +312,7 @@ instMetaTyVar :: MetaInfo -> TyVar -> TcM TcTyVar
-- Make a new meta tyvar whose Name and Kind
-- come from an existing TyVar
instMetaTyVar meta_info tyvar
= do { uniq <- newUnique
= do { uniq <- newMetaUnique
; ref <- newMutVar Flexi
; let name = setNameUnique (tyVarName tyvar) uniq
kind = tyVarKind tyvar
......@@ -583,8 +583,10 @@ zonkQuantifiedTyVar tv
-- Create the new, frozen, skolem type variable
-- We zonk to a skolem, not to a regular TcVar
-- See Note [Zonking to Skolem]
; uniq <- newUnique -- Remove it from TcMetaTyVar unique land
; let final_kind = defaultKind (tyVarKind tv)
final_tv = mkSkolTyVar (tyVarName tv) final_kind UnkSkol
final_name = setNameUnique (tyVarName tv) uniq
final_tv = mkSkolTyVar final_name final_kind UnkSkol
-- Bind the meta tyvar to the new tyvar
; case details of
......@@ -601,13 +603,11 @@ zonkQuantifiedTyVar tv
\begin{code}
zonkImplication :: Implication -> TcM Implication
zonkImplication implic@(Implic { ic_untch = env_tvs, ic_given = given
zonkImplication implic@(Implic { ic_given = given
, ic_wanted = wanted })
= do { env_tvs' <- zonkTcTyVarsAndFV env_tvs
; given' <- mapM zonkEvVar given
= do { given' <- mapM zonkEvVar given
; wanted' <- mapBagM zonkWanted wanted
; return (implic { ic_untch = env_tvs', ic_given = given'
, ic_wanted = wanted' }) }
; return (implic { ic_given = given', ic_wanted = wanted' }) }
zonkEvVar :: EvVar -> TcM EvVar
zonkEvVar var = do { ty' <- zonkTcType (varType var)
......
......@@ -294,7 +294,7 @@ bindInstsOfPatId id thing_inside
| not (isOverloadedTy (idType id))
= do { res <- thing_inside; return (res, emptyTcEvBinds) }
| otherwise
= do { (res, lie) <- getConstraints thing_inside
= do { (res, lie) <- captureConstraints thing_inside
; binds <- bindLocalMethods lie [id]
; return (res, binds) }
-}
......@@ -410,11 +410,12 @@ tc_pat penv (BangPat pat) pat_ty thing_inside
tc_pat penv lpat@(LazyPat pat) pat_ty thing_inside
= do { (pat', (res, pat_ct))
<- tc_lpat pat pat_ty (makeLazy penv) $
getConstraints thing_inside
captureConstraints thing_inside
-- Ignore refined penv', revert to penv
; emitConstraints pat_ct
-- getConstraints/extendConstraintss: see Note [Hopping the LIE in lazy patterns]
-- captureConstraints/extendConstraints:
-- see Note [Hopping the LIE in lazy patterns]
-- Check there are no unlifted types under the lazy pattern
; when (any (isUnLiftedType . idType) $ collectPatBinders pat') $
......@@ -593,7 +594,7 @@ We can't discharge the Num constraint from dictionaries bound by
the pattern C!
So we have to make the constraints from thing_inside "hop around"
the pattern. Hence the getConstraints and emitConstraints.
the pattern. Hence the captureConstraints and emitConstraints.
The same thing ensures that equality constraints in a lazy match
are not made available in the RHS of the match. For example
......
......@@ -364,7 +364,7 @@ tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv
-- Reason: solely to report unused imports and bindings
tcRnSrcDecls boot_iface decls
= do { -- Do all the declarations
(tc_envs, lie) <- getConstraints $ tc_rn_src_decls boot_iface decls ;
(tc_envs, lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ;
; traceTc "Tc8" empty ;
; setEnvs tc_envs $
do {
......@@ -482,7 +482,7 @@ tcRnHsBootDecls decls
hs_ruleds = rule_decls,
hs_annds = _,
hs_valds = val_binds }) <- rnTopSrcDecls first_group
; (gbl_env, lie) <- getConstraints $ setGblEnv tcg_env $ do {
; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
-- Check for illegal declarations
......@@ -1274,7 +1274,7 @@ tcGhciStmts stmts
-- OK, we're ready to typecheck the stmts
traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
((tc_stmts, ids), lie) <- getConstraints $ tc_io_stmts stmts $ \ _ ->
((tc_stmts, ids), lie) <- captureConstraints $ tc_io_stmts stmts $ \ _ ->
mapM tcLookupId names ;
-- Look up the names right in the middle,
-- where they will all be in scope
......@@ -1307,8 +1307,8 @@ tcRnExpr hsc_env ictxt rdr_expr
-- Now typecheck the expression;
-- it might have a rank-2 type (e.g. :t runST)
((_tc_expr, res_ty), lie) <- getConstraints (tcInferRho rn_expr) ;
((qtvs, dicts, _), lie_top) <- getConstraints (simplifyInfer False {- No MR for now -}
((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ;
((qtvs, dicts, _), lie_top) <- captureConstraints (simplifyInfer False {- No MR for now -}
(tyVarsOfType res_ty) lie) ;
_ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings
......
......@@ -69,6 +69,7 @@ initTc :: HscEnv
initTc hsc_env hsc_src keep_rn_syntax mod do_this
= do { errs_var <- newIORef (emptyBag, emptyBag) ;
meta_var <- newIORef initTyVarUnique ;
tvs_var <- newIORef emptyVarSet ;
dfuns_var <- newIORef emptyNameSet ;
keep_var <- newIORef emptyNameSet ;
......@@ -133,7 +134,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
tcl_env = emptyNameEnv,
tcl_tyvars = tvs_var,
tcl_lie = lie_var,
tcl_untch = emptyVarSet
tcl_meta = meta_var,
tcl_untch = initTyVarUnique
} ;
} ;
......@@ -315,6 +317,16 @@ getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
%************************************************************************
\begin{code}
newMetaUnique :: TcM Unique
-- The uniques for TcMetaTyVars are allocated specially
-- in guaranteed linear order, starting at zero for each module
newMetaUnique
= do { env <- getLclEnv
; let meta_var = tcl_meta env
; uniq <- readMutVar meta_var
; writeMutVar meta_var (incrUnique uniq)
; return uniq }
newUnique :: TcRnIf gbl lcl Unique
newUnique
= do { env <- getEnv ;
......@@ -678,7 +690,7 @@ tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
-- for the thing is propagated only if there are no errors
-- Hence it's restricted to the type-check monad
tryTcLIE thing_inside
= do { ((msgs, mb_res), lie) <- getConstraints (tryTcErrs thing_inside) ;
= do { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ;
; case mb_res of
Nothing -> return (msgs, Nothing)
Just val -> do { emitConstraints lie; return (msgs, Just val) }
......@@ -951,25 +963,27 @@ emitConstraint ct
= do { lie_var <- getConstraintVar ;
updTcRef lie_var (`extendWanteds` ct) }
getConstraints :: TcM a -> TcM (a, WantedConstraints)
-- (getConstraints m) runs m, and returns the type constraints it generates
getConstraints thing_inside
captureConstraints :: TcM a -> TcM (a, WantedConstraints)
-- (captureConstraints m) runs m, and returns the type constraints it generates
captureConstraints thing_inside
= do { lie_var <- newTcRef emptyWanteds ;
res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
thing_inside ;
lie <- readTcRef lie_var ;
return (res, lie) }
setUntouchables :: TcTyVarSet -> TcM a -> TcM a
setUntouchables untch_tvs thing_inside
= updLclEnv (\ env -> env { tcl_untch = untch_tvs }) thing_inside
getUntouchables :: TcM TcTyVarSet
getUntouchables = do { env <- getLclEnv; return (tcl_untch env) }
-- NB: no need to zonk this TcTyVarSet: they are, after all, untouchable!
captureUntouchables :: TcM a -> TcM (a, Untouchables)
captureUntouchables thing_inside
= do { env <- getLclEnv
; low_meta <- readTcRef (tcl_meta env)
; res <- setLclEnv (env { tcl_untch = low_meta })
thing_inside
; high_meta <- readTcRef (tcl_meta env)
; return (res, TouchableRange low_meta high_meta) }
isUntouchable :: TcTyVar -> TcM Bool
isUntouchable tv = do { env <- getLclEnv; return (tv `elemVarSet` tcl_untch env) }
isUntouchable tv = do { env <- getLclEnv
; return (varUnique tv < tcl_untch env) }
getLclTypeEnv :: TcM (NameEnv TcTyThing)
getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
......
......@@ -28,7 +28,7 @@ module TcRnTypes(
ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope,
-- Constraints
Untouchables,
Untouchables(..), inTouchableRange,
WantedConstraints, emptyWanteds, andWanteds, extendWanteds,
WantedConstraint(..), WantedEvVar(..), wantedEvVarLoc,
wantedEvVarToVar, wantedEvVarPred, splitWanteds,
......@@ -68,11 +68,12 @@ import NameSet
import Var
import VarEnv
import Module
import UniqFM
import SrcLoc
import VarSet
import ErrUtils
import UniqFM
import UniqSupply
import Unique
import BasicTypes
import Bag
import Outputable
......@@ -383,7 +384,13 @@ data TcLclEnv -- Changes as we move inside an expression
-- Why mutable? see notes with tcGetGlobalTyVars
tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints
tcl_untch :: Untouchables -- Untouchables
-- TcMetaTyVars have
tcl_meta :: TcRef Unique, -- The next free unique for TcMetaTyVars
-- Guaranteed to be allocated linearly
tcl_untch :: Unique -- Any TcMetaTyVar with
-- unique >= tcl_untch is touchable
-- unique < tcl_untch is untouchable
}
type TcTypeEnv = NameEnv TcTyThing
......@@ -678,7 +685,25 @@ instance Outputable WhereFrom where
v%************************************************************************
\begin{code}
type Untouchables = TcTyVarSet -- All MetaTyVars
data Untouchables = NoUntouchables
| TouchableRange
Unique -- Low end
Unique -- High end
-- A TcMetaTyvar is *touchable* iff its unique u satisfies
-- u >= low
-- u < high
instance Outputable Untouchables where
ppr NoUntouchables = ptext (sLit "No untouchables")
ppr (TouchableRange low high) = ptext (sLit "Touchable range:") <+>
ppr low <+> char '-' <+> ppr high
inTouchableRange :: Untouchables -> TcTyVar -> Bool
inTouchableRange NoUntouchables _ = True
inTouchableRange (TouchableRange low high) tv
= uniq >= low && uniq < high
where
uniq = varUnique tv
type WantedConstraints = Bag WantedConstraint
......
......@@ -57,8 +57,8 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
; (lhs', lhs_lie, rhs', rhs_lie, rule_ty)
<- tcExtendTyVarEnv tv_bndrs $
tcExtendIdEnv id_bndrs $
do { ((lhs', rule_ty), lhs_lie) <- getConstraints (tcInferRho lhs)
; (rhs', rhs_lie) <- getConstraints (tcMonoExpr rhs rule_ty)
do { ((lhs', rule_ty), lhs_lie) <- captureConstraints (tcInferRho lhs)
; (rhs', rhs_lie) <- captureConstraints (tcMonoExpr rhs rule_ty)
; return (lhs', lhs_lie, rhs', rhs_lie, rule_ty) }
; (lhs_dicts, lhs_ev_binds, rhs_ev_binds)
......
......@@ -30,7 +30,7 @@ module TcSMonad (
newTcEvBindsTcS,
getInstEnvs, getFamInstEnvs, -- Getting the environments
getTopEnv, getGblEnv, getTcEvBinds, getUntouchablesTcS,
getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
......@@ -340,7 +340,9 @@ data TcSEnv
tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)),
-- Global type bindings
tcs_context :: SimplContext
tcs_context :: SimplContext,
tcs_untch :: Untouchables
}
data SimplContext
......@@ -412,7 +414,7 @@ traceTcS0 :: String -> SDoc -> TcS ()
traceTcS0 herald doc = TcS $ \_env -> TcM.traceTcN 0 herald doc
runTcS :: SimplContext
-> TcTyVarSet -- Untouchables
-> Untouchables -- Untouchables
-> TcS a -- What to run
-> TcM (a, Bag EvBind)
runTcS context untouch tcs
......@@ -420,10 +422,11 @@ runTcS context untouch tcs
; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
; let env = TcSEnv { tcs_ev_binds = ev_binds_var
, tcs_ty_binds = ty_binds_var
, tcs_context = context }
, tcs_context = context
, tcs_untch = untouch }
-- Run the computation
; res <- TcM.setUntouchables untouch (unTcS tcs env)
; res <- unTcS tcs env
-- Perform the type unifications required
; ty_binds <- TcM.readTcRef ty_binds_var
......@@ -436,30 +439,31 @@ runTcS context untouch tcs
do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
nestImplicTcS :: EvBindsVar -> TcTyVarSet -> TcS a -> TcS a
nestImplicTcS ref untouch tcs
nestImplicTcS :: EvBindsVar -> Untouchables -> TcS a -> TcS a
nestImplicTcS ref untch (TcS thing_inside)
= TcS $ \ TcSEnv { tcs_ty_binds = ty_binds, tcs_context = ctxt } ->
let
nest_env = TcSEnv { tcs_ev_binds = ref
, tcs_ty_binds = ty_binds
, tcs_context = ctxtUnderImplic ctxt }
, tcs_untch = untch
, tcs_context = ctxtUnderImplic ctxt }
in
TcM.setUntouchables untouch (unTcS tcs nest_env)
thing_inside nest_env
ctxtUnderImplic :: SimplContext -> SimplContext
-- See Note [Simplifying RULE lhs constraints] in TcSimplify
ctxtUnderImplic SimplRuleLhs = SimplCheck
ctxtUnderImplic ctxt = ctxt
tryTcS :: TcTyVarSet -> TcS a -> TcS a
tryTcS :: TcS a -> TcS a
-- Like runTcS, but from within the TcS monad
-- Ignore all the evidence generated, and do not affect caller's evidence!
tryTcS untch tcs
tryTcS tcs
= TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyVarEnv
; ev_binds_var <- TcM.newTcEvBinds
; let env1 = env { tcs_ev_binds = ev_binds_var
, tcs_ty_binds = ty_binds_var }
; TcM.setUntouchables untch (unTcS tcs env1) })
; unTcS tcs env1 })
-- Update TcEvBinds
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -473,6 +477,9 @@ getTcSContext = TcS (return . tcs_context)
getTcEvBinds :: TcS EvBindsVar
getTcEvBinds = TcS (return . tcs_ev_binds)
getUntouchables :: TcS Untouchables
getUntouchables = TcS (return . tcs_untch)
getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType)))
getTcSTyBinds = TcS (return . tcs_ty_binds)
......@@ -543,9 +550,6 @@ getTopEnv = wrapTcS $ TcM.getTopEnv
getGblEnv :: TcS TcGblEnv
getGblEnv = wrapTcS $ TcM.getGblEnv
getUntouchablesTcS :: TcS TcTyVarSet
getUntouchablesTcS = wrapTcS $ TcM.getUntouchables
-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -563,10 +567,10 @@ pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2)
isTouchableMetaTyVar :: TcTyVar -> TcS Bool
-- is touchable variable!
isTouchableMetaTyVar v
| isMetaTyVar v = wrapTcS $ do { untch <- TcM.isUntouchable v;
; return (not untch) }
| otherwise = return False
isTouchableMetaTyVar tv
| isMetaTyVar tv = do { untch <- getUntouchables
; return (inTouchableRange untch tv) }
| otherwise = return False
-- Flatten skolems
......
......@@ -247,7 +247,7 @@ simplifyAsMuchAsPossible :: SimplContext -> WantedConstraints
-- We use this function when inferring the type of a function
-- The wanted constraints are already zonked
simplifyAsMuchAsPossible ctxt wanteds
= do { let untch = emptyVarSet
= do { let untch = NoUntouchables
-- We allow ourselves to unify environment
-- variables; hence *no untouchables*
......@@ -451,7 +451,7 @@ simplifySuperClass self wanteds
= do { wanteds <- mapBagM zonkWanted wanteds
; loc <- getCtLoc NoScSkol
; (unsolved, ev_binds)
<- runTcS SimplCheck emptyVarSet $
<- runTcS SimplCheck NoUntouchables $
do { can_self <- canGivens loc [self]
; let inert = foldlBag updInertSet emptyInert can_self
-- No need for solveInteract; we know it's inert
......@@ -560,7 +560,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted
; rhs_binds_var@(EvBindsVar evb_ref _) <- newTcEvBinds
; loc <- getCtLoc (RuleSkol name)
; rhs_binds1 <- simplifyCheck SimplCheck $ unitBag $ WcImplic $
Implic { ic_untch = emptyVarSet -- No untouchables
Implic { ic_untch = NoUntouchables
, ic_env = emptyNameEnv
, ic_skols = mkVarSet tv_bndrs
, ic_scoped = panic "emitImplication"
......@@ -604,7 +604,7 @@ simplifyCheck ctxt wanteds
; traceTc "simplifyCheck {" (vcat
[ ptext (sLit "wanted =") <+> ppr wanteds ])
; (unsolved, ev_binds) <- runTcS ctxt emptyVarSet $
; (unsolved, ev_binds) <- runTcS ctxt NoUntouchables $
solveWanteds emptyInert wanteds
; traceTc "simplifyCheck }" $
......@@ -801,13 +801,13 @@ applyDefaultingRules inert wanteds
| isEmptyBag wanteds
= return emptyBag
| otherwise
= do { untch <- getUntouchablesTcS
= do { untch <- getUntouchables
; tv_cts <- mapM (defaultTyVar untch) $
varSetElems (tyVarsOfCanonicals wanteds)
; info@(_, default_tys, _) <- getDefaultInfo
; let groups = findDefaultableGroups info untch wanteds
; deflt_cts <- mapM (disambigGroup default_tys untch inert) groups
; deflt_cts <- mapM (disambigGroup default_tys inert) groups
; traceTcS "deflt2" (vcat [ text "Tyvar defaults =" <+> ppr tv_cts
, text "Type defaults =" <+> ppr deflt_cts])
......@@ -815,7 +815,7 @@ applyDefaultingRules inert wanteds
; return (unionManyBags deflt_cts `andCCan` unionManyBags tv_cts) }
------------------
defaultTyVar :: TcTyVarSet -> TcTyVar -> TcS CanonicalCts
defaultTyVar :: Untouchables -> TcTyVar -> TcS CanonicalCts
-- defaultTyVar is used on any un-instantiated meta type variables to
-- default the kind of ? and ?? etc to *. This is important to ensure
-- that instance declarations match. For example consider
......@@ -832,7 +832,7 @@ defaultTyVar :: TcTyVarSet -> TcTyVar -> TcS CanonicalCts
defaultTyVar untch the_tv
| isMetaTyVar the_tv
, not (the_tv `elemVarSet` untch)
, inTouchableRange untch the_tv
, not (k `eqKind` default_k)
= do { (ev, better_ty) <- TcSMonad.newKindConstraint (mkTyVarTy the_tv) default_k
; let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk
......@@ -855,7 +855,7 @@ findDefaultableGroups
:: ( SimplContext
, [Type]
, (Bool,Bool) ) -- (Overloaded strings, extended default rules)
-> TcTyVarSet -- Untouchable
-> Untouchables -- Untouchable
-> CanonicalCts -- Unsolved
-> [[(CanonicalCt,TcTyVar)]]
findDefaultableGroups (ctxt, default_tys, (ovl_strings, extended_defaults))
......@@ -882,7 +882,7 @@ findDefaultableGroups (ctxt, default_tys, (ovl_strings, extended_defaults))
is_defaultable_group ds@((_,tv):_)
= isTyConableTyVar tv -- Note [Avoiding spurious errors]
&& not (tv `elemVarSet` bad_tvs)
&& not (tv `elemVarSet` untch) -- Non untouchable
&& inTouchableRange untch tv
&& defaultable_classes [cc_class cc | (cc,_) <- ds]
is_defaultable_group [] = panic "defaultable_group"
......@@ -904,15 +904,14 @@ findDefaultableGroups (ctxt, default_tys, (ovl_strings, extended_defaults))
------------------------------
disambigGroup :: [Type] -- The default types
-> TcTyVarSet -- Untouchables
-> InertSet -- Given inert
-> [(CanonicalCt, TcTyVar)] -- All classes of the form (C a)
-- sharing same type variable
-> TcS CanonicalCts
disambigGroup [] _inert _untch _grp
disambigGroup [] _inert _grp
= return emptyBag
disambigGroup (default_ty:default_tys) untch inert group
disambigGroup (default_ty:default_tys) inert group
= do { traceTcS "disambigGroup" (ppr group $$ ppr default_ty)
; ev <- newGivOrDerCoVar (mkTyVarTy the_tv) default_ty default_ty -- Refl
-- We know this equality is canonical,
......@@ -922,7 +921,7 @@ disambigGroup (default_ty:default_tys) untch inert group
, cc_tyvar = the_tv
, cc_rhs = default_ty }
; success <- tryTcS (extendVarSet untch the_tv) $
; success <- tryTcS $
do { given_inert <- solveOne inert given_eq
; final_inert <- solveInteract given_inert (listToBag wanteds)
; let (_, unsolved) = extractUnsolved final_inert
......@@ -936,7 +935,7 @@ disambigGroup (default_ty:default_tys) untch inert group
; return (unitBag given_eq) }
False -> -- Failure: try with the next type
do { traceTcS "disambigGoup succeeded" (ppr default_ty)
; disambigGroup default_tys untch inert group } }
; disambigGroup default_tys inert group } }
where
((the_ct,the_tv):_) = group
wanteds = map fst group
......
......@@ -344,7 +344,7 @@ tcBracket brack res_ty
; let brack_stage = Brack cur_stage pending_splices lie_var
; (meta_ty, lie) <- setStage brack_stage $
getConstraints $
captureConstraints $
tc_bracket cur_stage brack
; simplifyBracket lie
......@@ -487,7 +487,7 @@ tcTopSpliceExpr tc_action
-- if the type checker fails!
setStage Splice $
do { -- Typecheck the expression
(expr', lie) <- getConstraints tc_action
(expr', lie) <- captureConstraints tc_action
-- Solve the constraints
; const_binds <- simplifyTop lie
......
......@@ -412,16 +412,16 @@ checkConstraints skol_info free_tvs skol_tvs given thing_inside
newImplication :: SkolemInfo -> TcTyVarSet -> [TcTyVar]
-> [EvVar] -> TcM result
-> TcM (TcEvBinds, WantedConstraints, result)
newImplication skol_info free_tvs skol_tvs given thing_inside
newImplication skol_info _free_tvs 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
do { -- gbl_tvs <- tcGetGlobalTyVars
-- ; free_tvs <- zonkTcTyVarsAndFV free_tvs
-- ; let untch = gbl_tvs `unionVarSet` free_tvs
; (result, wanted) <- getConstraints $
setUntouchables untch $
thing_inside
; ((result, untch), wanted) <- captureConstraints $
captureUntouchables $
thing_inside
; if isEmptyBag wanted && not (hasEqualities given)
-- Optimisation : if there are no wanteds, and the givens
......@@ -619,7 +619,6 @@ uType_np origin orig_ty1 orig_ty2
go _ ty1 ty2
| tcIsForAllTy ty1 || tcIsForAllTy ty2
{-- | isSigmaTy ty1 || isSigmaTy ty2 --}
= unifySigmaTy origin ty1 ty2
-- Anything else fails
......@@ -636,12 +635,11 @@ unifySigmaTy origin ty1 ty2
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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment