From 8ddfc3c10a9d08e11812b5564da291d7024d5fc8 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 27 Mar 2000 13:23:50 +0000 Subject: [PATCH 1/1] [project @ 2000-03-27 13:23:49 by simonpj] Improve the error messages given when a definition isn't polymorphic enough. In paticular, for this program: let v = runST (newSTRef True) in runST (readSTRef v) we get the message Inferred type is less polymorphic than expected Quantified type variable `s' escapes It is reachable from the type variable(s) `a' which are free in the signature Signature type: forall s. ST s a Type to generalise: ST s (STRef s Bool) When checking an expression type signature In the first argument of `runST', namely `(newSTRef True)' In the right-hand side of a pattern binding: runST (newSTRef True) --- ghc/compiler/typecheck/TcBinds.lhs | 11 ++-- ghc/compiler/typecheck/TcClassDcl.lhs | 9 ++- ghc/compiler/typecheck/TcExpr.lhs | 10 ++-- ghc/compiler/typecheck/TcMatches.lhs | 6 +- ghc/compiler/typecheck/TcMonoType.lhs | 103 ++++++++++++++++++++++----------- ghc/compiler/typecheck/TcRules.lhs | 2 +- ghc/compiler/typecheck/TcSimplify.lhs | 3 +- 7 files changed, 87 insertions(+), 57 deletions(-) diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 69bde88..cd132e9 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -44,7 +44,7 @@ import TcUnify ( unifyTauTy, unifyTauTyLists ) import PrelInfo ( main_NAME, ioTyCon_NAME ) -import Id ( Id, mkVanillaId, setInlinePragma ) +import Id ( Id, mkVanillaId, setInlinePragma, idFreeTyVars ) import Var ( idType, idName ) import IdInfo ( setInlinePragInfo, InlinePragInfo(..) ) import Name ( Name, getName, getOccName, getSrcLoc ) @@ -767,10 +767,10 @@ checkSigMatch top_lvl binder_names mono_ids sigs -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK -- Doesn't affect substitution - check_one_sig (TySigInfo _ id sig_tyvars _ sig_tau _ _ src_loc) + check_one_sig (TySigInfo _ id sig_tyvars sig_theta sig_tau _ _ src_loc) = tcAddSrcLoc src_loc $ - tcAddErrCtxtM (sigCtxt (sig_msg id) (idType id)) $ - checkSigTyVars sig_tyvars + tcAddErrCtxtM (sigCtxt (sig_msg id) sig_tyvars sig_theta sig_tau) $ + checkSigTyVars sig_tyvars (idFreeTyVars id) -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE @@ -797,8 +797,7 @@ checkSigMatch top_lvl binder_names mono_ids sigs mk_dict_tys theta = map mkPredTy theta - sig_msg id tidy_ty = sep [ptext SLIT("When checking the type signature"), - nest 4 (ppr id <+> dcolon <+> ppr tidy_ty)] + sig_msg id = ptext SLIT("When checking the type signature for") <+> ppr id -- Search for Main.main in the binder_names, return corresponding mono_id find_main NotTopLevel binder_names mono_ids = Nothing diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index be02521..9c36c70 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -59,7 +59,7 @@ import Type ( Type, ThetaType, ClassContext, ) import PprType ( {- instance Outputable Type -} ) import Var ( tyVarKind, TyVar ) -import VarSet ( mkVarSet ) +import VarSet ( mkVarSet, emptyVarSet ) import TyCon ( mkAlgTyCon ) import Unique ( Unique, Uniquable(..) ) import Util @@ -599,15 +599,14 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta -- Now check that the instance type variables -- (or, in the case of a class decl, the class tyvars) -- have not been unified with anything in the environment - tcAddErrCtxtM (sigCtxt sig_msg (mkSigmaTy inst_tyvars inst_theta (idType meth_id))) $ - checkSigTyVars inst_tyvars `thenTc_` + tcAddErrCtxtM (sigCtxt sig_msg inst_tyvars inst_theta (idType meth_id)) $ + checkSigTyVars inst_tyvars emptyVarSet `thenTc_` returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2, insts `plusLIE` prag_lie', meth) where - sig_msg ty = sep [ptext SLIT("When checking the expected type for"), - nest 4 (ppr sel_name <+> dcolon <+> ppr ty)] + sig_msg = ptext SLIT("When checking the expected type for class method") <+> ppr sel_name sel_name = idName sel_id diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index f622d1c..7716100 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -131,6 +131,7 @@ tcPolyExpr arg expected_arg_ty tcInstTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) -> let (sig_theta, sig_tau) = splitRhoTy sig_rho + free_tyvars = tyVarsOfType expected_arg_ty in -- Type-check the arg and unify with expected type tcMonoExpr arg sig_tau `thenTc` \ (arg', lie_arg) -> @@ -146,10 +147,10 @@ tcPolyExpr arg expected_arg_ty -- Conclusion: include the free vars of the expected arg type in the -- list of "free vars" for the signature check. - tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) $ - tcAddErrCtxtM (sigCtxt sig_msg expected_arg_ty) $ + tcExtendGlobalTyVars free_tyvars $ + tcAddErrCtxtM (sigCtxt sig_msg sig_tyvars sig_theta sig_tau) $ - checkSigTyVars sig_tyvars `thenTc` \ zonked_sig_tyvars -> + checkSigTyVars sig_tyvars free_tyvars `thenTc` \ zonked_sig_tyvars -> newDicts SignatureOrigin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) -> -- ToDo: better origin @@ -170,8 +171,7 @@ tcPolyExpr arg expected_arg_ty returnTc ( generalised_arg, free_insts, arg', sig_tau, lie_arg ) where - sig_msg ty = sep [ptext SLIT("In an expression with expected type:"), - nest 4 (ppr ty)] + sig_msg = ptext SLIT("When checking an expression type signature") \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index e213632..0fb4aba 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -150,7 +150,7 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt -- Check that the scoped type variables from the patterns -- have not been constrained tcAddErrCtxtM (sigPatCtxt sig_tyvars pat_ids) ( - checkSigTyVars sig_tyvars + checkSigTyVars sig_tyvars emptyVarSet ) `thenTc_` -- *Now* we're free to unify with expected_ty @@ -191,7 +191,7 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt -- STEP 5: Check for existentially bound type variables tcExtendGlobalTyVars (tyVarsOfType rhs_ty) ( tcAddErrCtxtM (sigPatCtxt ex_tv_list pat_ids) $ - checkSigTyVars ex_tv_list `thenTc` \ zonked_ex_tvs -> + checkSigTyVars ex_tv_list emptyVarSet `thenTc` \ zonked_ex_tvs -> tcSimplifyAndCheck (text ("the existential context of a data constructor")) (mkVarSet zonked_ex_tvs) @@ -334,7 +334,7 @@ tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty tcExtendGlobalTyVars (tyVarsOfType (m elt_ty)) $ tcAddErrCtxtM (sigPatCtxt pat_tv_list pat_ids) $ - checkSigTyVars pat_tv_list `thenTc` \ zonked_pat_tvs -> + checkSigTyVars pat_tv_list emptyVarSet `thenTc` \ zonked_pat_tvs -> tcSimplifyAndCheck (text ("the existential context of a data constructor")) diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index af02410..0943cfb 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -26,7 +26,7 @@ import TcEnv ( tcExtendTyVarEnv, tcLookupTy, tcGetValueEnv, tcGetInScopeTyVars, import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType, typeToTcType, kindToTcKind, newKindVar, tcInstSigVar, - zonkTcKindToKind, zonkTcTypeToType, zonkTcTyVars, zonkTcType + zonkTcKindToKind, zonkTcTypeToType, zonkTcTyVars, zonkTcType, zonkTcTyVar ) import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr ) import TcUnify ( unifyKind, unifyKinds, unifyTypeKind ) @@ -34,13 +34,13 @@ import Type ( Type, PredType(..), ThetaType, UsageAnn(..), mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, mkUsgTy, mkUsForAllTy, zipFunTys, hoistForAllTys, mkSigmaTy, mkDictTy, mkPredTy, mkTyConApp, - mkAppTys, splitForAllTys, splitRhoTy, + mkAppTys, splitForAllTys, splitRhoTy, mkRhoTy, boxedTypeKind, unboxedTypeKind, tyVarsOfType, mkArrowKinds, getTyVar_maybe, getTyVar, - tidyOpenType, tidyOpenTypes, tidyTyVar, + tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars, tyVarsOfType, tyVarsOfTypes ) -import PprType ( pprConstraint ) +import PprType ( pprConstraint, pprType ) import Subst ( mkTopTyVarSubst, substTy ) import Id ( mkVanillaId, idName, idType, idFreeTyVars ) import Var ( TyVar, mkTyVar, mkNamedUVar, varName ) @@ -55,7 +55,7 @@ import TysWiredIn ( mkListTy, mkTupleTy, mkUnboxedTupleTy ) import UniqFM ( elemUFM, foldUFM ) import SrcLoc ( SrcLoc ) import Unique ( Unique, Uniquable(..) ) -import Util ( zipWithEqual, zipLazy, mapAccumL ) +import Util ( mapAccumL, isSingleton ) import Outputable \end{code} @@ -532,12 +532,15 @@ So we revert to ordinary type variables for signatures, and try to give a helpful message in checkSigTyVars. \begin{code} -checkSigTyVars :: [TcTyVar] -- The original signature type variables +checkSigTyVars :: [TcTyVar] -- Universally-quantified type variables in the signature + -> TcTyVarSet -- Tyvars that are free in the type signature + -- These should *already* be in the global-var set, and are + -- used here only to improve the error message -> TcM s [TcTyVar] -- Zonked signature type variables -checkSigTyVars [] = returnTc [] +checkSigTyVars [] free = returnTc [] -checkSigTyVars sig_tyvars +checkSigTyVars sig_tyvars free_tyvars = zonkTcTyVars sig_tyvars `thenNF_Tc` \ sig_tys -> tcGetGlobalTyVars `thenNF_Tc` \ globals -> @@ -600,9 +603,10 @@ checkSigTyVars sig_tyvars if tv `elemVarSet` globals -- Error (c)! Type variable escapes -- The least comprehensible, so put it last - then tcGetValueEnv `thenNF_Tc` \ ve -> - find_globals tv env (valueEnvIds ve) `thenNF_Tc` \ (env1, globs) -> - returnNF_Tc (env1, acc, escape_msg sig_tyvar tv globs : msgs) + then tcGetValueEnv `thenNF_Tc` \ ve -> + find_globals tv env [] (valueEnvIds ve) `thenNF_Tc` \ (env1, globs) -> + find_frees tv env1 [] (varSetElems free_tyvars) `thenNF_Tc` \ (env2, frees) -> + returnNF_Tc (env2, acc, escape_msg sig_tyvar tv globs frees : msgs) else -- All OK returnNF_Tc (env, extendVarEnv acc tv sig_tyvar, msgs) @@ -612,37 +616,57 @@ checkSigTyVars sig_tyvars -- whose types mention the offending type variable. It has to be -- careful to zonk the Id's type first, so it has to be in the monad. -- We must be careful to pass it a zonked type variable, too. -find_globals tv tidy_env ids - | null ids - = returnNF_Tc (tidy_env, []) +find_globals tv tidy_env acc [] + = returnNF_Tc (tidy_env, acc) -find_globals tv tidy_env (id:ids) +find_globals tv tidy_env acc (id:ids) | not (isLocallyDefined id) || isEmptyVarSet (idFreeTyVars id) - = find_globals tv tidy_env ids + = find_globals tv tidy_env acc ids | otherwise = zonkTcType (idType id) `thenNF_Tc` \ id_ty -> if tv `elemVarSet` tyVarsOfType id_ty then let (tidy_env', id_ty') = tidyOpenType tidy_env id_ty + acc' = (idName id, id_ty') : acc in - find_globals tv tidy_env' ids `thenNF_Tc` \ (tidy_env'', globs) -> - returnNF_Tc (tidy_env'', (idName id, id_ty') : globs) + find_globals tv tidy_env' acc' ids else - find_globals tv tidy_env ids - -escape_msg sig_tv tv globs - = vcat [mk_msg sig_tv <+> ptext SLIT("escapes"), - pp_escape, - ptext SLIT("The following variables in the environment mention") <+> quotes (ppr tv), - nest 4 (vcat_first 10 [ppr name <+> dcolon <+> ppr ty | (name,ty) <- globs]) - ] + find_globals tv tidy_env acc ids + +find_frees tv tidy_env acc [] + = returnNF_Tc (tidy_env, acc) +find_frees tv tidy_env acc (ftv:ftvs) + = zonkTcTyVar ftv `thenNF_Tc` \ ty -> + if tv `elemVarSet` tyVarsOfType ty then + let + (tidy_env', ftv') = tidyTyVar tidy_env ftv + in + find_frees tv tidy_env' (ftv':acc) ftvs + else + find_frees tv tidy_env acc ftvs + + +escape_msg sig_tv tv globs frees + = mk_msg sig_tv <+> ptext SLIT("escapes") $$ + if not (null globs) then + vcat [pp_it <+> ptext SLIT("is mentioned in the environment"), + ptext SLIT("The following variables in the environment mention") <+> quotes (ppr tv), + nest 2 (vcat_first 10 [ppr name <+> dcolon <+> ppr ty | (name,ty) <- globs]) + ] + else if not (null frees) then + vcat [ptext SLIT("It is reachable from the type variable(s)") <+> pprQuotedList frees, + nest 2 (ptext SLIT("which") <+> is_are <+> ptext SLIT("free in the signature")) + ] + else + empty -- Sigh. It's really hard to give a good error message + -- all the time. One bad case is an existential pattern match where - pp_escape | sig_tv /= tv = ptext SLIT("It unifies with") <+> - quotes (ppr tv) <> comma <+> - ptext SLIT("which is mentioned in the environment") - | otherwise = ptext SLIT("It is mentioned in the environment") + is_are | isSingleton frees = ptext SLIT("is") + | otherwise = ptext SLIT("are") + pp_it | sig_tv /= tv = ptext SLIT("It unifies with") <+> quotes (ppr tv) <> comma <+> ptext SLIT("which") + | otherwise = ptext SLIT("It") vcat_first :: Int -> [SDoc] -> SDoc vcat_first n [] = empty @@ -656,13 +680,22 @@ mk_msg tv = ptext SLIT("Quantified type variable") <+> quotes (ppr tv) These two context are used with checkSigTyVars \begin{code} -sigCtxt :: (Type -> Message) -> Type +sigCtxt :: Message -> [TcTyVar] -> TcThetaType -> TcTauType -> TidyEnv -> NF_TcM s (TidyEnv, Message) -sigCtxt mk_msg sig_ty tidy_env - = let - (env1, tidy_sig_ty) = tidyOpenType tidy_env sig_ty +sigCtxt when sig_tyvars sig_theta sig_tau tidy_env + = zonkTcType sig_tau `thenNF_Tc` \ actual_tau -> + let + (env1, tidy_sig_tyvars) = tidyTyVars tidy_env sig_tyvars + (env2, tidy_sig_rho) = tidyOpenType env1 (mkRhoTy sig_theta sig_tau) + (env3, tidy_actual_tau) = tidyOpenType env1 actual_tau + forall | null sig_tyvars = empty + | otherwise = ptext SLIT("forall") <+> hsep (map ppr tidy_sig_tyvars) <> dot + msg = vcat [ptext SLIT("Signature type: ") <+> forall <+> pprType tidy_sig_rho, + ptext SLIT("Type to generalise:") <+> pprType tidy_actual_tau, + when + ] in - returnNF_Tc (env1, mk_msg tidy_sig_ty) + returnNF_Tc (env3, msg) sigPatCtxt bound_tvs bound_ids tidy_env = returnNF_Tc (env1, diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index 1d9edb8..262ba38 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -67,7 +67,7 @@ tcRule (RuleDecl name sig_tvs vars lhs rhs src_loc) -- Check that LHS has no overloading at all tcSimplifyToDicts lhs_lie `thenTc` \ (lhs_dicts, lhs_binds) -> - checkSigTyVars sig_tyvars `thenTc_` + checkSigTyVars sig_tyvars emptyVarSet `thenTc_` -- Gather the template variables and tyvars let diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index b05225f..f1467ba 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -1223,8 +1223,7 @@ addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts addAmbigErr ambig_tv_fn dict = addInstErrTcM (instLoc dict) (tidy_env, - sep [text "Ambiguous type variable(s)" <+> - hsep (punctuate comma (map (quotes . ppr) ambig_tvs)), + sep [text "Ambiguous type variable(s)" <+> pprQuotedList ambig_tvs, nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict))]) where ambig_tvs = varSetElems (ambig_tv_fn tidy_dict) -- 1.7.10.4