2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcMonoType]{Typechecking user-specified @MonoTypes@}
7 module TcMonoType ( tcHsType, tcHsTypeKind, tcHsTopType, tcHsTopBoxedType, tcHsTopTypeKind,
8 tcContext, tcHsTyVar, kcHsTyVar,
9 tcExtendTyVarScope, tcExtendTopTyVarScope,
10 TcSigInfo(..), tcTySig, mkTcSig, maybeSig,
11 checkSigTyVars, sigCtxt, sigPatCtxt
14 #include "HsVersions.h"
16 import HsSyn ( HsType(..), HsTyVar(..), MonoUsageAnn(..),
17 Sig(..), HsPred(..), pprHsPred, pprParendHsType )
18 import RnHsSyn ( RenamedHsType, RenamedContext, RenamedSig )
19 import TcHsSyn ( TcId )
22 import TcEnv ( tcExtendTyVarEnv, tcLookupTy, tcGetValueEnv, tcGetInScopeTyVars,
23 tcExtendUVarEnv, tcLookupUVar,
24 tcGetGlobalTyVars, valueEnvIds, TcTyThing(..)
26 import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType,
27 typeToTcType, kindToTcKind,
28 newKindVar, tcInstSigVar,
29 zonkTcKindToKind, zonkTcTypeToType, zonkTcTyVars, zonkTcType
31 import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr )
32 import TcUnify ( unifyKind, unifyKinds, unifyTypeKind )
33 import Type ( Type, PredType(..), ThetaType, UsageAnn(..),
34 mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, mkUsgTy,
35 mkUsForAllTy, zipFunTys,
36 mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys, splitForAllTys, splitRhoTy,
37 boxedTypeKind, unboxedTypeKind, tyVarsOfType,
38 mkArrowKinds, getTyVar_maybe, getTyVar,
39 tidyOpenType, tidyOpenTypes, tidyTyVar,
40 tyVarsOfType, tyVarsOfTypes
42 import PprType ( pprConstraint )
43 import Subst ( mkTopTyVarSubst, substTy )
44 import Id ( mkVanillaId, idName, idType, idFreeTyVars )
45 import Var ( TyVar, mkTyVar, mkNamedUVar, varName )
48 import Bag ( bagToList )
49 import ErrUtils ( Message )
50 import PrelInfo ( cCallishClassKeys )
51 import TyCon ( TyCon )
52 import Name ( Name, OccName, isLocallyDefined )
53 import TysWiredIn ( mkListTy, mkTupleTy, mkUnboxedTupleTy )
54 import UniqFM ( elemUFM, foldUFM )
55 import SrcLoc ( SrcLoc )
56 import Unique ( Unique, Uniquable(..) )
57 import Util ( zipWithEqual, zipLazy, mapAccumL )
62 %************************************************************************
64 \subsection{Checking types}
66 %************************************************************************
68 tcHsType and tcHsTypeKind
69 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
71 tcHsType checks that the type really is of kind Type!
74 tcHsType :: RenamedHsType -> TcM s TcType
76 = -- tcAddErrCtxt (typeCtxt ty) $
79 tcHsTypeKind :: RenamedHsType -> TcM s (TcKind, TcType)
81 = -- tcAddErrCtxt (typeCtxt ty) $
84 -- Type-check a type, *and* then lazily zonk it. The important
85 -- point is that this zonks all the uncommitted *kind* variables
86 -- in kinds of any any nested for-all tyvars.
87 -- There won't be any mutable *type* variables at all.
89 -- NOTE the forkNF_Tc. This makes the zonking lazy, which is
90 -- absolutely necessary. During the type-checking of a recursive
91 -- group of tycons/classes (TcTyClsDecls.tcGroup) we use an
92 -- environment in which we aren't allowed to look at the actual
93 -- tycons/classes returned from a lookup. Because tc_app does
94 -- look at the tycon to build the type, we can't look at the type
95 -- either, until we get out of the loop. The fork delays the
96 -- zonking till we've completed the loop. Sigh.
98 tcHsTopType :: RenamedHsType -> TcM s Type
100 = -- tcAddErrCtxt (typeCtxt ty) $
101 tc_type ty `thenTc` \ ty' ->
102 forkNF_Tc (zonkTcTypeToType ty')
104 tcHsTopTypeKind :: RenamedHsType -> TcM s (TcKind, Type)
106 = -- tcAddErrCtxt (typeCtxt ty) $
107 tc_type_kind ty `thenTc` \ (kind, ty') ->
108 forkNF_Tc (zonkTcTypeToType ty') `thenTc` \ zonked_ty ->
109 returnNF_Tc (kind, zonked_ty)
111 tcHsTopBoxedType :: RenamedHsType -> TcM s Type
113 = -- tcAddErrCtxt (typeCtxt ty) $
114 tc_boxed_type ty `thenTc` \ ty' ->
115 forkNF_Tc (zonkTcTypeToType ty')
123 tc_boxed_type :: RenamedHsType -> TcM s Type
125 = tc_type_kind ty `thenTc` \ (actual_kind, tc_ty) ->
126 tcAddErrCtxt (typeKindCtxt ty)
127 (unifyKind boxedTypeKind actual_kind) `thenTc_`
130 tc_type :: RenamedHsType -> TcM s Type
132 -- The type ty must be a *type*, but it can be boxed
133 -- or unboxed. So we check that is is of form (Type bv)
134 -- using unifyTypeKind
135 = tc_type_kind ty `thenTc` \ (actual_kind, tc_ty) ->
136 tcAddErrCtxt (typeKindCtxt ty)
137 (unifyTypeKind actual_kind) `thenTc_`
140 tc_type_kind :: RenamedHsType -> TcM s (TcKind, Type)
141 tc_type_kind ty@(MonoTyVar name)
144 tc_type_kind (MonoListTy ty)
145 = tc_boxed_type ty `thenTc` \ tau_ty ->
146 returnTc (boxedTypeKind, mkListTy tau_ty)
148 tc_type_kind (MonoTupleTy tys True {-boxed-})
149 = mapTc tc_boxed_type tys `thenTc` \ tau_tys ->
150 returnTc (boxedTypeKind, mkTupleTy (length tys) tau_tys)
152 tc_type_kind (MonoTupleTy tys False {-unboxed-})
153 = mapTc tc_type tys `thenTc` \ tau_tys ->
154 returnTc (unboxedTypeKind, mkUnboxedTupleTy (length tys) tau_tys)
156 tc_type_kind (MonoFunTy ty1 ty2)
157 = tc_type ty1 `thenTc` \ tau_ty1 ->
158 tc_type ty2 `thenTc` \ tau_ty2 ->
159 returnTc (boxedTypeKind, mkFunTy tau_ty1 tau_ty2)
161 tc_type_kind (MonoTyApp ty1 ty2)
164 tc_type_kind (MonoDictTy class_name tys)
165 = tcClassAssertion (HsPClass class_name tys) `thenTc` \ (Class clas arg_tys) ->
166 returnTc (boxedTypeKind, mkDictTy clas arg_tys)
168 tc_type_kind (MonoUsgTy usg ty)
169 = newUsg usg `thenTc` \ usg' ->
170 tc_type_kind ty `thenTc` \ (kind, tc_ty) ->
171 returnTc (kind, mkUsgTy usg' tc_ty)
173 newUsg usg = case usg of
174 MonoUsOnce -> returnTc UsOnce
175 MonoUsMany -> returnTc UsMany
176 MonoUsVar uv_name -> tcLookupUVar uv_name `thenTc` \ uv ->
179 tc_type_kind (MonoUsgForAllTy uv_name ty)
181 uv = mkNamedUVar uv_name
183 tcExtendUVarEnv uv_name uv $
184 tc_type_kind ty `thenTc` \ (kind, tc_ty) ->
185 returnTc (kind, mkUsForAllTy uv tc_ty)
187 tc_type_kind (HsForAllTy (Just tv_names) context ty)
188 = tcExtendTyVarScope tv_names $ \ tyvars ->
189 tcContext context `thenTc` \ theta ->
190 tc_type_kind ty `thenTc` \ (kind, tau) ->
191 tcGetInScopeTyVars `thenTc` \ in_scope_vars ->
193 body_kind | null theta = kind
194 | otherwise = boxedTypeKind
195 -- Context behaves like a function type
196 -- This matters. Return-unboxed-tuple analysis can
197 -- give overloaded functions like
198 -- f :: forall a. Num a => (# a->a, a->a #)
199 -- And we want these to get through the type checker
200 check ct@(Class c tys) | ambiguous = failWithTc (ambigErr (c,tys) tau)
201 where ct_vars = tyVarsOfTypes tys
202 forall_tyvars = map varName in_scope_vars
203 tau_vars = tyVarsOfType tau
204 ambig ct_var = (varName ct_var `elem` forall_tyvars) &&
205 not (ct_var `elemUFM` tau_vars)
206 ambiguous = foldUFM ((||) . ambig) False ct_vars
207 check _ = returnTc ()
209 mapTc check theta `thenTc_`
210 returnTc (body_kind, mkSigmaTy tyvars theta tau)
213 Help functions for type applications
214 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
217 tc_app (MonoTyApp ty1 ty2) tys
218 = tc_app ty1 (ty2:tys)
225 = tcAddErrCtxt (appKindCtxt pp_app) $
226 mapAndUnzipTc tc_type_kind tys `thenTc` \ (arg_kinds, arg_tys) ->
227 tc_fun_type ty arg_tys `thenTc` \ (fun_kind, result_ty) ->
229 -- Check argument compatibility
230 newKindVar `thenNF_Tc` \ result_kind ->
231 unifyKind fun_kind (mkArrowKinds arg_kinds result_kind)
233 returnTc (result_kind, result_ty)
235 pp_app = ppr ty <+> sep (map pprParendHsType tys)
237 -- (tc_fun_type ty arg_tys) returns (kind-of ty, mkAppTys ty arg_tys)
238 -- But not quite; for synonyms it checks the correct arity, and builds a SynTy
239 -- hence the rather strange functionality.
241 tc_fun_type (MonoTyVar name) arg_tys
242 = tcLookupTy name `thenTc` \ (tycon_kind, maybe_arity, thing) ->
244 ATyVar tv -> returnTc (tycon_kind, mkAppTys (mkTyVarTy tv) arg_tys)
245 AClass clas -> failWithTc (classAsTyConErr name)
246 ATyCon tc -> case maybe_arity of
247 Nothing -> -- Data or newtype
248 returnTc (tycon_kind, mkTyConApp tc arg_tys)
250 Just arity -> -- Type synonym
251 checkTc (arity <= n_args) err_msg `thenTc_`
252 returnTc (tycon_kind, result_ty)
254 -- It's OK to have an *over-applied* type synonym
255 -- data Tree a b = ...
256 -- type Foo a = Tree [a]
257 -- f :: Foo a b -> ...
258 result_ty = mkAppTys (mkSynTy tc (take arity arg_tys))
260 err_msg = arityErr "type synonym" name arity n_args
261 n_args = length arg_tys
263 tc_fun_type ty arg_tys
264 = tc_type_kind ty `thenTc` \ (fun_kind, fun_ty) ->
265 returnTc (fun_kind, mkAppTys fun_ty arg_tys)
273 tcContext :: RenamedContext -> TcM s ThetaType
275 = --Someone discovered that @CCallable@ and @CReturnable@
276 -- could be used in contexts such as:
277 -- foo :: CCallable a => a -> PrimIO Int
278 -- Doing this utterly wrecks the whole point of introducing these
279 -- classes so we specifically check that this isn't being done.
281 -- We *don't* do this check in tcClassAssertion, because that's
282 -- called when checking a HsDictTy, and we don't want to reject
283 -- instance CCallable Int
285 mapTc check_naughty context `thenTc_`
287 mapTc tcClassAssertion context
290 check_naughty (HsPClass class_name _)
291 = checkTc (not (getUnique class_name `elem` cCallishClassKeys))
292 (naughtyCCallContextErr class_name)
293 check_naughty (HsPIParam _ _) = returnTc ()
295 tcClassAssertion assn@(HsPClass class_name tys)
296 = tcAddErrCtxt (appKindCtxt (pprHsPred assn)) $
297 mapAndUnzipTc tc_type_kind tys `thenTc` \ (arg_kinds, arg_tys) ->
298 tcLookupTy class_name `thenTc` \ (kind, ~(Just arity), thing) ->
300 ATyVar _ -> failWithTc (tyVarAsClassErr class_name)
301 ATyCon _ -> failWithTc (tyConAsClassErr class_name)
303 -- Check with kind mis-match
304 checkTc (arity == n_tys) err `thenTc_`
305 unifyKind kind (mkArrowKinds arg_kinds boxedTypeKind) `thenTc_`
306 returnTc (Class clas arg_tys)
309 err = arityErr "Class" class_name arity n_tys
310 tcClassAssertion assn@(HsPIParam name ty)
311 = tcAddErrCtxt (appKindCtxt (pprHsPred assn)) $
312 tc_type_kind ty `thenTc` \ (arg_kind, arg_ty) ->
313 returnTc (IParam name arg_ty)
317 %************************************************************************
319 \subsection{Type variables, with knot tying!}
321 %************************************************************************
324 tcExtendTopTyVarScope :: TcKind -> [HsTyVar Name]
325 -> ([TcTyVar] -> TcKind -> TcM s a)
327 tcExtendTopTyVarScope kind tyvar_names thing_inside
329 (tyvars_w_kinds, result_kind) = zipFunTys tyvar_names kind
330 tyvars = map mk_tv tyvars_w_kinds
332 tcExtendTyVarEnv tyvars (thing_inside tyvars result_kind)
334 mk_tv (UserTyVar name, kind) = mkTyVar name kind
335 mk_tv (IfaceTyVar name _, kind) = mkTyVar name kind
336 -- NB: immutable tyvars, but perhaps with mutable kinds
338 tcExtendTyVarScope :: [HsTyVar Name]
339 -> ([TcTyVar] -> TcM s a) -> TcM s a
340 tcExtendTyVarScope tv_names thing_inside
341 = mapNF_Tc tcHsTyVar tv_names `thenNF_Tc` \ tyvars ->
342 tcExtendTyVarEnv tyvars $
345 tcHsTyVar :: HsTyVar Name -> NF_TcM s TcTyVar
346 tcHsTyVar (UserTyVar name) = newKindVar `thenNF_Tc` \ kind ->
347 tcNewMutTyVar name kind
348 -- NB: mutable kind => mutable tyvar, so that zonking can bind
349 -- the tyvar to its immutable form
351 tcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (mkTyVar name (kindToTcKind kind))
353 kcHsTyVar :: HsTyVar name -> NF_TcM s TcKind
354 kcHsTyVar (UserTyVar name) = newKindVar
355 kcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (kindToTcKind kind)
359 %************************************************************************
361 \subsection{Signatures}
363 %************************************************************************
365 @tcSigs@ checks the signatures for validity, and returns a list of
366 {\em freshly-instantiated} signatures. That is, the types are already
367 split up, and have fresh type variables installed. All non-type-signature
368 "RenamedSigs" are ignored.
370 The @TcSigInfo@ contains @TcTypes@ because they are unified with
371 the variable's type, and after that checked to see whether they've
377 Name -- N, the Name in corresponding binding
379 TcId -- *Polymorphic* binder for this value...
386 TcId -- *Monomorphic* binder for this value
387 -- Does *not* have name = N
390 Inst -- Empty if theta is null, or
391 -- (method mono_id) otherwise
393 SrcLoc -- Of the signature
395 instance Outputable TcSigInfo where
396 ppr (TySigInfo nm id tyvars theta tau _ inst loc) =
397 ppr nm <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau
399 maybeSig :: [TcSigInfo] -> Name -> Maybe (TcSigInfo)
400 -- Search for a particular signature
401 maybeSig [] name = Nothing
402 maybeSig (sig@(TySigInfo sig_name _ _ _ _ _ _ _) : sigs) name
403 | name == sig_name = Just sig
404 | otherwise = maybeSig sigs name
409 tcTySig :: RenamedSig -> TcM s TcSigInfo
411 tcTySig (Sig v ty src_loc)
412 = tcAddSrcLoc src_loc $
413 tcHsType ty `thenTc` \ sigma_tc_ty ->
414 mkTcSig (mkVanillaId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig ->
417 mkTcSig :: TcId -> SrcLoc -> NF_TcM s TcSigInfo
418 mkTcSig poly_id src_loc
419 = -- Instantiate this type
420 -- It's important to do this even though in the error-free case
421 -- we could just split the sigma_tc_ty (since the tyvars don't
422 -- unified with anything). But in the case of an error, when
423 -- the tyvars *do* get unified with something, we want to carry on
424 -- typechecking the rest of the program with the function bound
425 -- to a pristine type, namely sigma_tc_ty
427 (tyvars, rho) = splitForAllTys (idType poly_id)
429 mapNF_Tc tcInstSigVar tyvars `thenNF_Tc` \ tyvars' ->
430 -- Make *signature* type variables
433 tyvar_tys' = mkTyVarTys tyvars'
434 rho' = substTy (mkTopTyVarSubst tyvars tyvar_tys') rho
435 -- mkTopTyVarSubst because the tyvars' are fresh
436 (theta', tau') = splitRhoTy rho'
437 -- This splitRhoTy tries hard to make sure that tau' is a type synonym
438 -- wherever possible, which can improve interface files.
440 newMethodWithGivenTy SignatureOrigin
443 theta' tau' `thenNF_Tc` \ inst ->
444 -- We make a Method even if it's not overloaded; no harm
446 returnNF_Tc (TySigInfo name poly_id tyvars' theta' tau' (instToIdBndr inst) inst src_loc)
448 name = idName poly_id
453 %************************************************************************
455 \subsection{Checking signature type variables}
457 %************************************************************************
459 @checkSigTyVars@ is used after the type in a type signature has been unified with
460 the actual type found. It then checks that the type variables of the type signature
462 (a) Still all type variables
463 eg matching signature [a] against inferred type [(p,q)]
464 [then a will be unified to a non-type variable]
466 (b) Still all distinct
467 eg matching signature [(a,b)] against inferred type [(p,p)]
468 [then a and b will be unified together]
470 (c) Not mentioned in the environment
471 eg the signature for f in this:
477 Here, f is forced to be monorphic by the free occurence of x.
479 (d) Not (unified with another type variable that is) in scope.
480 eg f x :: (r->r) = (\y->y) :: forall a. a->r
481 when checking the expression type signature, we find that
482 even though there is nothing in scope whose type mentions r,
483 nevertheless the type signature for the expression isn't right.
485 Another example is in a class or instance declaration:
487 op :: forall b. a -> b
489 Here, b gets unified with a
491 Before doing this, the substitution is applied to the signature type variable.
493 We used to have the notion of a "DontBind" type variable, which would
494 only be bound to itself or nothing. Then points (a) and (b) were
495 self-checking. But it gave rise to bogus consequential error messages.
498 f = (*) -- Monomorphic
503 Here, we get a complaint when checking the type signature for g,
504 that g isn't polymorphic enough; but then we get another one when
505 dealing with the (Num x) context arising from f's definition;
506 we try to unify x with Int (to default it), but find that x has already
507 been unified with the DontBind variable "a" from g's signature.
508 This is really a problem with side-effecting unification; we'd like to
509 undo g's effects when its type signature fails, but unification is done
510 by side effect, so we can't (easily).
512 So we revert to ordinary type variables for signatures, and try to
513 give a helpful message in checkSigTyVars.
516 checkSigTyVars :: [TcTyVar] -- The original signature type variables
517 -> TcM s [TcTyVar] -- Zonked signature type variables
519 checkSigTyVars [] = returnTc []
521 checkSigTyVars sig_tyvars
522 = zonkTcTyVars sig_tyvars `thenNF_Tc` \ sig_tys ->
523 tcGetGlobalTyVars `thenNF_Tc` \ globals ->
525 checkTcM (all_ok sig_tys globals)
526 (complain sig_tys globals) `thenTc_`
528 returnTc (map (getTyVar "checkSigTyVars") sig_tys)
532 all_ok (ty:tys) acc = case getTyVar_maybe ty of
533 Nothing -> False -- Point (a)
534 Just tv | tv `elemVarSet` acc -> False -- Point (b) or (c)
535 | otherwise -> all_ok tys (acc `extendVarSet` tv)
538 complain sig_tys globals
539 = -- For the in-scope ones, zonk them and construct a map
540 -- from the zonked tyvar to the in-scope one
541 -- If any of the in-scope tyvars zonk to a type, then ignore them;
542 -- that'll be caught later when we back up to their type sig
543 tcGetInScopeTyVars `thenNF_Tc` \ in_scope_tvs ->
544 zonkTcTyVars in_scope_tvs `thenNF_Tc` \ in_scope_tys ->
546 in_scope_assoc = [ (zonked_tv, in_scope_tv)
547 | (z_ty, in_scope_tv) <- in_scope_tys `zip` in_scope_tvs,
548 Just zonked_tv <- [getTyVar_maybe z_ty]
550 in_scope_env = mkVarEnv in_scope_assoc
553 -- "check" checks each sig tyvar in turn
555 (env2, in_scope_env, [])
556 (tidy_tvs `zip` tidy_tys) `thenNF_Tc` \ (env3, _, msgs) ->
558 failWithTcM (env3, main_msg $$ nest 4 (vcat msgs))
560 (env1, tidy_tvs) = mapAccumL tidyTyVar emptyTidyEnv sig_tyvars
561 (env2, tidy_tys) = tidyOpenTypes env1 sig_tys
563 main_msg = ptext SLIT("Inferred type is less polymorphic than expected")
565 check (env, acc, msgs) (sig_tyvar,ty)
566 -- sig_tyvar is from the signature;
567 -- ty is what you get if you zonk sig_tyvar and then tidy it
569 -- acc maps a zonked type variable back to a signature type variable
570 = case getTyVar_maybe ty of {
571 Nothing -> -- Error (a)!
572 returnNF_Tc (env, acc, unify_msg sig_tyvar (ppr ty) : msgs) ;
576 case lookupVarEnv acc tv of {
577 Just sig_tyvar' -> -- Error (b) or (d)!
578 returnNF_Tc (env, acc, unify_msg sig_tyvar (ppr sig_tyvar') : msgs) ;
582 if tv `elemVarSet` globals -- Error (c)! Type variable escapes
583 -- The least comprehensible, so put it last
584 then tcGetValueEnv `thenNF_Tc` \ ve ->
585 find_globals tv env (valueEnvIds ve) `thenNF_Tc` \ (env1, globs) ->
586 returnNF_Tc (env1, acc, escape_msg sig_tyvar tv globs : msgs)
589 returnNF_Tc (env, extendVarEnv acc tv sig_tyvar, msgs)
592 -- find_globals looks at the value environment and finds values
593 -- whose types mention the offending type variable. It has to be
594 -- careful to zonk the Id's type first, so it has to be in the monad.
595 -- We must be careful to pass it a zonked type variable, too.
596 find_globals tv tidy_env ids
598 = returnNF_Tc (tidy_env, [])
600 find_globals tv tidy_env (id:ids)
601 | not (isLocallyDefined id) ||
602 isEmptyVarSet (idFreeTyVars id)
603 = find_globals tv tidy_env ids
606 = zonkTcType (idType id) `thenNF_Tc` \ id_ty ->
607 if tv `elemVarSet` tyVarsOfType id_ty then
609 (tidy_env', id_ty') = tidyOpenType tidy_env id_ty
611 find_globals tv tidy_env' ids `thenNF_Tc` \ (tidy_env'', globs) ->
612 returnNF_Tc (tidy_env'', (idName id, id_ty') : globs)
614 find_globals tv tidy_env ids
616 escape_msg sig_tv tv globs
617 = vcat [mk_msg sig_tv <+> ptext SLIT("escapes"),
619 ptext SLIT("The following variables in the environment mention") <+> quotes (ppr tv),
620 nest 4 (vcat_first 10 [ppr name <+> dcolon <+> ppr ty | (name,ty) <- globs])
623 pp_escape | sig_tv /= tv = ptext SLIT("It unifies with") <+>
624 quotes (ppr tv) <> comma <+>
625 ptext SLIT("which is mentioned in the environment")
626 | otherwise = ptext SLIT("It is mentioned in the environment")
628 vcat_first :: Int -> [SDoc] -> SDoc
629 vcat_first n [] = empty
630 vcat_first 0 (x:xs) = text "...others omitted..."
631 vcat_first n (x:xs) = x $$ vcat_first (n-1) xs
633 unify_msg tv thing = mk_msg tv <+> ptext SLIT("is unified with") <+> quotes thing
634 mk_msg tv = ptext SLIT("Quantified type variable") <+> quotes (ppr tv)
637 These two context are used with checkSigTyVars
640 sigCtxt :: (Type -> Message) -> Type
641 -> TidyEnv -> NF_TcM s (TidyEnv, Message)
642 sigCtxt mk_msg sig_ty tidy_env
644 (env1, tidy_sig_ty) = tidyOpenType tidy_env sig_ty
646 returnNF_Tc (env1, mk_msg tidy_sig_ty)
648 sigPatCtxt bound_tvs bound_ids tidy_env
650 sep [ptext SLIT("When checking a pattern that binds"),
651 nest 4 (vcat (zipWith ppr_id show_ids tidy_tys))])
653 show_ids = filter is_interesting bound_ids
654 is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
656 (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
657 ppr_id id ty = ppr id <+> dcolon <+> ppr ty
658 -- Don't zonk the types so we get the separate, un-unified versions
662 %************************************************************************
664 \subsection{Errors and contexts}
666 %************************************************************************
669 naughtyCCallContextErr clas_name
670 = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas_name),
671 ptext SLIT("in a context")]
673 typeCtxt ty = ptext SLIT("In the type") <+> quotes (ppr ty)
675 typeKindCtxt :: RenamedHsType -> Message
676 typeKindCtxt ty = sep [ptext SLIT("When checking that"),
677 nest 2 (quotes (ppr ty)),
678 ptext SLIT("is a type")]
680 appKindCtxt :: SDoc -> Message
681 appKindCtxt pp = ptext SLIT("When checking kinds in") <+> quotes pp
684 = ptext SLIT("Class used as a type constructor:") <+> ppr name
687 = ptext SLIT("Type constructor used as a class:") <+> ppr name
690 = ptext SLIT("Type variable used as a class:") <+> ppr name
693 = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprConstraint c ts),
694 nest 4 (ptext SLIT("for the type:") <+> ppr ty),
695 nest 4 (ptext SLIT("Each forall'd type variable mentioned by the constraint must appear after the =>."))]