From: simonpj Date: Thu, 3 May 2001 09:32:49 +0000 (+0000) Subject: [project @ 2001-05-03 09:32:48 by simonpj] X-Git-Tag: Approximately_9120_patches~2014 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=b473b6c241cf54b5edc1e21553250739476c0cf9;p=ghc-hetmet.git [project @ 2001-05-03 09:32:48 by simonpj] ------------------------------------------------ Dramatically improve the error messages arising from failed unifications triggered by 'improvement' ------------------------------------------------ A bit more plumbing in FunDeps, and consequential wibbles elsewhere Changes this: Couldn't match `Int' against `[(String, Int)]' Expected type: Int Inferred type: [(String, Int)] to this: Foo.hs:8: Couldn't match `Int' against `[(String, Int)]' Expected type: Int Inferred type: [(String, Int)] When using functional dependencies to combine ?env :: Int, arising from a type signature at Foo.hs:7 ?env :: [(String, Int)], arising from use of implicit parameter `?env' at Foo.hs:8 When generalising the types for ident --- diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 1192ef3..a0f7087 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -229,6 +229,8 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec in -- GENERALISE + tcAddSrcLoc (minimum (map getSrcLoc binder_names)) $ + tcAddErrCtxt (genCtxt binder_names) $ generalise binder_names mbind tau_tvs lie_req tc_ty_sigs `thenTc` \ (tc_tyvars_to_gen, lie_free, dict_binds, dict_ids) -> @@ -482,8 +484,9 @@ generalise binder_names mbind tau_tvs lie_req sigs -- We unify them because, with polymorphic recursion, their types -- might not otherwise be related. This is a rather subtle issue. -- ToDo: amplify -checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ _ : other_sigs) - = mapTc_ check_one other_sigs `thenTc_` +checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ src_loc : other_sigs) + = tcAddSrcLoc src_loc $ + mapTc_ check_one other_sigs `thenTc_` if null theta1 then returnTc ([], []) -- Non-overloaded type signatures else @@ -501,8 +504,7 @@ checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ _ : other_sigs) sig_meths = concat [insts | TySigInfo _ _ _ _ _ _ insts _ <- sigs] check_one sig@(TySigInfo _ id _ theta _ _ _ src_loc) - = tcAddSrcLoc src_loc $ - tcAddErrCtxt (sigContextsCtxt id1 id) $ + = tcAddErrCtxt (sigContextsCtxt id1 id) $ checkTc (length theta == n_sig1_theta) sigContextsErr `thenTc_` unifyTauTyLists sig1_dict_tys (map mkPredTy theta) @@ -824,6 +826,9 @@ restrictedBindCtxtErr binder_names 4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names, ptext SLIT("that falls under the monomorphism restriction")]) +genCtxt binder_names + = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names + -- Used in error messages pprBinders bndrs = pprWithCommas ppr bndrs \end{code} diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 5a4867a..85762b0 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -51,7 +51,7 @@ import Type ( Type, ThetaType, PredType, mkClassPred, mkTyVarTy, getTyVar, isTyVarClassPred, splitSigmaTy, tyVarsOfPred, getClassPredTys_maybe, isClassPred, isIPPred, - inheritablePred + inheritablePred, predHasFDs ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) import TysWiredIn ( unitTy ) @@ -968,7 +968,12 @@ reduceContext doc try_me givens wanteds tcImprove avails = tcGetInstEnv `thenTc` \ inst_env -> let - preds = predsOfInsts (keysFM avails) + preds = [ (pred, pp_loc) + | inst <- keysFM avails, + let pp_loc = pprInstLoc (instLoc inst), + pred <- predsOfInst inst, + predHasFDs pred + ] -- Avails has all the superclasses etc (good) -- It also has all the intermediates of the deduction (good) -- It does not have duplicates (good) @@ -983,10 +988,14 @@ tcImprove avails mapTc_ unify eqns `thenTc_` returnTc False where - unify (qtvs, t1, t2) = tcInstTyVars (varSetElems qtvs) `thenNF_Tc` \ (_, _, tenv) -> - unifyTauTy (substTy tenv t1) (substTy tenv t2) - ppr_eqn (qtvs, t1, t2) = ptext SLIT("forall") <+> braces (pprWithCommas ppr (varSetElems qtvs)) <+> - ppr t1 <+> equals <+> ppr t2 + unify ((qtvs, t1, t2), doc) + = tcAddErrCtxt doc $ + tcInstTyVars (varSetElems qtvs) `thenNF_Tc` \ (_, _, tenv) -> + 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] \end{code} The main context-reduction function is @reduce@. Here's its game plan. diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index 3ecb8f8..2b7ce52 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -10,7 +10,8 @@ module Class ( mkClass, classTyVars, classArity, classKey, className, classSelIds, classTyCon, - classBigSig, classExtraBigSig, classTvsFds, classSCTheta + classBigSig, classExtraBigSig, classTvsFds, classSCTheta, + classHasFDs ) where #include "HsVersions.h" @@ -113,6 +114,9 @@ classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, classSCTheta = sc_theta, classSCSels = sc_sels, classOpStuff = op_stuff}) = (tyvars, fundeps, sc_theta, sc_sels, op_stuff) + +classHasFDs :: Class -> Bool +classHasFDs (Class {classFunDeps = fundeps}) = not (null fundeps) \end{code} diff --git a/ghc/compiler/types/FunDeps.lhs b/ghc/compiler/types/FunDeps.lhs index 40e154f..efbd8d6 100644 --- a/ghc/compiler/types/FunDeps.lhs +++ b/ghc/compiler/types/FunDeps.lhs @@ -12,14 +12,15 @@ module FunDeps ( #include "HsVersions.h" -import Var ( TyVar ) +import Name ( getSrcLoc ) +import Var ( Id, TyVar ) import Class ( Class, FunDep, classTvsFds ) -import Type ( Type, ThetaType, PredType(..), predTyUnique, tyVarsOfTypes, tyVarsOfPred ) +import Type ( Type, ThetaType, PredType(..), predTyUnique, mkClassPred, tyVarsOfTypes, tyVarsOfPred ) import Subst ( mkSubst, emptyInScopeSet, substTy ) import Unify ( unifyTyListsX, unifyExtendTysX ) -import Outputable ( Outputable, SDoc, interppSP, ptext, empty, hsep, punctuate, comma ) import VarSet import VarEnv +import Outputable import List ( tails ) import Maybes ( maybeToBool ) import ListSetOps ( equivClassesByUniq ) @@ -143,7 +144,7 @@ grow preds fixed_tvs \begin{code} ---------- -type Equation = (TyVarSet, Type,Type) -- These two types should be equal, for some +type Equation = (TyVarSet, Type, Type) -- These two types should be equal, for some -- substitution of the tyvars in the tyvar set -- For example, ({a,b}, (a,Int,b), (Int,z,Bool)) -- We unify z with Int, but since a and b are quantified we do nothing to them @@ -151,14 +152,16 @@ type Equation = (TyVarSet, Type,Type) -- These two types should be equal, for so -- to fresh type variables, and then calling the standard unifier. -- -- INVARIANT: they aren't already equal + -- ---------- -improve :: InstEnv a -- Gives instances for given class - -> [PredType] -- Current constraints - -> [Equation] -- Derived equalities that must also hold +improve :: InstEnv Id -- Gives instances for given class + -> [(PredType,SDoc)] -- Current constraints; doc says where they come from + -> [(Equation,SDoc)] -- Derived equalities that must also hold -- (NB the above INVARIANT for type Equation) + -- The SDoc explains why the equation holds (for error messages) type InstEnv a = Class -> [(TyVarSet, [Type], a)] -- This is a bit clumsy, because InstEnv is really @@ -199,18 +202,18 @@ NOTA BENE: \begin{code} improve inst_env preds - = [ eqn | group <- equivClassesByUniq predTyUnique preds, + = [ eqn | group <- equivClassesByUniq (predTyUnique . fst) preds, eqn <- checkGroup inst_env group ] ---------- -checkGroup :: InstEnv a -> [PredType] -> [Equation] +checkGroup :: InstEnv Id -> [(PredType,SDoc)] -> [(Equation, SDoc)] -- The preds are all for the same class or implicit param -checkGroup inst_env (IParam _ ty : ips) +checkGroup inst_env (p1@(IParam _ ty, _) : ips) = -- For implicit parameters, all the types must match - [(emptyVarSet, ty, ty') | IParam _ ty' <- ips, ty /= ty'] + [((emptyVarSet, ty, ty'), mkEqnMsg p1 p2) | p2@(IParam _ ty', _) <- ips, ty /= ty'] -checkGroup inst_env clss@(ClassP cls tys : _) +checkGroup inst_env clss@((ClassP cls _, _) : _) = -- For classes life is more complicated -- Suppose the class is like -- classs C as | (l1 -> r1), (l2 -> r2), ... where ... @@ -232,23 +235,31 @@ checkGroup inst_env clss@(ClassP cls tys : _) -- NOTE that we iterate over the fds first; they are typically -- empty, which aborts the rest of the loop. - pairwise_eqns :: [Equation] + pairwise_eqns :: [(Equation,SDoc)] pairwise_eqns -- This group comes from pairwise comparison - = [ eqn | fd <- cls_fds, - ClassP _ tys1 : rest <- tails clss, - ClassP _ tys2 <- rest, - eqn <- checkClsFD emptyVarSet fd cls_tvs tys1 tys2 + = [ (eqn, mkEqnMsg p1 p2) + | fd <- cls_fds, + p1@(ClassP _ tys1, _) : rest <- tails clss, + p2@(ClassP _ tys2, _) <- rest, + eqn <- checkClsFD emptyVarSet fd cls_tvs tys1 tys2 ] - instance_eqns :: [Equation] + instance_eqns :: [(Equation,SDoc)] instance_eqns -- This group comes from comparing with instance decls - = [ eqn | fd <- cls_fds, - (qtvs, tys1, _) <- cls_inst_env, - ClassP _ tys2 <- clss, - eqn <- checkClsFD qtvs fd cls_tvs tys1 tys2 + = [ (eqn, mkEqnMsg p1 p2) + | fd <- cls_fds, + (qtvs, tys1, dfun_id) <- cls_inst_env, + let p1 = (mkClassPred cls tys1, + ptext SLIT("arising from the instance declaration at") <+> ppr (getSrcLoc dfun_id)), + p2@(ClassP _ tys2, _) <- clss, + eqn <- checkClsFD qtvs fd cls_tvs tys1 tys2 ] - +mkEqnMsg (pred1,from1) (pred2,from2) + = vcat [ptext SLIT("When using functional dependencies to combine"), + nest 2 (sep [ppr pred1 <> comma, nest 2 from1]), + nest 2 (sep [ppr pred2 <> comma, nest 2 from2])] + ---------- checkClsFD :: TyVarSet -- The quantified type variables, which -- can be instantiated to make the types match diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index ea24c92..2bf99f5 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -51,7 +51,7 @@ module Type ( -- Predicates and the like PredType(..), getClassPredTys_maybe, getClassPredTys, - isPredTy, isClassPred, isTyVarClassPred, + isPredTy, isClassPred, isTyVarClassPred, predHasFDs, mkDictTy, mkPredTy, mkPredTys, splitPredTy_maybe, predTyUnique, splitDictTy, splitDictTy_maybe, isDictTy, predRepTy, splitDFunTy, mkClassPred, predMentionsIPs, inheritablePred, isIPPred, mkPredName, @@ -102,7 +102,7 @@ import VarSet import OccName ( mkDictOcc ) import Name ( Name, NamedThing(..), OccName, mkLocalName, tidyOccName ) import NameSet -import Class ( classTyCon, Class ) +import Class ( classTyCon, classHasFDs, Class ) import TyCon ( TyCon, isUnboxedTupleTyCon, isUnLiftedTyCon, isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep, @@ -714,6 +714,12 @@ predMentionsIPs :: PredType -> NameSet -> Bool predMentionsIPs (IParam n _) ns = n `elemNameSet` ns predMentionsIPs other ns = False +predHasFDs :: PredType -> Bool +-- True if the predicate has functional depenencies; +-- I.e. should participate in improvement +predHasFDs (IParam _ _) = True +predHasFDs (ClassP cls _) = classHasFDs cls + mkDictTy :: Class -> [Type] -> Type mkDictTy clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) ) mkPredTy (ClassP clas tys)