Commit 8ddfc3c1 authored by simonpj's avatar simonpj
Browse files

[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)
parent 36908417
......@@ -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
......
......@@ -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
......
......@@ -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}
%************************************************************************
......
......@@ -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"))
......
......@@ -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,
......
......@@ -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
......
......@@ -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)
......
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