5 mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
7 mkAppTy, mkAppTys, splitAppTy, splitAppTys,
9 mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys,
11 mkTyConApp, mkTyConTy, splitTyConApp_maybe,
12 splitAlgTyConApp_maybe, splitAlgTyConApp,
13 mkDictTy, splitDictTy_maybe, isDictTy,
17 mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, applyTy,
19 TauType, RhoType, SigmaType, ThetaType,
22 mkSigmaTy, splitSigmaTy,
24 isUnpointedType, isUnboxedType, typePrimRep,
28 tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind,
30 instantiateTy, instantiateTauTy, instantiateThetaTy,
35 #include "HsVersions.h"
37 import {-# SOURCE #-} Id ( Id )
40 import Class ( classTyCon, Class )
41 import Kind ( mkBoxedTypeKind, resultKind, Kind )
42 import TyCon ( mkFunTyCon, isFunTyCon, isEnumerationTyCon, isTupleTyCon, maybeTyConSingleCon,
43 isPrimTyCon, isAlgTyCon, isSynTyCon, tyConArity,
44 tyConKind, tyConDataCons, getSynTyConDefn,
45 tyConPrimRep, tyConClass_maybe, TyCon )
46 import TyVar ( GenTyVarSet, TyVarEnv, GenTyVar, TyVar,
47 tyVarKind, emptyTyVarSet, unionTyVarSets, minusTyVarSet,
48 unitTyVarSet, lookupTyVarEnv, delFromTyVarEnv, zipTyVarEnv, mkTyVarEnv,
49 emptyTyVarEnv, isEmptyTyVarEnv, addToTyVarEnv )
50 import Name ( NamedThing(..),
51 NameSet(..), unionNameSets, emptyNameSet, unitNameSet, minusNameSet
55 import BasicTypes ( Unused )
56 import Maybes ( maybeToBool, assocMaybe )
57 import PrimRep ( PrimRep(..) )
58 import Unique -- quite a few *Keys
59 import Util ( thenCmp, panic )
64 %************************************************************************
66 \subsection{The data type}
68 %************************************************************************
72 type Type = GenType Unused -- Used after typechecker
74 data GenType flexi -- Parameterised over the "flexi" part of a type variable
75 = TyVarTy (GenTyVar flexi)
78 (GenType flexi) -- Function is *not* a TyConApp
81 | TyConApp -- Application of a TyCon
82 TyCon -- *Invariant* saturated appliations of FunTyCon and
83 -- synonyms have their own constructors, below.
84 [GenType flexi] -- Might not be saturated.
86 | FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2]
90 | SynTy -- Saturated application of a type synonym
91 (GenType flexi) -- The unexpanded version; always a TyConTy
92 (GenType flexi) -- The expanded version
96 (GenType flexi) -- TypeKind
100 %************************************************************************
102 \subsection{Constructor-specific functions}
104 %************************************************************************
107 ---------------------------------------------------------------------
111 mkTyVarTy :: GenTyVar flexi -> GenType flexi
114 mkTyVarTys :: [GenTyVar flexi] -> [GenType flexi]
115 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
117 getTyVar :: String -> GenType flexi -> GenTyVar flexi
118 getTyVar msg (TyVarTy tv) = tv
119 getTyVar msg (SynTy _ t) = getTyVar msg t
120 getTyVar msg other = panic ("getTyVar: " ++ msg)
122 getTyVar_maybe :: GenType flexi -> Maybe (GenTyVar flexi)
123 getTyVar_maybe (TyVarTy tv) = Just tv
124 getTyVar_maybe (SynTy _ t) = getTyVar_maybe t
125 getTyVar_maybe other = Nothing
127 isTyVarTy :: GenType flexi -> Bool
128 isTyVarTy (TyVarTy tv) = True
129 isTyVarTy (SynTy _ ty) = isTyVarTy ty
130 isTyVarTy other = False
134 ---------------------------------------------------------------------
137 We need to be pretty careful with AppTy to make sure we obey the
138 invariant that a TyConApp is always visibly so. mkAppTy maintains the
142 mkAppTy orig_ty1 orig_ty2 = mk_app orig_ty1
144 mk_app (SynTy _ ty1) = mk_app ty1
145 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
146 mk_app ty1 = AppTy orig_ty1 orig_ty2
148 mkAppTys :: GenType flexi -> [GenType flexi] -> GenType flexi
149 mkAppTys orig_ty1 [] = orig_ty1
150 -- This check for an empty list of type arguments
151 -- avoids the needless of a type synonym constructor.
152 -- For example: mkAppTys Rational []
153 -- returns to (Ratio Integer), which has needlessly lost
154 -- the Rational part.
155 mkAppTys orig_ty1 orig_tys2 = mk_app orig_ty1
157 mk_app (SynTy _ ty1) = mk_app ty1
158 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
159 mk_app ty1 = foldl AppTy orig_ty1 orig_tys2
161 splitAppTy :: GenType flexi -> (GenType flexi, GenType flexi)
162 splitAppTy (FunTy ty1 ty2) = (TyConApp mkFunTyCon [ty1], ty2)
163 splitAppTy (AppTy ty1 ty2) = (ty1, ty2)
164 splitAppTy (SynTy _ ty) = splitAppTy ty
165 splitAppTy (TyConApp tc tys) = split tys []
167 split [ty2] acc = (TyConApp tc (reverse acc), ty2)
168 split (ty:tys) acc = split tys (ty:acc)
169 splitAppTy other = panic "splitAppTy"
171 splitAppTys :: GenType flexi -> (GenType flexi, [GenType flexi])
172 splitAppTys ty = split ty ty []
174 split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
175 split orig_ty (SynTy _ ty) args = split orig_ty ty args
176 split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
177 (TyConApp mkFunTyCon [], [ty1,ty2])
178 split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
179 split orig_ty ty args = (orig_ty, args)
183 ---------------------------------------------------------------------
188 mkFunTy :: GenType flexi -> GenType flexi -> GenType flexi
189 mkFunTy arg res = FunTy arg res
191 mkFunTys :: [GenType flexi] -> GenType flexi -> GenType flexi
192 mkFunTys tys ty = foldr FunTy ty tys
194 splitFunTy_maybe :: GenType flexi -> Maybe (GenType flexi, GenType flexi)
195 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
196 splitFunTy_maybe (SynTy _ ty) = splitFunTy_maybe ty
197 splitFunTy_maybe other = Nothing
200 splitFunTys :: GenType flexi -> ([GenType flexi], GenType flexi)
201 splitFunTys ty = split [] ty ty
203 split args orig_ty (FunTy arg res) = split (arg:args) res res
204 split args orig_ty (SynTy _ ty) = split args orig_ty ty
205 split args orig_ty ty = (reverse args, orig_ty)
210 ---------------------------------------------------------------------
215 mkTyConApp :: TyCon -> [GenType flexi] -> GenType flexi
217 | isFunTyCon tycon && length tys == 2
219 (ty1:ty2:_) -> FunTy ty1 ty2
222 = ASSERT(not (isSynTyCon tycon))
225 mkTyConTy :: TyCon -> GenType flexi
226 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
229 -- splitTyConApp "looks through" synonyms, because they don't
230 -- mean a distinct type, but all other type-constructor applications
231 -- including functions are returned as Just ..
233 splitTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi])
234 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
235 splitTyConApp_maybe (FunTy arg res) = Just (mkFunTyCon, [arg,res])
236 splitTyConApp_maybe (SynTy _ ty) = splitTyConApp_maybe ty
237 splitTyConApp_maybe other = Nothing
239 -- splitAlgTyConApp_maybe looks for
240 -- *saturated* applications of *algebraic* data types
241 -- "Algebraic" => newtype, data type, or dictionary (not function types)
242 -- We return the constructors too.
244 splitAlgTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi], [Id])
245 splitAlgTyConApp_maybe (TyConApp tc tys)
247 tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
248 splitAlgTyConApp_maybe (SynTy _ ty) = splitAlgTyConApp_maybe ty
249 splitAlgTyConApp_maybe other = Nothing
251 splitAlgTyConApp :: GenType flexi -> (TyCon, [GenType flexi], [Id])
252 -- Here the "algebraic" property is an *assertion*
253 splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
254 (tc, tys, tyConDataCons tc)
255 splitAlgTyConApp (SynTy _ ty) = splitAlgTyConApp ty
258 y"Dictionary" types are just ordinary data types, but you can
259 tell from the type constructor whether it's a dictionary or not.
262 mkDictTy :: Class -> [GenType flexi] -> GenType flexi
263 mkDictTy clas tys = TyConApp (classTyCon clas) tys
265 splitDictTy_maybe :: GenType flexi -> Maybe (Class, [GenType flexi])
266 splitDictTy_maybe (TyConApp tc tys)
267 | maybeToBool maybe_class
268 && tyConArity tc == length tys = Just (clas, tys)
270 maybe_class = tyConClass_maybe tc
271 Just clas = maybe_class
273 splitDictTy_maybe (SynTy _ ty) = splitDictTy_maybe ty
274 splitDictTy_maybe other = Nothing
276 isDictTy :: GenType flexi -> Bool
277 -- This version is slightly more efficient than (maybeToBool . splitDictTy)
278 isDictTy (TyConApp tc tys)
279 | maybeToBool (tyConClass_maybe tc)
280 && tyConArity tc == length tys
282 isDictTy (SynTy _ ty) = isDictTy ty
283 isDictTy other = False
287 ---------------------------------------------------------------------
292 mkSynTy syn_tycon tys
293 = ASSERT(isSynTyCon syn_tycon)
294 SynTy (TyConApp syn_tycon tys)
295 (instantiateTauTy (zipTyVarEnv tyvars tys) body)
297 (tyvars, body) = getSynTyConDefn syn_tycon
299 isSynTy (SynTy _ _) = True
300 isSynTy other = False
303 Notes on type synonyms
304 ~~~~~~~~~~~~~~~~~~~~~~
305 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
306 to return type synonyms whereever possible. Thus
311 splitFunTys (a -> Foo a) = ([a], Foo a)
314 The reason is that we then get better (shorter) type signatures in
315 interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
320 ---------------------------------------------------------------------
325 mkForAllTy = ForAllTy
327 mkForAllTys :: [GenTyVar flexi] -> GenType flexi -> GenType flexi
328 mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
330 splitForAllTy_maybe :: GenType flexi -> Maybe (GenTyVar flexi, GenType flexi)
331 splitForAllTy_maybe (SynTy _ ty) = splitForAllTy_maybe ty
332 splitForAllTy_maybe (ForAllTy tyvar ty) = Just(tyvar, ty)
333 splitForAllTy_maybe _ = Nothing
335 splitForAllTys :: GenType flexi -> ([GenTyVar flexi], GenType flexi)
336 splitForAllTys ty = split ty ty []
338 split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
339 split orig_ty (SynTy _ ty) tvs = split orig_ty ty tvs
340 split orig_ty t tvs = (reverse tvs, orig_ty)
345 applyTy :: GenType flexi -> GenType flexi -> GenType flexi
346 applyTy (SynTy _ fun) arg = applyTy fun arg
347 applyTy (ForAllTy tv ty) arg = instantiateTy (mkTyVarEnv [(tv,arg)]) ty
348 applyTy other arg = panic "applyTy"
352 %************************************************************************
354 \subsection{Stuff to do with the source-language types}
356 %************************************************************************
361 type ThetaType = [(Class, [Type])]
362 type SigmaType = Type
365 @isTauTy@ tests for nested for-alls.
368 isTauTy :: GenType flexi -> Bool
369 isTauTy (TyVarTy v) = True
370 isTauTy (TyConApp _ tys) = all isTauTy tys
371 isTauTy (AppTy a b) = isTauTy a && isTauTy b
372 isTauTy (FunTy a b) = isTauTy a && isTauTy b
373 isTauTy (SynTy _ ty) = isTauTy ty
374 isTauTy other = False
378 mkRhoTy :: [(Class, [GenType flexi])] -> GenType flexi -> GenType flexi
379 mkRhoTy theta ty = foldr (\(c,t) r -> FunTy (mkDictTy c t) r) ty theta
381 splitRhoTy :: GenType flexi -> ([(Class, [GenType flexi])], GenType flexi)
382 splitRhoTy ty = split ty ty []
384 split orig_ty (FunTy arg res) ts = case splitDictTy_maybe arg of
385 Just pair -> split res res (pair:ts)
386 Nothing -> (reverse ts, orig_ty)
387 split orig_ty (SynTy _ ty) ts = split orig_ty ty ts
388 split orig_ty ty ts = (reverse ts, orig_ty)
394 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
396 splitSigmaTy :: GenType flexi -> ([GenTyVar flexi], [(Class, [GenType flexi])], GenType flexi)
400 (tyvars,rho) = splitForAllTys ty
401 (theta,tau) = splitRhoTy rho
405 %************************************************************************
407 \subsection{Kinds and free variables}
409 %************************************************************************
411 ---------------------------------------------------------------------
412 Finding the kind of a type
413 ~~~~~~~~~~~~~~~~~~~~~~~~~~
415 typeKind :: GenType flexi -> Kind
417 typeKind (TyVarTy tyvar) = tyVarKind tyvar
418 typeKind (TyConApp tycon tys) = foldr (\_ k -> resultKind k) (tyConKind tycon) tys
419 typeKind (SynTy _ ty) = typeKind ty
420 typeKind (FunTy fun arg) = mkBoxedTypeKind
421 typeKind (AppTy fun arg) = resultKind (typeKind fun)
422 typeKind (ForAllTy _ _) = mkBoxedTypeKind
426 ---------------------------------------------------------------------
427 Free variables of a type
428 ~~~~~~~~~~~~~~~~~~~~~~~~
430 tyVarsOfType :: GenType flexi -> GenTyVarSet flexi
432 tyVarsOfType (TyVarTy tv) = unitTyVarSet tv
433 tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
434 tyVarsOfType (SynTy ty1 ty2) = tyVarsOfType ty1
435 tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res
436 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg
437 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar
439 tyVarsOfTypes :: [GenType flexi] -> GenTyVarSet flexi
440 tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
442 -- Find the free names of a type, including the type constructors and classes it mentions
443 namesOfType :: GenType flexi -> NameSet
444 namesOfType (TyVarTy tv) = unitNameSet (getName tv)
445 namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets`
447 namesOfType (SynTy ty1 ty2) = namesOfType ty1
448 namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
449 namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
450 namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
452 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
456 %************************************************************************
458 \subsection{Instantiating a type}
460 %************************************************************************
463 instantiateTy :: TyVarEnv (GenType flexi) -> GenType flexi -> GenType flexi
464 instantiateTauTy :: TyVarEnv (GenType flexi2) -> GenType flexi1 -> GenType flexi2
467 -- instantiateTy applies a type environment to a type.
468 -- It can handle shadowing; for example:
469 -- f = /\ t1 t2 -> \ d ->
470 -- letrec f' = /\ t1 -> \x -> ...(f' t1 x')...
472 -- Here, when we clone t1 to t1', say, we'll come across shadowing
473 -- when applying the clone environment to the type of f'.
475 -- As a sanity check, we should also check that name capture
476 -- doesn't occur, but that means keeping track of the free variables of the
477 -- range of the TyVarEnv, which I don't do just yet.
479 instantiateTy tenv ty
480 | isEmptyTyVarEnv tenv
486 go tenv ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of
489 go tenv (TyConApp tc tys) = TyConApp tc (map (go tenv) tys)
490 go tenv (SynTy ty1 ty2) = SynTy (go tenv ty1) (go tenv ty2)
491 go tenv (FunTy arg res) = FunTy (go tenv arg) (go tenv res)
492 go tenv (AppTy fun arg) = mkAppTy (go tenv fun) (go tenv arg)
493 go tenv (ForAllTy tv ty) = ForAllTy tv (go tenv' ty)
495 tenv' = case lookupTyVarEnv tenv tv of
497 Just _ -> delFromTyVarEnv tenv tv
499 -- instantiateTauTy works only (a) on types with no ForAlls,
500 -- and when (b) all the type variables are being instantiated
501 -- In return it is more polymorphic than instantiateTy
503 instantiateTauTy tenv ty = go ty
505 go ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of
506 Just ty -> ty -- Must succeed
507 go (TyConApp tc tys) = TyConApp tc (map go tys)
508 go (SynTy ty1 ty2) = SynTy (go ty1) (go ty2)
509 go (FunTy arg res) = FunTy (go arg) (go res)
510 go (AppTy fun arg) = mkAppTy (go fun) (go arg)
511 go (ForAllTy tv ty) = panic "instantiateTauTy"
514 instantiateThetaTy :: TyVarEnv Type -> ThetaType -> ThetaType
515 instantiateThetaTy tenv theta
516 = [(clas, map (instantiateTauTy tenv) tys) | (clas, tys) <- theta]
520 %************************************************************************
522 \subsection{Boxedness and pointedness}
524 %************************************************************************
527 *unboxed* iff its representation is other than a pointer
528 Unboxed types cannot instantiate a type variable
529 Unboxed types are always unpointed.
531 *unpointed* iff it can't be a thunk, and cannot have value bottom
532 An unpointed type may or may not be unboxed.
533 (E.g. Array# is unpointed, but boxed.)
534 An unpointed type *can* instantiate a type variable,
535 provided it is boxed.
537 *primitive* iff it is a built-in type that can't be expressed
540 Currently, all primitive types are unpointed, but that's not necessarily
541 the case. (E.g. Int could be primitive.)
544 isUnboxedType :: Type -> Bool
545 isUnboxedType ty = case typePrimRep ty of
549 -- Danger! Currently the unpointed types are precisely
550 -- the primitive ones, but that might not always be the case
551 isUnpointedType :: Type -> Bool
552 isUnpointedType ty = case splitTyConApp_maybe ty of
553 Just (tc, ty_args) -> isPrimTyCon tc
556 typePrimRep :: Type -> PrimRep
557 typePrimRep ty = case splitTyConApp_maybe ty of
558 Just (tc, ty_args) -> tyConPrimRep tc
563 %************************************************************************
565 \subsection{Matching on types}
567 %************************************************************************
569 Matching is a {\em unidirectional} process, matching a type against a
570 template (which is just a type with type variables in it). The
571 matcher assumes that there are no repeated type variables in the
572 template, so that it simply returns a mapping of type variables to
573 types. It also fails on nested foralls.
575 @matchTys@ matches corresponding elements of a list of templates and
579 matchTy :: GenType flexi1 -- Template
580 -> GenType flexi2 -- Proposed instance of template
581 -> Maybe (TyVarEnv (GenType flexi2)) -- Matching substitution
584 matchTys :: [GenType flexi1] -- Templates
585 -> [GenType flexi2] -- Proposed instance of template
586 -> Maybe (TyVarEnv (GenType flexi2), -- Matching substitution
587 [GenType flexi2]) -- Left over instance types
589 matchTy ty1 ty2 = match ty1 ty2 (\s -> Just s) emptyTyVarEnv
590 matchTys tys1 tys2 = match_list tys1 tys2 (\pr -> Just pr) emptyTyVarEnv
593 @match@ is the main function.
596 match :: GenType flexi1 -> GenType flexi2 -- Current match pair
597 -> (TyVarEnv (GenType flexi2) -> Maybe result) -- Continuation
598 -> TyVarEnv (GenType flexi2) -- Current substitution
601 -- When matching against a type variable, see if the variable
602 -- has already been bound. If so, check that what it's bound to
603 -- is the same as ty; if not, bind it and carry on.
605 match (TyVarTy v) ty k = \s -> case lookupTyVarEnv s v of
606 Nothing -> k (addToTyVarEnv s v ty)
607 Just ty' | ty' == ty -> k s -- Succeeds
608 | otherwise -> Nothing -- Fails
610 match (FunTy arg1 res1) (FunTy arg2 res2) k = match arg1 arg2 (match res1 res2 k)
611 match (AppTy fun1 arg1) (AppTy fun2 arg2) k = match fun1 fun2 (match arg1 arg2 k)
612 match (TyConApp tc1 tys1) (TyConApp tc2 tys2) k | tc1 == tc2
613 = match_list tys1 tys2 ( \(s,tys2') ->
620 -- With type synonyms, we have to be careful for the exact
621 -- same reasons as in the unifier. Please see the
622 -- considerable commentary there before changing anything
624 match (SynTy _ ty1) ty2 k = match ty1 ty2 k
625 match ty1 (SynTy _ ty2) k = match ty1 ty2 k
628 match _ _ _ = \s -> Nothing
630 match_list [] tys2 k = \s -> k (s, tys2)
631 match_list (ty1:tys1) [] k = panic "match_list"
632 match_list (ty1:tys1) (ty2:tys2) k = match ty1 ty2 (match_list tys1 tys2 k)
635 %************************************************************************
637 \subsection{Equality on types}
639 %************************************************************************
641 For the moment at least, type comparisons don't work if
642 there are embedded for-alls.
645 instance Eq (GenType flexi) where
646 ty1 == ty2 = case ty1 `cmpTy` ty2 of { EQ -> True; other -> False }
648 instance Ord (GenType flexi) where
649 compare ty1 ty2 = cmpTy ty1 ty2
651 cmpTy :: GenType flexi -> GenType flexi -> Ordering
653 = cmp emptyTyVarEnv ty1 ty2
655 -- The "env" maps type variables in ty1 to type variables in ty2
656 -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
657 -- we in effect substitute tv2 for tv1 in t1 before continuing
658 lookup env tv1 = case lookupTyVarEnv env tv1 of
663 cmp env (SynTy _ ty1) ty2 = cmp env ty1 ty2
664 cmp env ty1 (SynTy _ ty2) = cmp env ty1 ty2
666 -- Deal with equal constructors
667 cmp env (TyVarTy tv1) (TyVarTy tv2) = lookup env tv1 `compare` tv2
668 cmp env (AppTy f1 a1) (AppTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
669 cmp env (FunTy f1 a1) (FunTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
670 cmp env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmps env tys1 tys2)
671 cmp env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmp (addToTyVarEnv env tv1 tv2) t1 t2
673 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
674 cmp env (AppTy _ _) (TyVarTy _) = GT
676 cmp env (FunTy _ _) (TyVarTy _) = GT
677 cmp env (FunTy _ _) (AppTy _ _) = GT
679 cmp env (TyConApp _ _) (TyVarTy _) = GT
680 cmp env (TyConApp _ _) (AppTy _ _) = GT
681 cmp env (TyConApp _ _) (FunTy _ _) = GT
683 cmp env (ForAllTy _ _) other = GT
688 cmps env (t:ts) [] = GT
689 cmps env [] (t:ts) = LT
690 cmps env (t1:t1s) (t2:t2s) = cmp env t1 t2 `thenCmp` cmps env t1s t2s
695 %************************************************************************
699 %************************************************************************
704 showTypeCategory :: Type -> Char
706 {C,I,F,D} char, int, float, double
708 S other single-constructor type
709 {c,i,f,d} unboxed ditto
711 s *unpacked" single-cons...
717 + dictionary, unless it's a ...
720 M other (multi-constructor) data-con type
722 - reserved for others to mark as "uninteresting"
728 case splitTyConApp_maybe ty of
729 Nothing -> if maybeToBool (splitFunTy_maybe ty)
734 let utc = uniqueOf tycon in
735 if utc == charDataConKey then 'C'
736 else if utc == intDataConKey then 'I'
737 else if utc == floatDataConKey then 'F'
738 else if utc == doubleDataConKey then 'D'
739 else if utc == integerDataConKey then 'J'
740 else if utc == charPrimTyConKey then 'c'
741 else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
742 || utc == addrPrimTyConKey) then 'i'
743 else if utc == floatPrimTyConKey then 'f'
744 else if utc == doublePrimTyConKey then 'd'
745 else if isPrimTyCon tycon {- array, we hope -} then 'A'
746 else if isEnumerationTyCon tycon then 'E'
747 else if isTupleTyCon tycon then 'T'
748 else if maybeToBool (maybeTyConSingleCon tycon) then 'S'
749 else if utc == listTyConKey then 'L'
750 else 'M' -- oh, well...