Commit 44c2d766 authored by simonpj's avatar simonpj
Browse files

[project @ 2002-06-17 16:21:42 by simonpj]

Ignore fewer type errors in tcSimplifyTop; fixes tc106
parent 7c537ab2
...@@ -1598,42 +1598,49 @@ tcSimplifyTop wanted_lie ...@@ -1598,42 +1598,49 @@ tcSimplifyTop wanted_lie
std_groups = equivClasses cmp_by_tyvar stds std_groups = equivClasses cmp_by_tyvar stds
-- Pick the ones which its worth trying to disambiguate -- Pick the ones which its worth trying to disambiguate
(std_oks, std_bads) = partition worth_a_try std_groups -- namely, the onese whose type variable isn't bound
-- Have a try at disambiguation
-- if the type variable isn't bound
-- up with one of the non-standard classes -- up with one of the non-standard classes
(std_oks, std_bads) = partition worth_a_try std_groups
worth_a_try group@(d:_) = not (non_std_tyvars `intersectsVarSet` tyVarsOfInst d) worth_a_try group@(d:_) = not (non_std_tyvars `intersectsVarSet` tyVarsOfInst d)
non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds) non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds)
-- Collect together all the bad guys -- Collect together all the bad guys
bad_guys = non_stds ++ concat std_bads bad_guys = non_stds ++ concat std_bads
(tidy_env, tidy_dicts) = tidyInsts bad_guys
(bad_ips, non_ips) = partition is_ip tidy_dicts
(no_insts, ambigs) = partition no_inst non_ips
is_ip d = any isIPPred (predsOfInst d)
no_inst d = not (isTyVarDict d) || tyVarsOfInst d `subVarSet` fixed_tvs
fixed_tvs = oclose (predsOfInsts tidy_dicts) emptyVarSet
in in
ifErrsTc (returnTc []) ( -- Report definite errors
-- Don't check for ambiguous things mapNF_Tc (addTopInstanceErrs tidy_env) (groupInsts no_insts) `thenNF_Tc_`
-- if there has been an error; errors often mapNF_Tc (addTopIPErrs tidy_env) (groupInsts bad_ips) `thenNF_Tc_`
-- Deal with ambiguity errors, but only if
-- if there has not been an error so far; errors often
-- give rise to spurious ambiguous Insts -- give rise to spurious ambiguous Insts
ifErrsTc (returnTc []) (
-- Complain about the ones that don't fall under
-- And complain about the ones that don't fall under
-- the Haskell rules for disambiguation -- the Haskell rules for disambiguation
-- This group includes both non-existent instances -- This group includes both non-existent instances
-- e.g. Num (IO a) and Eq (Int -> Int) -- e.g. Num (IO a) and Eq (Int -> Int)
-- and ambiguous dictionaries -- and ambiguous dictionaries
-- e.g. Num a -- e.g. Num a
addTopAmbigErrs bad_guys `thenNF_Tc_` mapNF_Tc (addAmbigErr tidy_env) ambigs `thenNF_Tc_`
-- Disambiguate the ones that look feasible -- Disambiguate the ones that look feasible
mapTc disambigGroup std_oks mapTc disambigGroup std_oks
) `thenTc` \ binds_ambig -> ) `thenTc` \ binds_ambig ->
returnTc (binds `andMonoBinds` andMonoBindList binds_ambig) returnTc (binds `andMonoBinds` andMonoBindList binds_ambig)
where where
wanteds = lieToList wanted_lie wanteds = lieToList wanted_lie
d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2 ----------------------------------
d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
get_tv d = case getDictClassTys d of get_tv d = case getDictClassTys d of
(clas, [ty]) -> tcGetTyVar "tcSimplify" ty (clas, [ty]) -> tcGetTyVar "tcSimplify" ty
...@@ -1887,20 +1894,6 @@ groupInsts (inst:insts) = (inst:friends) : groupInsts others ...@@ -1887,20 +1894,6 @@ groupInsts (inst:insts) = (inst:friends) : groupInsts others
loc_msg = showSDoc (pprInstLoc (instLoc inst)) loc_msg = showSDoc (pprInstLoc (instLoc inst))
is_friend friend = showSDoc (pprInstLoc (instLoc friend)) == loc_msg is_friend friend = showSDoc (pprInstLoc (instLoc friend)) == loc_msg
addTopAmbigErrs dicts
= mapNF_Tc (addTopInstanceErrs tidy_env) (groupInsts no_insts) `thenNF_Tc_`
mapNF_Tc (addTopIPErrs tidy_env) (groupInsts bad_ips) `thenNF_Tc_`
mapNF_Tc (addAmbigErr tidy_env) ambigs `thenNF_Tc_`
returnNF_Tc ()
where
fixed_tvs = oclose (predsOfInsts tidy_dicts) emptyVarSet
(tidy_env, tidy_dicts) = tidyInsts dicts
(bad_ips, non_ips) = partition is_ip tidy_dicts
(no_insts, ambigs) = partition no_inst non_ips
is_ip d = any isIPPred (predsOfInst d)
no_inst d = not (isTyVarDict d) || tyVarsOfInst d `subVarSet` fixed_tvs
plural [x] = empty plural [x] = empty
plural xs = char 's' plural xs = char 's'
......
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