instBindingRequired, instCanBeGeneralised,
newDictsFromOld, instMentionsIPs,
getDictClassTys, isTyVarDict,
- instLoc, pprInst, zonkInst, tidyInsts,
+ instLoc, pprInst, zonkInst, tidyInsts, tidyMoreInsts,
Inst, LIE, pprInsts, pprInstsInFull,
mkLIE, lieToList
)
else
check_loop givens' (irreds ++ frees) `thenTc` \ (qtvs', frees1, binds1, irreds1) ->
returnTc (qtvs', frees1, binds `AndMonoBinds` binds1, irreds1)
-
-complainCheck doc givens irreds
- = mapNF_Tc zonkInst given_dicts `thenNF_Tc` \ givens' ->
- mapNF_Tc (addNoInstanceErr doc given_dicts) irreds `thenNF_Tc_`
- returnTc ()
- where
- given_dicts = filter isDict givens
- -- Filter out methods, which are only added to
- -- the given set as an optimisation
\end{code}
-- foo = f (3::Int)
-- We want to infer the polymorphic type
-- foo :: forall b. b -> b
- tcSimplifyToDicts wanted_lie `thenTc` \ (dicts, _) ->
let
- constrained_tvs = tyVarsOfInsts dicts
+ wanteds = lieToList wanted_lie
+ try_me inst = ReduceMe -- Reduce as far as we can. Don't stop at
+ -- dicts; the idea is to get rid of as many type
+ -- variables as possible, and we don't want to stop
+ -- at (say) Monad (ST s), because that reduces
+ -- immediately, with no constraint on s.
in
+ simpleReduceLoop doc try_me wanteds `thenTc` \ (_, _, constrained_dicts) ->
-- Next, figure out the tyvars we will quantify over
zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenNF_Tc` \ tau_tvs' ->
tcGetGlobalTyVars `thenNF_Tc` \ gbl_tvs ->
let
- qtvs = (tau_tvs' `minusVarSet` oclose (predsOfInsts dicts) gbl_tvs)
+ constrained_tvs = tyVarsOfInsts constrained_dicts
+ qtvs = (tau_tvs' `minusVarSet` oclose (predsOfInsts constrained_dicts) gbl_tvs)
`minusVarSet` constrained_tvs
in
reduceContext doc try_me [] wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
ASSERT( no_improvement )
ASSERT( null irreds )
- -- No need to loop because tcSimplifyToDicts will have
+ -- No need to loop because simpleReduceLoop will have
-- already done any improvement necessary
returnTc (varSetElems qtvs, mkLIE frees, binds)
unifyTauTy (substTy tenv t1) (substTy tenv t2)
ppr_eqn ((qtvs, t1, t2), doc)
= vcat [ptext SLIT("forall") <+> braces (pprWithCommas ppr (varSetElems qtvs))
- <+> ppr t1 <+> equals <+> ppr t2,
- doc]
+ <+> ppr t1 <+> ptext SLIT(":=:") <+> ppr t2,
+ nest 2 doc]
\end{code}
The main context-reduction function is @reduce@. Here's its game plan.
now?
\begin{code}
+groupInsts :: [Inst] -> [[Inst]]
+-- Group together insts with the same origin
+-- We want to report them together in error messages
+groupInsts [] = []
+groupInsts (inst:insts) = (inst:friends) : groupInsts others
+ where
+ -- (It may seem a bit crude to compare the error messages,
+ -- but it makes sure that we combine just what the user sees,
+ -- and it avoids need equality on InstLocs.)
+ (friends, others) = partition is_friend insts
+ loc_msg = showSDoc (pprInstLoc (instLoc inst))
+ is_friend friend = showSDoc (pprInstLoc (instLoc friend)) == loc_msg
+
+
addTopAmbigErrs dicts
- = mapNF_Tc complain tidy_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
- complain d | any isIPPred (predsOfInst d) = addTopIPErr tidy_env d
- | not (isTyVarDict d) ||
- tyVarsOfInst d `subVarSet` fixed_tvs = addTopInstanceErr tidy_env d
- | otherwise = addAmbigErr tidy_env d
+ (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
-addTopIPErr tidy_env tidy_dict
- = addInstErrTcM (instLoc tidy_dict)
+plural [x] = empty
+plural xs = char 's'
+
+addTopIPErrs tidy_env tidy_dicts
+ = addInstErrTcM (instLoc (head tidy_dicts))
(tidy_env,
- ptext SLIT("Unbound implicit parameter") <+> quotes (pprInst tidy_dict))
+ ptext SLIT("Unbound implicit parameter") <> plural tidy_dicts <+> pprInsts tidy_dicts)
-- Used for top-level irreducibles
-addTopInstanceErr tidy_env tidy_dict
- = addInstErrTcM (instLoc tidy_dict)
+addTopInstanceErrs tidy_env tidy_dicts
+ = addInstErrTcM (instLoc (head tidy_dicts))
(tidy_env,
- ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict))
+ ptext SLIT("No instance") <> plural tidy_dicts <+>
+ ptext SLIT("for") <+> pprInsts tidy_dicts)
addAmbigErrs dicts
= mapNF_Tc (addAmbigErr tidy_env) tidy_dicts
quotes (ppr default_ty),
pprInstsInFull tidy_dicts]
--- The error message when we don't find a suitable instance
--- is complicated by the fact that sometimes this is because
--- there is no instance, and sometimes it's because there are
--- too many instances (overlap). See the comments in TcEnv.lhs
--- with the InstEnv stuff.
-addNoInstanceErr what_doc givens dict
+complainCheck doc givens irreds
+ = mapNF_Tc zonkInst given_dicts `thenNF_Tc` \ givens' ->
+ mapNF_Tc (addNoInstanceErrs doc givens') (groupInsts irreds) `thenNF_Tc_`
+ returnNF_Tc ()
+ where
+ given_dicts = filter isDict givens
+ -- Filter out methods, which are only added to
+ -- the given set as an optimisation
+
+addNoInstanceErrs what_doc givens dicts
= tcGetInstEnv `thenNF_Tc` \ inst_env ->
let
- doc = vcat [sep [herald <+> quotes (pprInst tidy_dict),
+ (tidy_env1, tidy_givens) = tidyInsts givens
+ (tidy_env2, tidy_dicts) = tidyMoreInsts tidy_env1 dicts
+
+ doc = vcat [sep [herald <+> pprInsts tidy_dicts,
nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens],
ambig_doc,
ptext SLIT("Probable fix:"),
unambig_doc | ambig_overlap = ptext SLIT("unambiguously")
| otherwise = empty
+ -- The error message when we don't find a suitable instance
+ -- is complicated by the fact that sometimes this is because
+ -- there is no instance, and sometimes it's because there are
+ -- too many instances (overlap). See the comments in TcEnv.lhs
+ -- with the InstEnv stuff.
+
ambig_doc
| not ambig_overlap = empty
| otherwise
= vcat [ptext SLIT("The choice of (overlapping) instance declaration"),
nest 4 (ptext SLIT("depends on the instantiation of") <+>
- quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst tidy_dict))))]
+ quotes (pprWithCommas ppr (varSetElems (tyVarsOfInsts tidy_dicts))))]
- fix1 = sep [ptext SLIT("Add") <+> quotes (pprInst tidy_dict),
+ fix1 = sep [ptext SLIT("Add") <+> pprInsts tidy_dicts,
ptext SLIT("to the") <+> what_doc]
- fix2 | isTyVarDict dict
- || not (isClassDict dict) -- Don't suggest adding instance declarations for implicit parameters
- || ambig_overlap
+ fix2 | null instance_dicts
= empty
| otherwise
- = ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict)
+ = ptext SLIT("Or add an instance declaration for") <+> pprInsts instance_dicts
- (tidy_env, tidy_dict:tidy_givens) = tidyInsts (dict:givens)
+ instance_dicts = [d | d <- tidy_dicts, isClassDict d, not (isTyVarDict d)]
+ -- Insts for which it is worth suggesting an adding an instance declaration
+ -- Exclude implicit parameters, and tyvar dicts
-- Checks for the ambiguous case when we have overlapping instances
- ambig_overlap | isClassDict dict
- = case lookupInstEnv inst_env clas tys of
+ ambig_overlap = any ambig_overlap1 dicts
+ ambig_overlap1 dict
+ | isClassDict dict
+ = case lookupInstEnv inst_env clas tys of
NoMatch ambig -> ambig
other -> False
- | otherwise = False
- where
- (clas,tys) = getDictClassTys dict
+ | otherwise = False
+ where
+ (clas,tys) = getDictClassTys dict
in
- addInstErrTcM (instLoc dict) (tidy_env, doc)
+ addInstErrTcM (instLoc (head dicts)) (tidy_env2, doc)
-- Used for the ...Thetas variants; all top level
addNoInstErr pred
projects / ghc-hetmet.git / blobdiff