+
+ -- "check" checks each sig tyvar in turn
+ foldlNF_Tc check
+ (env2, in_scope_env, [])
+ (tidy_tvs `zip` tidy_tys) `thenNF_Tc` \ (env3, _, msgs) ->
+
+ failWithTcM (env3, main_msg $$ nest 4 (vcat msgs))
+ where
+ (env1, tidy_tvs) = mapAccumL tidyTyVar emptyTidyEnv sig_tyvars
+ (env2, tidy_tys) = tidyOpenTypes env1 sig_tys
+
+ main_msg = ptext SLIT("Inferred type is less polymorphic than expected")
+
+ check (env, acc, msgs) (sig_tyvar,ty)
+ -- sig_tyvar is from the signature;
+ -- ty is what you get if you zonk sig_tyvar and then tidy it
+ --
+ -- acc maps a zonked type variable back to a signature type variable
+ = case getTyVar_maybe ty of {
+ Nothing -> -- Error (a)!
+ returnNF_Tc (env, acc, unify_msg sig_tyvar (ppr ty) : msgs) ;
+
+ Just tv ->
+
+ case lookupVarEnv acc tv of {
+ Just sig_tyvar' -> -- Error (b) or (d)!
+ returnNF_Tc (env, acc, unify_msg sig_tyvar (ppr sig_tyvar') : msgs) ;
+
+ Nothing ->
+
+ 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 (eltsUFM ve) `thenNF_Tc` \ (env1, globs) ->
+ returnNF_Tc (env1, acc, escape_msg sig_tyvar tv globs : msgs)
+
+ else -- All OK
+ returnNF_Tc (env, extendVarEnv acc tv sig_tyvar, msgs)
+ }}
+
+-- find_globals looks at the value environment and finds values
+-- 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 (id:ids)
+ | not (isLocallyDefined id) ||
+ isEmptyVarSet (idFreeTyVars id)
+ = find_globals tv tidy_env 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
+ in
+ find_globals tv tidy_env' ids `thenNF_Tc` \ (tidy_env'', globs) ->
+ returnNF_Tc (tidy_env'', (idName id, id_ty') : globs)
+ 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])
+ ]
+ 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")
+
+ vcat_first n [] = empty
+ vcat_first 0 (x:xs) = text "...others omitted..."
+ vcat_first n (x:xs) = x $$ vcat_first (n-1) xs
+
+unify_msg tv thing = mk_msg tv <+> ptext SLIT("is unified with") <+> quotes thing
+mk_msg tv = ptext SLIT("Quantified type variable") <+> quotes (ppr tv)