2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcMonoType]{Typechecking user-specified @MonoTypes@}
7 module TcMonoType ( tcHsSigType, tcHsType, tcIfaceType, tcHsTheta, tcHsPred,
11 kcHsTyVar, kcHsTyVars, mkTyClTyVars,
12 kcHsType, kcHsSigType, kcHsSigTypes,
13 kcHsLiftedSigType, kcHsContext,
14 tcAddScopedTyVars, tcHsTyVars, mkImmutTyVars,
16 TcSigInfo(..), tcTySig, mkTcSig, maybeSig, tcSigPolyId, tcSigMonoId
19 #include "HsVersions.h"
21 import HsSyn ( HsType(..), HsTyVarBndr(..), HsTyOp(..),
22 Sig(..), HsPred(..), pprParendHsType, HsTupCon(..), hsTyVarNames )
23 import RnHsSyn ( RenamedHsType, RenamedHsPred, RenamedContext, RenamedSig, extractHsTyVars )
24 import TcHsSyn ( TcId )
27 import TcEnv ( tcExtendTyVarEnv, tcLookup, tcLookupGlobal,
29 TyThing(..), TcTyThing(..), tcExtendKindEnv
31 import TcMType ( newKindVar, zonkKindEnv, tcInstType,
32 checkValidType, UserTypeCtxt(..), pprUserTypeCtxt
34 import TcUnify ( unifyKind, unifyOpenTypeKind )
35 import TcType ( Type, Kind, SourceType(..), ThetaType, TyVarDetails(..),
36 TcTyVar, TcKind, TcThetaType, TcTauType,
37 mkTyVarTy, mkTyVarTys, mkFunTy,
38 zipFunTys, mkForAllTys, mkFunTys, tcEqType, isPredTy,
39 mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys,
40 liftedTypeKind, unliftedTypeKind, mkArrowKind,
41 mkArrowKinds, tcSplitFunTy_maybe, tcSplitForAllTys
43 import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToId )
45 import Id ( mkLocalId, idName, idType )
46 import Var ( TyVar, mkTyVar, tyVarKind )
47 import ErrUtils ( Message )
48 import TyCon ( TyCon, tyConKind )
49 import Class ( classTyCon )
52 import Subst ( deShadowTy )
53 import TysWiredIn ( mkListTy, mkPArrTy, mkTupleTy, genUnitTyCon )
54 import BasicTypes ( Boxity(..) )
55 import SrcLoc ( SrcLoc )
56 import Util ( lengthIs )
62 %************************************************************************
64 \subsection{Checking types}
66 %************************************************************************
68 Generally speaking we now type-check types in three phases
70 1. Kind check the HsType [kcHsType]
71 2. Convert from HsType to Type, and hoist the foralls [tcHsType]
72 3. Check the validity of the resulting type [checkValidType]
74 Often these steps are done one after the othe (tcHsSigType).
75 But in mutually recursive groups of type and class decls we do
76 1 kind-check the whole group
77 2 build TyCons/Classes in a knot-tied wa
78 3 check the validity of types in the now-unknotted TyCons/Classes
81 tcHsSigType :: UserTypeCtxt -> RenamedHsType -> TcM Type
82 -- Do kind checking, and hoist for-alls to the top
83 tcHsSigType ctxt ty = tcAddErrCtxt (checkTypeCtxt ctxt ty) (
84 kcTypeType ty `thenTc_`
87 checkValidType ctxt ty' `thenTc_`
91 = vcat [ptext SLIT("In the type:") <+> ppr ty,
92 ptext SLIT("While checking") <+> pprUserTypeCtxt ctxt ]
94 tcHsType :: RenamedHsType -> TcM Type
95 -- Don't do kind checking, nor validity checking,
96 -- but do hoist for-alls to the top
97 -- This is used in type and class decls, where kinding is
98 -- done in advance, and validity checking is done later
99 -- [Validity checking done later because of knot-tying issues.]
100 tcHsType ty = tc_type ty `thenTc` \ ty' ->
101 returnTc (hoistForAllTys ty')
103 tcHsTheta :: RenamedContext -> TcM ThetaType
104 -- Used when we are expecting a ClassContext (i.e. no implicit params)
105 -- Does not do validity checking, like tcHsType
106 tcHsTheta hs_theta = mapTc tc_pred hs_theta
108 -- In interface files the type is already kinded,
109 -- and we definitely don't want to hoist for-alls.
110 -- Otherwise we'll change
111 -- dmfail :: forall m:(*->*) Monad m => forall a:* => String -> m a
113 -- dmfail :: forall m:(*->*) a:* Monad m => String -> m a
114 -- which definitely isn't right!
115 tcIfaceType ty = tc_type ty
119 %************************************************************************
121 \subsection{Kind checking}
123 %************************************************************************
127 When we come across the binding site for some type variables, we
128 proceed in two stages
130 1. Figure out what kind each tyvar has
132 2. Create suitably-kinded tyvars,
134 and typecheck the body
136 To do step 1, we proceed thus:
138 1a. Bind each type variable to a kind variable
139 1b. Apply the kind checker
140 1c. Zonk the resulting kinds
142 The kind checker is passed to tcHsTyVars as an argument.
144 For example, when we find
145 (forall a m. m a -> m a)
146 we bind a,m to kind varibles and kind-check (m a -> m a). This
147 makes a get kind *, and m get kind *->*. Now we typecheck (m a -> m a)
148 in an environment that binds a and m suitably.
150 The kind checker passed to tcHsTyVars needs to look at enough to
151 establish the kind of the tyvar:
152 * For a group of type and class decls, it's just the group, not
153 the rest of the program
154 * For a tyvar bound in a pattern type signature, its the types
155 mentioned in the other type signatures in that bunch of patterns
156 * For a tyvar bound in a RULE, it's the type signatures on other
157 universally quantified variables in the rule
159 Note that this may occasionally give surprising results. For example:
161 data T a b = MkT (a b)
163 Here we deduce a::*->*, b::*.
164 But equally valid would be
165 a::(*->*)-> *, b::*->*
168 -- tcHsTyVars is used for type variables in type signatures
169 -- e.g. forall a. a->a
170 -- They are immutable, because they scope only over the signature
171 -- They may or may not be explicitly-kinded
172 tcHsTyVars :: [HsTyVarBndr Name]
173 -> TcM a -- The kind checker
174 -> ([TyVar] -> TcM b)
177 tcHsTyVars [] kind_check thing_inside = thing_inside []
178 -- A useful short cut for a common case!
180 tcHsTyVars tv_names kind_check thing_inside
181 = kcHsTyVars tv_names `thenNF_Tc` \ tv_names_w_kinds ->
182 tcExtendKindEnv tv_names_w_kinds kind_check `thenTc_`
183 zonkKindEnv tv_names_w_kinds `thenNF_Tc` \ tvs_w_kinds ->
185 tyvars = mkImmutTyVars tvs_w_kinds
187 tcExtendTyVarEnv tyvars (thing_inside tyvars)
191 tcAddScopedTyVars :: [RenamedHsType] -> TcM a -> TcM a
192 -- tcAddScopedTyVars is used for scoped type variables
193 -- added by pattern type signatures
194 -- e.g. \ (x::a) (y::a) -> x+y
195 -- They never have explicit kinds (because this is source-code only)
196 -- They are mutable (because they can get bound to a more specific type)
198 -- Find the not-already-in-scope signature type variables,
199 -- kind-check them, and bring them into scope
201 -- We no longer specify that these type variables must be univerally
202 -- quantified (lots of email on the subject). If you want to put that
203 -- back in, you need to
204 -- a) Do a checkSigTyVars after thing_inside
205 -- b) More insidiously, don't pass in expected_ty, else
206 -- we unify with it too early and checkSigTyVars barfs
207 -- Instead you have to pass in a fresh ty var, and unify
208 -- it with expected_ty afterwards
209 tcAddScopedTyVars [] thing_inside
210 = thing_inside -- Quick get-out for the empty case
212 tcAddScopedTyVars sig_tys thing_inside
213 = tcGetEnv `thenNF_Tc` \ env ->
215 all_sig_tvs = foldr (unionNameSets . extractHsTyVars) emptyNameSet sig_tys
216 sig_tvs = filter not_in_scope (nameSetToList all_sig_tvs)
217 not_in_scope tv = not (tcInLocalScope env tv)
219 mapNF_Tc newNamedKindVar sig_tvs `thenTc` \ kind_env ->
220 tcExtendKindEnv kind_env (kcHsSigTypes sig_tys) `thenTc_`
221 zonkKindEnv kind_env `thenNF_Tc` \ tvs_w_kinds ->
222 listTc [ tcNewMutTyVar name kind PatSigTv
223 | (name, kind) <- tvs_w_kinds] `thenNF_Tc` \ tyvars ->
224 tcExtendTyVarEnv tyvars thing_inside
229 kcHsTyVar :: HsTyVarBndr name -> NF_TcM (name, TcKind)
230 kcHsTyVars :: [HsTyVarBndr name] -> NF_TcM [(name, TcKind)]
232 kcHsTyVar (UserTyVar name) = newNamedKindVar name
233 kcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (name, kind)
235 kcHsTyVars tvs = mapNF_Tc kcHsTyVar tvs
237 newNamedKindVar name = newKindVar `thenNF_Tc` \ kind ->
238 returnNF_Tc (name, kind)
240 ---------------------------
241 kcLiftedType :: RenamedHsType -> TcM ()
242 -- The type ty must be a *lifted* *type*
244 = kcHsType ty `thenTc` \ kind ->
245 tcAddErrCtxt (typeKindCtxt ty) $
246 unifyKind liftedTypeKind kind
248 ---------------------------
249 kcTypeType :: RenamedHsType -> TcM ()
250 -- The type ty must be a *type*, but it can be lifted or unlifted.
252 = kcHsType ty `thenTc` \ kind ->
253 tcAddErrCtxt (typeKindCtxt ty) $
254 unifyOpenTypeKind kind
256 ---------------------------
257 kcHsSigType, kcHsLiftedSigType :: RenamedHsType -> TcM ()
258 -- Used for type signatures
259 kcHsSigType = kcTypeType
260 kcHsSigTypes tys = mapTc_ kcHsSigType tys
261 kcHsLiftedSigType = kcLiftedType
263 ---------------------------
264 kcHsType :: RenamedHsType -> TcM TcKind
265 kcHsType (HsTyVar name) = kcTyVar name
267 kcHsType (HsKindSig ty k)
268 = kcHsType ty `thenTc` \ k' ->
269 unifyKind k k' `thenTc_`
272 kcHsType (HsListTy ty)
273 = kcLiftedType ty `thenTc` \ tau_ty ->
274 returnTc liftedTypeKind
276 kcHsType (HsPArrTy ty)
277 = kcLiftedType ty `thenTc` \ tau_ty ->
278 returnTc liftedTypeKind
280 kcHsType (HsTupleTy (HsTupCon _ boxity _) tys)
281 = mapTc kcTypeType tys `thenTc_`
282 returnTc (case boxity of
283 Boxed -> liftedTypeKind
284 Unboxed -> unliftedTypeKind)
286 kcHsType (HsFunTy ty1 ty2)
287 = kcTypeType ty1 `thenTc_`
288 kcTypeType ty2 `thenTc_`
289 returnTc liftedTypeKind
291 kcHsType (HsOpTy ty1 HsArrow ty2)
292 = kcTypeType ty1 `thenTc_`
293 kcTypeType ty2 `thenTc_`
294 returnTc liftedTypeKind
296 kcHsType ty@(HsOpTy ty1 (HsTyOp op) ty2)
297 = kcTyVar op `thenTc` \ op_kind ->
298 kcHsType ty1 `thenTc` \ ty1_kind ->
299 kcHsType ty2 `thenTc` \ ty2_kind ->
300 tcAddErrCtxt (appKindCtxt (ppr ty)) $
301 kcAppKind op_kind ty1_kind `thenTc` \ op_kind' ->
302 kcAppKind op_kind' ty2_kind
304 kcHsType (HsParTy ty) -- Skip parentheses markers
307 kcHsType (HsNumTy _) -- The unit type for generics
308 = returnTc liftedTypeKind
310 kcHsType (HsPredTy pred)
311 = kcHsPred pred `thenTc_`
312 returnTc liftedTypeKind
314 kcHsType ty@(HsAppTy ty1 ty2)
315 = kcHsType ty1 `thenTc` \ tc_kind ->
316 kcHsType ty2 `thenTc` \ arg_kind ->
317 tcAddErrCtxt (appKindCtxt (ppr ty)) $
318 kcAppKind tc_kind arg_kind
320 kcHsType (HsForAllTy (Just tv_names) context ty)
321 = kcHsTyVars tv_names `thenNF_Tc` \ kind_env ->
322 tcExtendKindEnv kind_env $
323 kcHsContext context `thenTc_`
324 kcHsType ty `thenTc_`
325 returnTc liftedTypeKind
327 ---------------------------
328 kcAppKind fun_kind arg_kind
329 = case tcSplitFunTy_maybe fun_kind of
330 Just (arg_kind', res_kind)
331 -> unifyKind arg_kind arg_kind' `thenTc_`
334 Nothing -> newKindVar `thenNF_Tc` \ res_kind ->
335 unifyKind fun_kind (mkArrowKind arg_kind res_kind) `thenTc_`
339 ---------------------------
340 kc_pred :: RenamedHsPred -> TcM TcKind -- Does *not* check for a saturated
341 -- application (reason: used from TcDeriv)
342 kc_pred pred@(HsIParam name ty)
345 kc_pred pred@(HsClassP cls tys)
346 = kcClass cls `thenTc` \ kind ->
347 mapTc kcHsType tys `thenTc` \ arg_kinds ->
348 newKindVar `thenNF_Tc` \ kv ->
349 unifyKind kind (mkArrowKinds arg_kinds kv) `thenTc_`
352 ---------------------------
353 kcHsContext ctxt = mapTc_ kcHsPred ctxt
355 kcHsPred pred -- Checks that the result is of kind liftedType
356 = tcAddErrCtxt (appKindCtxt (ppr pred)) $
357 kc_pred pred `thenTc` \ kind ->
358 unifyKind liftedTypeKind kind `thenTc_`
362 ---------------------------
363 kcTyVar name -- Could be a tyvar or a tycon
364 = tcLookup name `thenTc` \ thing ->
366 AThing kind -> returnTc kind
367 ATyVar tv -> returnTc (tyVarKind tv)
368 AGlobal (ATyCon tc) -> returnTc (tyConKind tc)
369 other -> failWithTc (wrongThingErr "type" thing name)
371 kcClass cls -- Must be a class
372 = tcLookup cls `thenNF_Tc` \ thing ->
374 AThing kind -> returnTc kind
375 AGlobal (AClass cls) -> returnTc (tyConKind (classTyCon cls))
376 other -> failWithTc (wrongThingErr "class" thing cls)
379 %************************************************************************
383 %************************************************************************
385 tc_type, the main work horse
386 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
392 tc_type is used to typecheck the types in the RHS of data
393 constructors. In the case of recursive data types, that means that
394 the type constructors themselves are (partly) black holes. e.g.
396 data T a = MkT a [T a]
398 While typechecking the [T a] on the RHS, T itself is not yet fully
399 defined. That in turn places restrictions on what you can check in
400 tcHsType; if you poke on too much you get a black hole. I keep
401 forgetting this, hence this warning!
403 So tc_type does no validity-checking. Instead that's all done
404 by TcMType.checkValidType
406 --------------------------
407 *** END OF BIG WARNING ***
408 --------------------------
412 tc_type :: RenamedHsType -> TcM Type
414 tc_type ty@(HsTyVar name)
417 tc_type (HsKindSig ty k)
418 = tc_type ty -- Kind checking done already
420 tc_type (HsListTy ty)
421 = tc_type ty `thenTc` \ tau_ty ->
422 returnTc (mkListTy tau_ty)
424 tc_type (HsPArrTy ty)
425 = tc_type ty `thenTc` \ tau_ty ->
426 returnTc (mkPArrTy tau_ty)
428 tc_type (HsTupleTy (HsTupCon _ boxity arity) tys)
429 = ASSERT( tys `lengthIs` arity )
430 tc_types tys `thenTc` \ tau_tys ->
431 returnTc (mkTupleTy boxity arity tau_tys)
433 tc_type (HsFunTy ty1 ty2)
434 = tc_type ty1 `thenTc` \ tau_ty1 ->
435 tc_type ty2 `thenTc` \ tau_ty2 ->
436 returnTc (mkFunTy tau_ty1 tau_ty2)
438 tc_type (HsOpTy ty1 HsArrow ty2)
439 = tc_type ty1 `thenTc` \ tau_ty1 ->
440 tc_type ty2 `thenTc` \ tau_ty2 ->
441 returnTc (mkFunTy tau_ty1 tau_ty2)
443 tc_type (HsOpTy ty1 (HsTyOp op) ty2)
444 = tc_type ty1 `thenTc` \ tau_ty1 ->
445 tc_type ty2 `thenTc` \ tau_ty2 ->
446 tc_fun_type op [tau_ty1,tau_ty2]
448 tc_type (HsParTy ty) -- Remove the parentheses markers
453 returnTc (mkTyConApp genUnitTyCon [])
455 tc_type (HsAppTy ty1 ty2) = tc_app ty1 [ty2]
457 tc_type (HsPredTy pred)
458 = tc_pred pred `thenTc` \ pred' ->
459 returnTc (mkPredTy pred')
461 tc_type full_ty@(HsForAllTy (Just tv_names) ctxt ty)
463 kind_check = kcHsContext ctxt `thenTc_` kcHsType ty
465 tcHsTyVars tv_names kind_check $ \ tyvars ->
466 mapTc tc_pred ctxt `thenTc` \ theta ->
467 tc_type ty `thenTc` \ tau ->
468 returnTc (mkSigmaTy tyvars theta tau)
470 tc_types arg_tys = mapTc tc_type arg_tys
473 Help functions for type applications
474 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
477 tc_app :: RenamedHsType -> [RenamedHsType] -> TcM Type
478 tc_app (HsAppTy ty1 ty2) tys
479 = tc_app ty1 (ty2:tys)
482 = tcAddErrCtxt (appKindCtxt pp_app) $
483 tc_types tys `thenTc` \ arg_tys ->
485 HsTyVar fun -> tc_fun_type fun arg_tys
486 other -> tc_type ty `thenTc` \ fun_ty ->
487 returnNF_Tc (mkAppTys fun_ty arg_tys)
489 pp_app = ppr ty <+> sep (map pprParendHsType tys)
491 -- (tc_fun_type ty arg_tys) returns (mkAppTys ty arg_tys)
492 -- But not quite; for synonyms it checks the correct arity, and builds a SynTy
493 -- hence the rather strange functionality.
495 tc_fun_type name arg_tys
496 = tcLookup name `thenTc` \ thing ->
498 ATyVar tv -> returnTc (mkAppTys (mkTyVarTy tv) arg_tys)
500 AGlobal (ATyCon tc) -> returnTc (mkGenTyConApp tc arg_tys)
502 other -> failWithTc (wrongThingErr "type constructor" thing name)
509 tcHsPred pred = kc_pred pred `thenTc_` tc_pred pred
510 -- Is happy with a partial application, e.g. (ST s)
513 tc_pred assn@(HsClassP class_name tys)
514 = tcAddErrCtxt (appKindCtxt (ppr assn)) $
515 tc_types tys `thenTc` \ arg_tys ->
516 tcLookupGlobal class_name `thenTc` \ thing ->
518 AClass clas -> returnTc (ClassP clas arg_tys)
519 other -> failWithTc (wrongThingErr "class" (AGlobal thing) class_name)
521 tc_pred assn@(HsIParam name ty)
522 = tcAddErrCtxt (appKindCtxt (ppr assn)) $
523 tc_type ty `thenTc` \ arg_ty ->
524 returnTc (IParam name arg_ty)
529 %************************************************************************
531 \subsection{Type variables, with knot tying!}
533 %************************************************************************
536 mkImmutTyVars :: [(Name,Kind)] -> [TyVar]
537 mkImmutTyVars pairs = [mkTyVar name kind | (name, kind) <- pairs]
539 mkTyClTyVars :: Kind -- Kind of the tycon or class
540 -> [HsTyVarBndr Name]
542 mkTyClTyVars kind tyvar_names
543 = mkImmutTyVars tyvars_w_kinds
545 (tyvars_w_kinds, _) = zipFunTys (hsTyVarNames tyvar_names) kind
549 %************************************************************************
551 \subsection{Signatures}
553 %************************************************************************
555 @tcSigs@ checks the signatures for validity, and returns a list of
556 {\em freshly-instantiated} signatures. That is, the types are already
557 split up, and have fresh type variables installed. All non-type-signature
558 "RenamedSigs" are ignored.
560 The @TcSigInfo@ contains @TcTypes@ because they are unified with
561 the variable's type, and after that checked to see whether they've
567 TcId -- *Polymorphic* binder for this value...
574 TcId -- *Monomorphic* binder for this value
575 -- Does *not* have name = N
578 [Inst] -- Empty if theta is null, or
579 -- (method mono_id) otherwise
581 SrcLoc -- Of the signature
583 instance Outputable TcSigInfo where
584 ppr (TySigInfo id tyvars theta tau _ inst loc) =
585 ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau
587 tcSigPolyId :: TcSigInfo -> TcId
588 tcSigPolyId (TySigInfo id _ _ _ _ _ _) = id
590 tcSigMonoId :: TcSigInfo -> TcId
591 tcSigMonoId (TySigInfo _ _ _ _ id _ _) = id
593 maybeSig :: [TcSigInfo] -> Name -> Maybe (TcSigInfo)
594 -- Search for a particular signature
595 maybeSig [] name = Nothing
596 maybeSig (sig@(TySigInfo sig_id _ _ _ _ _ _) : sigs) name
597 | name == idName sig_id = Just sig
598 | otherwise = maybeSig sigs name
603 tcTySig :: RenamedSig -> TcM TcSigInfo
605 tcTySig (Sig v ty src_loc)
606 = tcAddSrcLoc src_loc $
607 tcHsSigType (FunSigCtxt v) ty `thenTc` \ sigma_tc_ty ->
608 mkTcSig (mkLocalId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig ->
611 mkTcSig :: TcId -> SrcLoc -> NF_TcM TcSigInfo
612 mkTcSig poly_id src_loc
613 = -- Instantiate this type
614 -- It's important to do this even though in the error-free case
615 -- we could just split the sigma_tc_ty (since the tyvars don't
616 -- unified with anything). But in the case of an error, when
617 -- the tyvars *do* get unified with something, we want to carry on
618 -- typechecking the rest of the program with the function bound
619 -- to a pristine type, namely sigma_tc_ty
620 tcInstType SigTv (idType poly_id) `thenNF_Tc` \ (tyvars', theta', tau') ->
622 newMethodWithGivenTy SignatureOrigin
625 theta' tau' `thenNF_Tc` \ inst ->
626 -- We make a Method even if it's not overloaded; no harm
628 returnNF_Tc (TySigInfo poly_id tyvars' theta' tau'
629 (instToId inst) [inst] src_loc)
633 %************************************************************************
635 \subsection{Errors and contexts}
637 %************************************************************************
641 hoistForAllTys :: Type -> Type
642 -- Used for user-written type signatures only
643 -- Move all the foralls and constraints to the top
644 -- e.g. T -> forall a. a ==> forall a. T -> a
645 -- T -> (?x::Int) -> Int ==> (?x::Int) -> T -> Int
647 -- Also: eliminate duplicate constraints. These can show up
648 -- when hoisting constraints, notably implicit parameters.
650 -- We want to 'look through' type synonyms when doing this
651 -- so it's better done on the Type than the HsType
655 no_shadow_ty = deShadowTy ty
656 -- Running over ty with an empty substitution gives it the
657 -- no-shadowing property. This is important. For example:
658 -- type Foo r = forall a. a -> r
659 -- foo :: Foo (Foo ())
660 -- Here the hoisting should give
661 -- foo :: forall a a1. a -> a1 -> ()
663 -- What about type vars that are lexically in scope in the envt?
664 -- We simply rely on them having a different unique to any
665 -- binder in 'ty'. Otherwise we'd have to slurp the in-scope-tyvars
666 -- out of the envt, which is boring and (I think) not necessary.
668 case hoist no_shadow_ty of
669 (tvs, theta, body) -> mkForAllTys tvs (mkFunTys (nubBy tcEqType theta) body)
670 -- The 'nubBy' eliminates duplicate constraints,
671 -- notably implicit parameters
674 | (tvs1, body_ty) <- tcSplitForAllTys ty,
676 = case hoist body_ty of
677 (tvs2,theta,tau) -> (tvs1 ++ tvs2, theta, tau)
679 | Just (arg, res) <- tcSplitFunTy_maybe ty
681 arg' = hoistForAllTys arg -- Don't forget to apply hoist recursively
682 in -- to the argument type
683 if (isPredTy arg') then
685 (tvs,theta,tau) -> (tvs, arg':theta, tau)
688 (tvs,theta,tau) -> (tvs, theta, mkFunTy arg' tau)
690 | otherwise = ([], [], ty)
694 %************************************************************************
696 \subsection{Errors and contexts}
698 %************************************************************************
701 typeKindCtxt :: RenamedHsType -> Message
702 typeKindCtxt ty = sep [ptext SLIT("When checking that"),
703 nest 2 (quotes (ppr ty)),
704 ptext SLIT("is a type")]
706 appKindCtxt :: SDoc -> Message
707 appKindCtxt pp = ptext SLIT("When checking kinds in") <+> quotes pp
709 wrongThingErr expected thing name
710 = pp_thing thing <+> quotes (ppr name) <+> ptext SLIT("used as a") <+> text expected
712 pp_thing (AGlobal (ATyCon _)) = ptext SLIT("Type constructor")
713 pp_thing (AGlobal (AClass _)) = ptext SLIT("Class")
714 pp_thing (AGlobal (AnId _)) = ptext SLIT("Identifier")
715 pp_thing (ATyVar _) = ptext SLIT("Type variable")
716 pp_thing (ATcId _) = ptext SLIT("Local identifier")
717 pp_thing (AThing _) = ptext SLIT("Utterly bogus")