+ (b) Still all distinct
+ eg matching signature [(a,b)] against inferred type [(p,p)]
+ [then a and b will be unified together]
+
+ (c) Not mentioned in the environment
+ eg the signature for f in this:
+
+ g x = ... where
+ f :: a->[a]
+ f y = [x,y]
+
+ Here, f is forced to be monorphic by the free occurence of x.
+
+ (d) Not (unified with another type variable that is) in scope.
+ eg f x :: (r->r) = (\y->y) :: forall a. a->r
+ when checking the expression type signature, we find that
+ even though there is nothing in scope whose type mentions r,
+ nevertheless the type signature for the expression isn't right.
+
+ Another example is in a class or instance declaration:
+ class C a where
+ op :: forall b. a -> b
+ op x = x
+ Here, b gets unified with a
+
+Before doing this, the substitution is applied to the signature type variable.
+
+We used to have the notion of a "DontBind" type variable, which would
+only be bound to itself or nothing. Then points (a) and (b) were
+self-checking. But it gave rise to bogus consequential error messages.
+For example:
+
+ f = (*) -- Monomorphic
+
+ g :: Num a => a -> a
+ g x = f x x
+
+Here, we get a complaint when checking the type signature for g,
+that g isn't polymorphic enough; but then we get another one when
+dealing with the (Num x) context arising from f's definition;
+we try to unify x with Int (to default it), but find that x has already
+been unified with the DontBind variable "a" from g's signature.
+This is really a problem with side-effecting unification; we'd like to
+undo g's effects when its type signature fails, but unification is done
+by side effect, so we can't (easily).
+
+So we revert to ordinary type variables for signatures, and try to
+give a helpful message in checkSigTyVars.
+
+\begin{code}
+checkSigTyVars :: [TcTyVar] -- Universally-quantified type variables in the signature
+ -> TcTyVarSet -- Tyvars that are free in the type signature
+ -- Not necessarily zonked
+ -- These should *already* be in the free-in-env set,
+ -- and are used here only to improve the error message
+ -> TcM [TcTyVar] -- Zonked signature type variables
+
+checkSigTyVars [] free = returnTc []
+checkSigTyVars sig_tyvars free_tyvars
+ = zonkTcTyVars sig_tyvars `thenNF_Tc` \ sig_tys ->
+ tcGetGlobalTyVars `thenNF_Tc` \ globals ->
+
+ checkTcM (allDistinctTyVars sig_tys globals)
+ (complain sig_tys globals) `thenTc_`
+
+ returnTc (map (tcGetTyVar "checkSigTyVars") sig_tys)
+
+ where
+ complain sig_tys globals
+ = -- For the in-scope ones, zonk them and construct a map
+ -- from the zonked tyvar to the in-scope one
+ -- If any of the in-scope tyvars zonk to a type, then ignore them;
+ -- that'll be caught later when we back up to their type sig
+ tcGetEnv `thenNF_Tc` \ env ->
+ let
+ in_scope_tvs = tcEnvTyVars env
+ in
+ zonkTcTyVars in_scope_tvs `thenNF_Tc` \ in_scope_tys ->
+ let
+ in_scope_assoc = [ (zonked_tv, in_scope_tv)
+ | (z_ty, in_scope_tv) <- in_scope_tys `zip` in_scope_tvs,
+ Just zonked_tv <- [tcGetTyVar_maybe z_ty]
+ ]
+ in_scope_env = mkVarEnv in_scope_assoc
+ in
+
+ -- "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) = tidyOpenTyVars emptyTidyEnv sig_tyvars
+ (env2, tidy_tys) = tidyOpenTypes env1 sig_tys
+
+ main_msg = ptext SLIT("Inferred type is less polymorphic than expected")
+
+ check (tidy_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 tcGetTyVar_maybe ty of {
+ Nothing -> -- Error (a)!
+ returnNF_Tc (tidy_env, acc, unify_msg sig_tyvar (quotes (ppr ty)) : msgs) ;
+
+ Just tv ->
+
+ case lookupVarEnv acc tv of {
+ Just sig_tyvar' -> -- Error (b) or (d)!
+ returnNF_Tc (tidy_env, acc, unify_msg sig_tyvar thing : msgs)
+ where
+ thing = ptext SLIT("another quantified type variable") <+> quotes (ppr sig_tyvar')
+
+ ; Nothing ->
+
+ if tv `elemVarSet` globals -- Error (c)! Type variable escapes
+ -- The least comprehensible, so put it last
+ -- Game plan:
+ -- a) get the local TcIds from the environment,
+ -- and pass them to find_globals (they might have tv free)
+ -- b) similarly, find any free_tyvars that mention tv
+ then tcGetEnv `thenNF_Tc` \ ve ->
+ find_globals tv tidy_env [] (tcEnvTcIds ve) `thenNF_Tc` \ (tidy_env1, globs) ->
+ find_frees tv tidy_env1 [] (varSetElems free_tyvars) `thenNF_Tc` \ (tidy_env2, frees) ->
+ returnNF_Tc (tidy_env2, acc, escape_msg sig_tyvar tv globs frees : msgs)
+
+ else -- All OK
+ returnNF_Tc (tidy_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 :: Var
+ -> TidyEnv
+ -> [(Name,Type)]
+ -> [Id]
+ -> NF_TcM (TidyEnv,[(Name,Type)])
+
+find_globals tv tidy_env acc []
+ = returnNF_Tc (tidy_env, acc)
+
+find_globals tv tidy_env acc (id:ids)
+ | isEmptyVarSet (idFreeTyVars id)
+ = 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' acc' ids
+ else
+ 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