From 27f289f3190d7eedf758d3f2c08697a042186691 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 20 Aug 2001 07:54:33 +0000 Subject: [PATCH] [project @ 2001-08-20 07:54:33 by simonpj] Improve error messages from the typechecker, after a suggestion from Alastair Reid. --- ghc/compiler/typecheck/Inst.lhs | 17 ++--- ghc/compiler/typecheck/TcSimplify.lhs | 109 ++++++++++++++++++++------------- 2 files changed, 77 insertions(+), 49 deletions(-) diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 2d46001..c16ba2c 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -9,7 +9,7 @@ module Inst ( plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE, Inst, - pprInst, pprInsts, pprInstsInFull, tidyInsts, + pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts, newDictsFromOld, newDicts, newMethod, newMethodWithGivenTy, newOverloadedLit, @@ -99,7 +99,7 @@ zonkLIE :: LIE -> NF_TcM LIE zonkLIE lie = mapBagNF_Tc zonkInst lie pprInsts :: [Inst] -> SDoc -pprInsts insts = parens (sep (punctuate comma (map pprInst insts))) +pprInsts insts = parens (sep (punctuate comma (map pprInst insts))) pprInstsInFull insts @@ -532,13 +532,16 @@ tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc -tidyInsts :: [Inst] -> (TidyEnv, [Inst]) +tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst]) -- This function doesn't assume that the tyvars are in scope -- so it works like tidyOpenType, returning a TidyEnv -tidyInsts insts - = (env, map (tidyInst env) insts) +tidyMoreInsts env insts + = (env', map (tidyInst env') insts) where - env = tidyFreeTyVars emptyTidyEnv (tyVarsOfInsts insts) + env' = tidyFreeTyVars env (tyVarsOfInsts insts) + +tidyInsts :: [Inst] -> (TidyEnv, [Inst]) +tidyInsts insts = tidyMoreInsts emptyTidyEnv insts \end{code} @@ -648,5 +651,3 @@ lookupSimpleInst clas tys other -> returnNF_Tc Nothing \end{code} - - diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index fe8b600..b9da476 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -31,7 +31,7 @@ import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), instBindingRequired, instCanBeGeneralised, newDictsFromOld, instMentionsIPs, getDictClassTys, isTyVarDict, - instLoc, pprInst, zonkInst, tidyInsts, + instLoc, pprInst, zonkInst, tidyInsts, tidyMoreInsts, Inst, LIE, pprInsts, pprInstsInFull, mkLIE, lieToList ) @@ -685,15 +685,6 @@ tcSimplCheck doc is_free get_qtvs givens wanted_lie 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} @@ -1691,26 +1682,47 @@ from the insts, or just whatever seems to be around in the monad just 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 @@ -1736,15 +1748,22 @@ warnDefault dicts default_ty 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:"), @@ -1755,35 +1774,43 @@ addNoInstanceErr what_doc givens dict 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 -- 1.7.10.4