import Inst
import Var
import VarSet
+import VarEnv ( varEnvElts )
+
import Name
import NameEnv ( emptyNameEnv )
import Bag
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)
+ ; traceTc "sinf" $ vcat
+ [ ptext (sLit "perhaps_bound =") <+> ppr perhaps_bound
+ , ptext (sLit "surely_free =") <+> ppr surely_free
+ ]
-- Now simplify the possibly-bound constraints
; (simplified_perhaps_bound, tc_binds)
-- 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*
= 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
; 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"
; 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 }" $
, text "inert =" <+> ppr inert ]
; (unsolved_flats, unsolved_implics)
<- simpl_loop 1 can_flats implic_wanteds
+ ; bb <- getTcEvBindsBag
; traceTcS "solveWanteds }" $
vcat [ text "wanteds =" <+> ppr wanteds
, text "unsolved_flats =" <+> ppr unsolved_flats
- , text "unsolved_implics =" <+> ppr unsolved_implics ]
+ , text "unsolved_implics =" <+> ppr unsolved_implics
+ , text "current evbinds =" <+> vcat (map ppr (varEnvElts bb))
+ ]
; return (unsolved_flats, unsolved_implics) }
where
simpl_loop :: Int
, ic_wanted = wanteds
, ic_loc = loc })
= nestImplicTcS ev_binds untch $
+ recoverTcS (return (emptyBag, emptyBag)) $
+ -- Recover from nested failures. Even the top level is
+ -- just a bunch of implications, so failing at the first
+ -- one is bad
do { traceTcS "solveImplication {" (ppr imp)
-- Solve flat givens
| isEmptyBag wanteds
= return emptyBag
| otherwise
- = do { untch <- getUntouchablesTcS
+ = do { untch <- getUntouchables
; tv_cts <- mapM (defaultTyVar untch) $
- varSetElems (tyVarsOfCanonicals wanteds)
+ varSetElems (tyVarsOfCDicts 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])
; 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
-- whatever, because the type-class defaulting rules have yet to run.
defaultTyVar untch the_tv
- | isMetaTyVar the_tv
- , not (the_tv `elemVarSet` untch)
+ | isTouchableMetaTyVar_InRange untch the_tv
, not (k `eqKind` default_k)
- = do { (ev, better_ty) <- TcSMonad.newKindConstraint (mkTyVarTy the_tv) default_k
+ = do { (ev, better_ty) <- TcSMonad.newKindConstraint the_tv default_k
; let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk
-- 'DefaultOrigin' is strictly the declaration, but it's convenient
wanted_eq = CTyEqCan { cc_id = ev
:: ( 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))
is_defaultable_group ds@((_,tv):_)
= isTyConableTyVar tv -- Note [Avoiding spurious errors]
&& not (tv `elemVarSet` bad_tvs)
- && not (tv `elemVarSet` untch) -- Non untouchable
+ && isTouchableMetaTyVar_InRange untch tv
&& defaultable_classes [cc_class cc | (cc,_) <- ds]
is_defaultable_group [] = panic "defaultable_group"
------------------------------
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,
, 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
; 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
projects / ghc-hetmet.git / blobdiff