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,
18 applyTy, applyTys, isForAllTy,
20 TauType, RhoType, SigmaType, ThetaType,
23 mkSigmaTy, splitSigmaTy,
25 isUnpointedType, isUnboxedType, typePrimRep,
29 tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind,
31 instantiateTy, instantiateTauTy, instantiateThetaTy, applyToTyVars,
36 #include "HsVersions.h"
38 import {-# SOURCE #-} Id ( Id )
41 import Class ( classTyCon, Class )
42 import Kind ( mkBoxedTypeKind, resultKind, Kind )
43 import TyCon ( mkFunTyCon, isFunTyCon, isEnumerationTyCon, isTupleTyCon, maybeTyConSingleCon,
44 isPrimTyCon, isAlgTyCon, isSynTyCon, tyConArity,
45 tyConKind, tyConDataCons, getSynTyConDefn,
46 tyConPrimRep, tyConClass_maybe, TyCon )
47 import TyVar ( GenTyVarSet, TyVarEnv, GenTyVar, TyVar,
48 tyVarKind, tyVarFlexi, emptyTyVarSet, unionTyVarSets, minusTyVarSet,
49 unitTyVarSet, lookupTyVarEnv, delFromTyVarEnv, zipTyVarEnv, mkTyVarEnv,
50 emptyTyVarEnv, isEmptyTyVarEnv, addToTyVarEnv )
51 import Name ( NamedThing(..),
52 NameSet(..), unionNameSets, emptyNameSet, unitNameSet, minusNameSet
56 import BasicTypes ( Unused )
57 import Maybes ( maybeToBool, assocMaybe )
58 import PrimRep ( PrimRep(..) )
59 import Unique -- quite a few *Keys
60 import Util ( thenCmp, panic, assertPanic )
65 %************************************************************************
67 \subsection{The data type}
69 %************************************************************************
73 type Type = GenType Unused -- Used after typechecker
75 data GenType flexi -- Parameterised over the "flexi" part of a type variable
76 = TyVarTy (GenTyVar flexi)
79 (GenType flexi) -- Function is *not* a TyConApp
82 | TyConApp -- Application of a TyCon
83 TyCon -- *Invariant* saturated appliations of FunTyCon and
84 -- synonyms have their own constructors, below.
85 [GenType flexi] -- Might not be saturated.
87 | FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2]
91 | SynTy -- Saturated application of a type synonym
92 (GenType flexi) -- The unexpanded version; always a TyConTy
93 (GenType flexi) -- The expanded version
97 (GenType flexi) -- TypeKind
101 %************************************************************************
103 \subsection{Constructor-specific functions}
105 %************************************************************************
108 ---------------------------------------------------------------------
112 mkTyVarTy :: GenTyVar flexi -> GenType flexi
115 mkTyVarTys :: [GenTyVar flexi] -> [GenType flexi]
116 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
118 getTyVar :: String -> GenType flexi -> GenTyVar flexi
119 getTyVar msg (TyVarTy tv) = tv
120 getTyVar msg (SynTy _ t) = getTyVar msg t
121 getTyVar msg other = panic ("getTyVar: " ++ msg)
123 getTyVar_maybe :: GenType flexi -> Maybe (GenTyVar flexi)
124 getTyVar_maybe (TyVarTy tv) = Just tv
125 getTyVar_maybe (SynTy _ t) = getTyVar_maybe t
126 getTyVar_maybe other = Nothing
128 isTyVarTy :: GenType flexi -> Bool
129 isTyVarTy (TyVarTy tv) = True
130 isTyVarTy (SynTy _ ty) = isTyVarTy ty
131 isTyVarTy other = False
135 ---------------------------------------------------------------------
138 We need to be pretty careful with AppTy to make sure we obey the
139 invariant that a TyConApp is always visibly so. mkAppTy maintains the
143 mkAppTy orig_ty1 orig_ty2 = mk_app orig_ty1
145 mk_app (SynTy _ ty1) = mk_app ty1
146 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
147 mk_app ty1 = AppTy orig_ty1 orig_ty2
149 mkAppTys :: GenType flexi -> [GenType flexi] -> GenType flexi
150 mkAppTys orig_ty1 [] = orig_ty1
151 -- This check for an empty list of type arguments
152 -- avoids the needless of a type synonym constructor.
153 -- For example: mkAppTys Rational []
154 -- returns to (Ratio Integer), which has needlessly lost
155 -- the Rational part.
156 mkAppTys orig_ty1 orig_tys2 = mk_app orig_ty1
158 mk_app (SynTy _ ty1) = mk_app ty1
159 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
160 mk_app ty1 = foldl AppTy orig_ty1 orig_tys2
162 splitAppTy :: GenType flexi -> (GenType flexi, GenType flexi)
163 splitAppTy (FunTy ty1 ty2) = (TyConApp mkFunTyCon [ty1], ty2)
164 splitAppTy (AppTy ty1 ty2) = (ty1, ty2)
165 splitAppTy (SynTy _ ty) = splitAppTy ty
166 splitAppTy (TyConApp tc tys) = split tys []
168 split [ty2] acc = (TyConApp tc (reverse acc), ty2)
169 split (ty:tys) acc = split tys (ty:acc)
170 splitAppTy other = panic "splitAppTy"
172 splitAppTys :: GenType flexi -> (GenType flexi, [GenType flexi])
173 splitAppTys ty = split ty ty []
175 split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
176 split orig_ty (SynTy _ ty) args = split orig_ty ty args
177 split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
178 (TyConApp mkFunTyCon [], [ty1,ty2])
179 split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
180 split orig_ty ty args = (orig_ty, args)
184 ---------------------------------------------------------------------
189 mkFunTy :: GenType flexi -> GenType flexi -> GenType flexi
190 mkFunTy arg res = FunTy arg res
192 mkFunTys :: [GenType flexi] -> GenType flexi -> GenType flexi
193 mkFunTys tys ty = foldr FunTy ty tys
195 splitFunTy_maybe :: GenType flexi -> Maybe (GenType flexi, GenType flexi)
196 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
197 splitFunTy_maybe (SynTy _ ty) = splitFunTy_maybe ty
198 splitFunTy_maybe other = Nothing
201 splitFunTys :: GenType flexi -> ([GenType flexi], GenType flexi)
202 splitFunTys ty = split [] ty ty
204 split args orig_ty (FunTy arg res) = split (arg:args) res res
205 split args orig_ty (SynTy _ ty) = split args orig_ty ty
206 split args orig_ty ty = (reverse args, orig_ty)
211 ---------------------------------------------------------------------
216 mkTyConApp :: TyCon -> [GenType flexi] -> GenType flexi
218 | isFunTyCon tycon && length tys == 2
220 (ty1:ty2:_) -> FunTy ty1 ty2
223 = ASSERT(not (isSynTyCon tycon))
226 mkTyConTy :: TyCon -> GenType flexi
227 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
230 -- splitTyConApp "looks through" synonyms, because they don't
231 -- mean a distinct type, but all other type-constructor applications
232 -- including functions are returned as Just ..
234 splitTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi])
235 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
236 splitTyConApp_maybe (FunTy arg res) = Just (mkFunTyCon, [arg,res])
237 splitTyConApp_maybe (SynTy _ ty) = splitTyConApp_maybe ty
238 splitTyConApp_maybe other = Nothing
240 -- splitAlgTyConApp_maybe looks for
241 -- *saturated* applications of *algebraic* data types
242 -- "Algebraic" => newtype, data type, or dictionary (not function types)
243 -- We return the constructors too.
245 splitAlgTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi], [Id])
246 splitAlgTyConApp_maybe (TyConApp tc tys)
248 tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
249 splitAlgTyConApp_maybe (SynTy _ ty) = splitAlgTyConApp_maybe ty
250 splitAlgTyConApp_maybe other = Nothing
252 splitAlgTyConApp :: GenType flexi -> (TyCon, [GenType flexi], [Id])
253 -- Here the "algebraic" property is an *assertion*
254 splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
255 (tc, tys, tyConDataCons tc)
256 splitAlgTyConApp (SynTy _ ty) = splitAlgTyConApp ty
259 "Dictionary" types are just ordinary data types, but you can
260 tell from the type constructor whether it's a dictionary or not.
263 mkDictTy :: Class -> [GenType flexi] -> GenType flexi
264 mkDictTy clas tys = TyConApp (classTyCon clas) tys
266 splitDictTy_maybe :: GenType flexi -> Maybe (Class, [GenType flexi])
267 splitDictTy_maybe (TyConApp tc tys)
268 | maybeToBool maybe_class
269 && tyConArity tc == length tys = Just (clas, tys)
271 maybe_class = tyConClass_maybe tc
272 Just clas = maybe_class
274 splitDictTy_maybe (SynTy _ ty) = splitDictTy_maybe ty
275 splitDictTy_maybe other = Nothing
277 isDictTy :: GenType flexi -> Bool
278 -- This version is slightly more efficient than (maybeToBool . splitDictTy)
279 isDictTy (TyConApp tc tys)
280 | maybeToBool (tyConClass_maybe tc)
281 && tyConArity tc == length tys
283 isDictTy (SynTy _ ty) = isDictTy ty
284 isDictTy other = False
288 ---------------------------------------------------------------------
293 mkSynTy syn_tycon tys
294 = ASSERT(isSynTyCon syn_tycon)
295 SynTy (TyConApp syn_tycon tys)
296 (instantiateTauTy (zipTyVarEnv tyvars tys) body)
298 (tyvars, body) = getSynTyConDefn syn_tycon
300 isSynTy (SynTy _ _) = True
301 isSynTy other = False
304 Notes on type synonyms
305 ~~~~~~~~~~~~~~~~~~~~~~
306 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
307 to return type synonyms whereever possible. Thus
312 splitFunTys (a -> Foo a) = ([a], Foo a)
315 The reason is that we then get better (shorter) type signatures in
316 interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
321 ---------------------------------------------------------------------
326 mkForAllTy = ForAllTy
328 mkForAllTys :: [GenTyVar flexi] -> GenType flexi -> GenType flexi
329 mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
331 splitForAllTy_maybe :: GenType flexi -> Maybe (GenTyVar flexi, GenType flexi)
332 splitForAllTy_maybe (SynTy _ ty) = splitForAllTy_maybe ty
333 splitForAllTy_maybe (ForAllTy tyvar ty) = Just(tyvar, ty)
334 splitForAllTy_maybe _ = Nothing
336 isForAllTy :: GenType flexi -> Bool
337 isForAllTy (SynTy _ ty) = isForAllTy ty
338 isForAllTy (ForAllTy tyvar ty) = True
341 splitForAllTys :: GenType flexi -> ([GenTyVar flexi], GenType flexi)
342 splitForAllTys ty = split ty ty []
344 split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
345 split orig_ty (SynTy _ ty) tvs = split orig_ty ty tvs
346 split orig_ty t tvs = (reverse tvs, orig_ty)
351 applyTy :: GenType flexi -> GenType flexi -> GenType flexi
352 applyTy (SynTy _ fun) arg = applyTy fun arg
353 applyTy (ForAllTy tv ty) arg = instantiateTy (mkTyVarEnv [(tv,arg)]) ty
354 applyTy other arg = panic "applyTy"
356 applyTys :: GenType flexi -> [GenType flexi] -> GenType flexi
357 applyTys fun_ty arg_tys
358 = go [] fun_ty arg_tys
360 go env ty [] = instantiateTy (mkTyVarEnv env) ty
361 go env (SynTy _ fun) args = go env fun args
362 go env (ForAllTy tv ty) (arg:args) = go ((tv,arg):env) ty args
363 go env other args = panic "applyTys"
367 %************************************************************************
369 \subsection{Stuff to do with the source-language types}
371 %************************************************************************
376 type ThetaType = [(Class, [Type])]
377 type SigmaType = Type
380 @isTauTy@ tests for nested for-alls.
383 isTauTy :: GenType flexi -> Bool
384 isTauTy (TyVarTy v) = True
385 isTauTy (TyConApp _ tys) = all isTauTy tys
386 isTauTy (AppTy a b) = isTauTy a && isTauTy b
387 isTauTy (FunTy a b) = isTauTy a && isTauTy b
388 isTauTy (SynTy _ ty) = isTauTy ty
389 isTauTy other = False
393 mkRhoTy :: [(Class, [GenType flexi])] -> GenType flexi -> GenType flexi
394 mkRhoTy theta ty = foldr (\(c,t) r -> FunTy (mkDictTy c t) r) ty theta
396 splitRhoTy :: GenType flexi -> ([(Class, [GenType flexi])], GenType flexi)
397 splitRhoTy ty = split ty ty []
399 split orig_ty (FunTy arg res) ts = case splitDictTy_maybe arg of
400 Just pair -> split res res (pair:ts)
401 Nothing -> (reverse ts, orig_ty)
402 split orig_ty (SynTy _ ty) ts = split orig_ty ty ts
403 split orig_ty ty ts = (reverse ts, orig_ty)
409 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
411 splitSigmaTy :: GenType flexi -> ([GenTyVar flexi], [(Class, [GenType flexi])], GenType flexi)
415 (tyvars,rho) = splitForAllTys ty
416 (theta,tau) = splitRhoTy rho
420 %************************************************************************
422 \subsection{Kinds and free variables}
424 %************************************************************************
426 ---------------------------------------------------------------------
427 Finding the kind of a type
428 ~~~~~~~~~~~~~~~~~~~~~~~~~~
430 typeKind :: GenType flexi -> Kind
432 typeKind (TyVarTy tyvar) = tyVarKind tyvar
433 typeKind (TyConApp tycon tys) = foldr (\_ k -> resultKind k) (tyConKind tycon) tys
434 typeKind (SynTy _ ty) = typeKind ty
435 typeKind (FunTy fun arg) = mkBoxedTypeKind
436 typeKind (AppTy fun arg) = resultKind (typeKind fun)
437 typeKind (ForAllTy _ _) = mkBoxedTypeKind
441 ---------------------------------------------------------------------
442 Free variables of a type
443 ~~~~~~~~~~~~~~~~~~~~~~~~
445 tyVarsOfType :: GenType flexi -> GenTyVarSet flexi
447 tyVarsOfType (TyVarTy tv) = unitTyVarSet tv
448 tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
449 tyVarsOfType (SynTy ty1 ty2) = tyVarsOfType ty1
450 tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res
451 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg
452 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar
454 tyVarsOfTypes :: [GenType flexi] -> GenTyVarSet flexi
455 tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
457 -- Find the free names of a type, including the type constructors and classes it mentions
458 namesOfType :: GenType flexi -> NameSet
459 namesOfType (TyVarTy tv) = unitNameSet (getName tv)
460 namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets`
462 namesOfType (SynTy ty1 ty2) = namesOfType ty1
463 namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
464 namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
465 namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
467 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
471 %************************************************************************
473 \subsection{Instantiating a type}
475 %************************************************************************
478 instantiateTy :: TyVarEnv (GenType flexi) -> GenType flexi -> GenType flexi
479 instantiateTauTy :: TyVarEnv (GenType flexi2) -> GenType flexi1 -> GenType flexi2
482 -- instantiateTy applies a type environment to a type.
483 -- It can handle shadowing; for example:
484 -- f = /\ t1 t2 -> \ d ->
485 -- letrec f' = /\ t1 -> \x -> ...(f' t1 x')...
487 -- Here, when we clone t1 to t1', say, we'll come across shadowing
488 -- when applying the clone environment to the type of f'.
490 -- As a sanity check, we should also check that name capture
491 -- doesn't occur, but that means keeping track of the free variables of the
492 -- range of the TyVarEnv, which I don't do just yet.
494 instantiateTy tenv ty
495 | isEmptyTyVarEnv tenv
501 go tenv ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of
504 go tenv (TyConApp tc tys) = TyConApp tc (map (go tenv) tys)
505 go tenv (SynTy ty1 ty2) = SynTy (go tenv ty1) (go tenv ty2)
506 go tenv (FunTy arg res) = FunTy (go tenv arg) (go tenv res)
507 go tenv (AppTy fun arg) = mkAppTy (go tenv fun) (go tenv arg)
508 go tenv (ForAllTy tv ty) = ForAllTy tv (go tenv' ty)
510 tenv' = case lookupTyVarEnv tenv tv of
512 Just _ -> delFromTyVarEnv tenv tv
514 -- instantiateTauTy works only (a) on types with no ForAlls,
515 -- and when (b) all the type variables are being instantiated
516 -- In return it is more polymorphic than instantiateTy
518 instantiateTauTy tenv ty = applyToTyVars lookup ty
520 lookup tv = case lookupTyVarEnv tenv tv of
521 Just ty -> ty -- Must succeed
524 instantiateThetaTy :: TyVarEnv Type -> ThetaType -> ThetaType
525 instantiateThetaTy tenv theta
526 = [(clas, map (instantiateTauTy tenv) tys) | (clas, tys) <- theta]
528 applyToTyVars :: (GenTyVar flexi1 -> GenType flexi2)
531 applyToTyVars f ty = go ty
533 go (TyVarTy tv) = f tv
534 go (TyConApp tc tys) = TyConApp tc (map go tys)
535 go (SynTy ty1 ty2) = SynTy (go ty1) (go ty2)
536 go (FunTy arg res) = FunTy (go arg) (go res)
537 go (AppTy fun arg) = mkAppTy (go fun) (go arg)
538 go (ForAllTy tv ty) = panic "instantiateTauTy"
542 %************************************************************************
544 \subsection{Boxedness and pointedness}
546 %************************************************************************
549 *unboxed* iff its representation is other than a pointer
550 Unboxed types cannot instantiate a type variable
551 Unboxed types are always unpointed.
553 *unpointed* iff it can't be a thunk, and cannot have value bottom
554 An unpointed type may or may not be unboxed.
555 (E.g. Array# is unpointed, but boxed.)
556 An unpointed type *can* instantiate a type variable,
557 provided it is boxed.
559 *primitive* iff it is a built-in type that can't be expressed
562 Currently, all primitive types are unpointed, but that's not necessarily
563 the case. (E.g. Int could be primitive.)
566 isUnboxedType :: Type -> Bool
567 isUnboxedType ty = case typePrimRep ty of
571 -- Danger! Currently the unpointed types are precisely
572 -- the primitive ones, but that might not always be the case
573 isUnpointedType :: Type -> Bool
574 isUnpointedType ty = case splitTyConApp_maybe ty of
575 Just (tc, ty_args) -> isPrimTyCon tc
578 typePrimRep :: Type -> PrimRep
579 typePrimRep ty = case splitTyConApp_maybe ty of
580 Just (tc, ty_args) -> tyConPrimRep tc
585 %************************************************************************
587 \subsection{Matching on types}
589 %************************************************************************
591 Matching is a {\em unidirectional} process, matching a type against a
592 template (which is just a type with type variables in it). The
593 matcher assumes that there are no repeated type variables in the
594 template, so that it simply returns a mapping of type variables to
595 types. It also fails on nested foralls.
597 @matchTys@ matches corresponding elements of a list of templates and
601 matchTy :: GenType Bool -- Template
602 -> GenType flexi -- Proposed instance of template
603 -> Maybe (TyVarEnv (GenType flexi)) -- Matching substitution
606 matchTys :: [GenType Bool] -- Templates
607 -> [GenType flexi] -- Proposed instance of template
608 -> Maybe (TyVarEnv (GenType flexi), -- Matching substitution
609 [GenType flexi]) -- Left over instance types
611 matchTy ty1 ty2 = match ty1 ty2 (\s -> Just s) emptyTyVarEnv
612 matchTys tys1 tys2 = match_list tys1 tys2 (\pr -> Just pr) emptyTyVarEnv
615 @match@ is the main function.
618 match :: GenType Bool -> GenType flexi -- Current match pair
619 -> (TyVarEnv (GenType flexi) -> Maybe result) -- Continuation
620 -> TyVarEnv (GenType flexi) -- Current substitution
623 -- When matching against a type variable, see if the variable
624 -- has already been bound. If so, check that what it's bound to
625 -- is the same as ty; if not, bind it and carry on.
627 match (TyVarTy v) ty k = \s -> if tyVarFlexi v then
628 -- v is a template variable
629 case lookupTyVarEnv s v of
630 Nothing -> k (addToTyVarEnv s v ty)
631 Just ty' | ty' == ty -> k s -- Succeeds
632 | otherwise -> Nothing -- Fails
634 -- v is not a template variable; ty had better match
635 -- Can't use (==) because types differ
637 TyVarTy v' | uniqueOf v == uniqueOf v'
639 other -> Nothing -- Failure
641 match (FunTy arg1 res1) (FunTy arg2 res2) k = match arg1 arg2 (match res1 res2 k)
642 match (AppTy fun1 arg1) (AppTy fun2 arg2) k = match fun1 fun2 (match arg1 arg2 k)
643 match (TyConApp tc1 tys1) (TyConApp tc2 tys2) k | tc1 == tc2
644 = match_list tys1 tys2 ( \(s,tys2') ->
651 -- With type synonyms, we have to be careful for the exact
652 -- same reasons as in the unifier. Please see the
653 -- considerable commentary there before changing anything
655 match (SynTy _ ty1) ty2 k = match ty1 ty2 k
656 match ty1 (SynTy _ ty2) k = match ty1 ty2 k
659 match _ _ _ = \s -> Nothing
661 match_list [] tys2 k = \s -> k (s, tys2)
662 match_list (ty1:tys1) [] k = \s -> Nothing -- Not enough arg tys => failure
663 match_list (ty1:tys1) (ty2:tys2) k = match ty1 ty2 (match_list tys1 tys2 k)
666 %************************************************************************
668 \subsection{Equality on types}
670 %************************************************************************
672 For the moment at least, type comparisons don't work if
673 there are embedded for-alls.
676 instance Eq (GenType flexi) where
677 ty1 == ty2 = case ty1 `cmpTy` ty2 of { EQ -> True; other -> False }
679 instance Ord (GenType flexi) where
680 compare ty1 ty2 = cmpTy ty1 ty2
682 cmpTy :: GenType flexi -> GenType flexi -> Ordering
684 = cmp emptyTyVarEnv ty1 ty2
686 -- The "env" maps type variables in ty1 to type variables in ty2
687 -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
688 -- we in effect substitute tv2 for tv1 in t1 before continuing
689 lookup env tv1 = case lookupTyVarEnv env tv1 of
694 cmp env (SynTy _ ty1) ty2 = cmp env ty1 ty2
695 cmp env ty1 (SynTy _ ty2) = cmp env ty1 ty2
697 -- Deal with equal constructors
698 cmp env (TyVarTy tv1) (TyVarTy tv2) = lookup env tv1 `compare` tv2
699 cmp env (AppTy f1 a1) (AppTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
700 cmp env (FunTy f1 a1) (FunTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
701 cmp env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmps env tys1 tys2)
702 cmp env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmp (addToTyVarEnv env tv1 tv2) t1 t2
704 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
705 cmp env (AppTy _ _) (TyVarTy _) = GT
707 cmp env (FunTy _ _) (TyVarTy _) = GT
708 cmp env (FunTy _ _) (AppTy _ _) = GT
710 cmp env (TyConApp _ _) (TyVarTy _) = GT
711 cmp env (TyConApp _ _) (AppTy _ _) = GT
712 cmp env (TyConApp _ _) (FunTy _ _) = GT
714 cmp env (ForAllTy _ _) other = GT
719 cmps env (t:ts) [] = GT
720 cmps env [] (t:ts) = LT
721 cmps env (t1:t1s) (t2:t2s) = cmp env t1 t2 `thenCmp` cmps env t1s t2s
726 %************************************************************************
730 %************************************************************************
735 showTypeCategory :: Type -> Char
737 {C,I,F,D} char, int, float, double
739 S other single-constructor type
740 {c,i,f,d} unboxed ditto
742 s *unpacked" single-cons...
748 + dictionary, unless it's a ...
751 M other (multi-constructor) data-con type
753 - reserved for others to mark as "uninteresting"
759 case splitTyConApp_maybe ty of
760 Nothing -> if maybeToBool (splitFunTy_maybe ty)
765 let utc = uniqueOf tycon in
766 if utc == charDataConKey then 'C'
767 else if utc == intDataConKey then 'I'
768 else if utc == floatDataConKey then 'F'
769 else if utc == doubleDataConKey then 'D'
770 else if utc == integerDataConKey then 'J'
771 else if utc == charPrimTyConKey then 'c'
772 else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
773 || utc == addrPrimTyConKey) then 'i'
774 else if utc == floatPrimTyConKey then 'f'
775 else if utc == doublePrimTyConKey then 'd'
776 else if isPrimTyCon tycon {- array, we hope -} then 'A'
777 else if isEnumerationTyCon tycon then 'E'
778 else if isTupleTyCon tycon then 'T'
779 else if maybeToBool (maybeTyConSingleCon tycon) then 'S'
780 else if utc == listTyConKey then 'L'
781 else 'M' -- oh, well...