X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=f0963f7af08c1aca0318261c6b671ac823b1afb2;hb=a40f2735958055f7ff94e5df73e710044aa63b2c;hp=5cbffdd872945f6a721ab93b75e1779c79f7201b;hpb=cd2f5397bc1345fc37706168c268a8bd37af7f2f;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 5cbffdd..f0963f7 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -18,6 +18,8 @@ import TcInteract import Inst import Var import VarSet +import VarEnv ( varEnvElts ) + import Name import NameEnv ( emptyNameEnv ) import Bag @@ -208,8 +210,12 @@ simplifyInfer apply_mr tau_tvs 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) + ; 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) @@ -247,7 +253,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 +457,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 +566,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 +610,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 }" $ @@ -629,10 +635,13 @@ solveWanteds inert wanteds , 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 @@ -801,13 +810,13 @@ applyDefaultingRules inert wanteds | 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]) @@ -815,7 +824,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 @@ -831,10 +840,9 @@ defaultTyVar :: TcTyVarSet -> TcTyVar -> TcS CanonicalCts -- 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 @@ -855,7 +863,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 +890,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 + && isTouchableMetaTyVar_InRange untch tv && defaultable_classes [cc_class cc | (cc,_) <- ds] is_defaultable_group [] = panic "defaultable_group" @@ -904,15 +912,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 +929,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 +943,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