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(..),
53 unionNameSets, emptyNameSet, unitNameSet, minusNameSet
57 import BasicTypes ( Unused )
58 import Maybes ( maybeToBool, assocMaybe )
59 import PrimRep ( PrimRep(..) )
60 import Unique -- quite a few *Keys
61 import Util ( thenCmp, panic, assertPanic )
66 %************************************************************************
68 \subsection{The data type}
70 %************************************************************************
74 type Type = GenType Unused -- Used after typechecker
76 data GenType flexi -- Parameterised over the "flexi" part of a type variable
77 = TyVarTy (GenTyVar flexi)
80 (GenType flexi) -- Function is *not* a TyConApp
83 | TyConApp -- Application of a TyCon
84 TyCon -- *Invariant* saturated appliations of FunTyCon and
85 -- synonyms have their own constructors, below.
86 [GenType flexi] -- Might not be saturated.
88 | FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2]
92 | SynTy -- Saturated application of a type synonym
93 (GenType flexi) -- The unexpanded version; always a TyConTy
94 (GenType flexi) -- The expanded version
98 (GenType flexi) -- TypeKind
102 %************************************************************************
104 \subsection{Constructor-specific functions}
106 %************************************************************************
109 ---------------------------------------------------------------------
113 mkTyVarTy :: GenTyVar flexi -> GenType flexi
116 mkTyVarTys :: [GenTyVar flexi] -> [GenType flexi]
117 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
119 getTyVar :: String -> GenType flexi -> GenTyVar flexi
120 getTyVar msg (TyVarTy tv) = tv
121 getTyVar msg (SynTy _ t) = getTyVar msg t
122 getTyVar msg other = panic ("getTyVar: " ++ msg)
124 getTyVar_maybe :: GenType flexi -> Maybe (GenTyVar flexi)
125 getTyVar_maybe (TyVarTy tv) = Just tv
126 getTyVar_maybe (SynTy _ t) = getTyVar_maybe t
127 getTyVar_maybe other = Nothing
129 isTyVarTy :: GenType flexi -> Bool
130 isTyVarTy (TyVarTy tv) = True
131 isTyVarTy (SynTy _ ty) = isTyVarTy ty
132 isTyVarTy other = False
136 ---------------------------------------------------------------------
139 We need to be pretty careful with AppTy to make sure we obey the
140 invariant that a TyConApp is always visibly so. mkAppTy maintains the
144 mkAppTy orig_ty1 orig_ty2 = mk_app orig_ty1
146 mk_app (SynTy _ ty1) = mk_app ty1
147 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
148 mk_app ty1 = AppTy orig_ty1 orig_ty2
150 mkAppTys :: GenType flexi -> [GenType flexi] -> GenType flexi
151 mkAppTys orig_ty1 [] = orig_ty1
152 -- This check for an empty list of type arguments
153 -- avoids the needless of a type synonym constructor.
154 -- For example: mkAppTys Rational []
155 -- returns to (Ratio Integer), which has needlessly lost
156 -- the Rational part.
157 mkAppTys orig_ty1 orig_tys2 = mk_app orig_ty1
159 mk_app (SynTy _ ty1) = mk_app ty1
160 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
161 mk_app ty1 = foldl AppTy orig_ty1 orig_tys2
163 splitAppTy :: GenType flexi -> (GenType flexi, GenType flexi)
164 splitAppTy (FunTy ty1 ty2) = (TyConApp mkFunTyCon [ty1], ty2)
165 splitAppTy (AppTy ty1 ty2) = (ty1, ty2)
166 splitAppTy (SynTy _ ty) = splitAppTy ty
167 splitAppTy (TyConApp tc tys) = split tys []
169 split [ty2] acc = (TyConApp tc (reverse acc), ty2)
170 split (ty:tys) acc = split tys (ty:acc)
171 splitAppTy other = panic "splitAppTy"
173 splitAppTys :: GenType flexi -> (GenType flexi, [GenType flexi])
174 splitAppTys ty = split ty ty []
176 split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
177 split orig_ty (SynTy _ ty) args = split orig_ty ty args
178 split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
179 (TyConApp mkFunTyCon [], [ty1,ty2])
180 split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
181 split orig_ty ty args = (orig_ty, args)
185 ---------------------------------------------------------------------
190 mkFunTy :: GenType flexi -> GenType flexi -> GenType flexi
191 mkFunTy arg res = FunTy arg res
193 mkFunTys :: [GenType flexi] -> GenType flexi -> GenType flexi
194 mkFunTys tys ty = foldr FunTy ty tys
196 splitFunTy_maybe :: GenType flexi -> Maybe (GenType flexi, GenType flexi)
197 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
198 splitFunTy_maybe (SynTy _ ty) = splitFunTy_maybe ty
199 splitFunTy_maybe other = Nothing
202 splitFunTys :: GenType flexi -> ([GenType flexi], GenType flexi)
203 splitFunTys ty = split [] ty ty
205 split args orig_ty (FunTy arg res) = split (arg:args) res res
206 split args orig_ty (SynTy _ ty) = split args orig_ty ty
207 split args orig_ty ty = (reverse args, orig_ty)
212 ---------------------------------------------------------------------
217 mkTyConApp :: TyCon -> [GenType flexi] -> GenType flexi
219 | isFunTyCon tycon && length tys == 2
221 (ty1:ty2:_) -> FunTy ty1 ty2
224 = ASSERT(not (isSynTyCon tycon))
227 mkTyConTy :: TyCon -> GenType flexi
228 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
231 -- splitTyConApp "looks through" synonyms, because they don't
232 -- mean a distinct type, but all other type-constructor applications
233 -- including functions are returned as Just ..
235 splitTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi])
236 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
237 splitTyConApp_maybe (FunTy arg res) = Just (mkFunTyCon, [arg,res])
238 splitTyConApp_maybe (SynTy _ ty) = splitTyConApp_maybe ty
239 splitTyConApp_maybe other = Nothing
241 -- splitAlgTyConApp_maybe looks for
242 -- *saturated* applications of *algebraic* data types
243 -- "Algebraic" => newtype, data type, or dictionary (not function types)
244 -- We return the constructors too.
246 splitAlgTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi], [Id])
247 splitAlgTyConApp_maybe (TyConApp tc tys)
249 tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
250 splitAlgTyConApp_maybe (SynTy _ ty) = splitAlgTyConApp_maybe ty
251 splitAlgTyConApp_maybe other = Nothing
253 splitAlgTyConApp :: GenType flexi -> (TyCon, [GenType flexi], [Id])
254 -- Here the "algebraic" property is an *assertion*
255 splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
256 (tc, tys, tyConDataCons tc)
257 splitAlgTyConApp (SynTy _ ty) = splitAlgTyConApp ty
260 "Dictionary" types are just ordinary data types, but you can
261 tell from the type constructor whether it's a dictionary or not.
264 mkDictTy :: Class -> [GenType flexi] -> GenType flexi
265 mkDictTy clas tys = TyConApp (classTyCon clas) tys
267 splitDictTy_maybe :: GenType flexi -> Maybe (Class, [GenType flexi])
268 splitDictTy_maybe (TyConApp tc tys)
269 | maybeToBool maybe_class
270 && tyConArity tc == length tys = Just (clas, tys)
272 maybe_class = tyConClass_maybe tc
273 Just clas = maybe_class
275 splitDictTy_maybe (SynTy _ ty) = splitDictTy_maybe ty
276 splitDictTy_maybe other = Nothing
278 isDictTy :: GenType flexi -> Bool
279 -- This version is slightly more efficient than (maybeToBool . splitDictTy)
280 isDictTy (TyConApp tc tys)
281 | maybeToBool (tyConClass_maybe tc)
282 && tyConArity tc == length tys
284 isDictTy (SynTy _ ty) = isDictTy ty
285 isDictTy other = False
289 ---------------------------------------------------------------------
294 mkSynTy syn_tycon tys
295 = ASSERT(isSynTyCon syn_tycon)
296 SynTy (TyConApp syn_tycon tys)
297 (instantiateTauTy (zipTyVarEnv tyvars tys) body)
299 (tyvars, body) = getSynTyConDefn syn_tycon
301 isSynTy (SynTy _ _) = True
302 isSynTy other = False
305 Notes on type synonyms
306 ~~~~~~~~~~~~~~~~~~~~~~
307 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
308 to return type synonyms whereever possible. Thus
313 splitFunTys (a -> Foo a) = ([a], Foo a)
316 The reason is that we then get better (shorter) type signatures in
317 interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
322 ---------------------------------------------------------------------
327 mkForAllTy = ForAllTy
329 mkForAllTys :: [GenTyVar flexi] -> GenType flexi -> GenType flexi
330 mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
332 splitForAllTy_maybe :: GenType flexi -> Maybe (GenTyVar flexi, GenType flexi)
333 splitForAllTy_maybe (SynTy _ ty) = splitForAllTy_maybe ty
334 splitForAllTy_maybe (ForAllTy tyvar ty) = Just(tyvar, ty)
335 splitForAllTy_maybe _ = Nothing
337 isForAllTy :: GenType flexi -> Bool
338 isForAllTy (SynTy _ ty) = isForAllTy ty
339 isForAllTy (ForAllTy tyvar ty) = True
342 splitForAllTys :: GenType flexi -> ([GenTyVar flexi], GenType flexi)
343 splitForAllTys ty = split ty ty []
345 split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
346 split orig_ty (SynTy _ ty) tvs = split orig_ty ty tvs
347 split orig_ty t tvs = (reverse tvs, orig_ty)
352 applyTy :: GenType flexi -> GenType flexi -> GenType flexi
353 applyTy (SynTy _ fun) arg = applyTy fun arg
354 applyTy (ForAllTy tv ty) arg = instantiateTy (mkTyVarEnv [(tv,arg)]) ty
355 applyTy other arg = panic "applyTy"
357 applyTys :: GenType flexi -> [GenType flexi] -> GenType flexi
358 applyTys fun_ty arg_tys
359 = go [] fun_ty arg_tys
361 go env ty [] = instantiateTy (mkTyVarEnv env) ty
362 go env (SynTy _ fun) args = go env fun args
363 go env (ForAllTy tv ty) (arg:args) = go ((tv,arg):env) ty args
364 go env other args = panic "applyTys"
368 %************************************************************************
370 \subsection{Stuff to do with the source-language types}
372 %************************************************************************
377 type ThetaType = [(Class, [Type])]
378 type SigmaType = Type
381 @isTauTy@ tests for nested for-alls.
384 isTauTy :: GenType flexi -> Bool
385 isTauTy (TyVarTy v) = True
386 isTauTy (TyConApp _ tys) = all isTauTy tys
387 isTauTy (AppTy a b) = isTauTy a && isTauTy b
388 isTauTy (FunTy a b) = isTauTy a && isTauTy b
389 isTauTy (SynTy _ ty) = isTauTy ty
390 isTauTy other = False
394 mkRhoTy :: [(Class, [GenType flexi])] -> GenType flexi -> GenType flexi
395 mkRhoTy theta ty = foldr (\(c,t) r -> FunTy (mkDictTy c t) r) ty theta
397 splitRhoTy :: GenType flexi -> ([(Class, [GenType flexi])], GenType flexi)
398 splitRhoTy ty = split ty ty []
400 split orig_ty (FunTy arg res) ts = case splitDictTy_maybe arg of
401 Just pair -> split res res (pair:ts)
402 Nothing -> (reverse ts, orig_ty)
403 split orig_ty (SynTy _ ty) ts = split orig_ty ty ts
404 split orig_ty ty ts = (reverse ts, orig_ty)
410 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
412 splitSigmaTy :: GenType flexi -> ([GenTyVar flexi], [(Class, [GenType flexi])], GenType flexi)
416 (tyvars,rho) = splitForAllTys ty
417 (theta,tau) = splitRhoTy rho
421 %************************************************************************
423 \subsection{Kinds and free variables}
425 %************************************************************************
427 ---------------------------------------------------------------------
428 Finding the kind of a type
429 ~~~~~~~~~~~~~~~~~~~~~~~~~~
431 typeKind :: GenType flexi -> Kind
433 typeKind (TyVarTy tyvar) = tyVarKind tyvar
434 typeKind (TyConApp tycon tys) = foldr (\_ k -> resultKind k) (tyConKind tycon) tys
435 typeKind (SynTy _ ty) = typeKind ty
436 typeKind (FunTy fun arg) = mkBoxedTypeKind
437 typeKind (AppTy fun arg) = resultKind (typeKind fun)
438 typeKind (ForAllTy _ _) = mkBoxedTypeKind
442 ---------------------------------------------------------------------
443 Free variables of a type
444 ~~~~~~~~~~~~~~~~~~~~~~~~
446 tyVarsOfType :: GenType flexi -> GenTyVarSet flexi
448 tyVarsOfType (TyVarTy tv) = unitTyVarSet tv
449 tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
450 tyVarsOfType (SynTy ty1 ty2) = tyVarsOfType ty1
451 tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res
452 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg
453 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar
455 tyVarsOfTypes :: [GenType flexi] -> GenTyVarSet flexi
456 tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
458 -- Find the free names of a type, including the type constructors and classes it mentions
459 namesOfType :: GenType flexi -> NameSet
460 namesOfType (TyVarTy tv) = unitNameSet (getName tv)
461 namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets`
463 namesOfType (SynTy ty1 ty2) = namesOfType ty1
464 namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
465 namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
466 namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
468 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
472 %************************************************************************
474 \subsection{Instantiating a type}
476 %************************************************************************
479 instantiateTy :: TyVarEnv (GenType flexi) -> GenType flexi -> GenType flexi
480 instantiateTauTy :: TyVarEnv (GenType flexi2) -> GenType flexi1 -> GenType flexi2
483 -- instantiateTy applies a type environment to a type.
484 -- It can handle shadowing; for example:
485 -- f = /\ t1 t2 -> \ d ->
486 -- letrec f' = /\ t1 -> \x -> ...(f' t1 x')...
488 -- Here, when we clone t1 to t1', say, we'll come across shadowing
489 -- when applying the clone environment to the type of f'.
491 -- As a sanity check, we should also check that name capture
492 -- doesn't occur, but that means keeping track of the free variables of the
493 -- range of the TyVarEnv, which I don't do just yet.
495 instantiateTy tenv ty
496 | isEmptyTyVarEnv tenv
502 go tenv ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of
505 go tenv (TyConApp tc tys) = TyConApp tc (map (go tenv) tys)
506 go tenv (SynTy ty1 ty2) = SynTy (go tenv ty1) (go tenv ty2)
507 go tenv (FunTy arg res) = FunTy (go tenv arg) (go tenv res)
508 go tenv (AppTy fun arg) = mkAppTy (go tenv fun) (go tenv arg)
509 go tenv (ForAllTy tv ty) = ForAllTy tv (go tenv' ty)
511 tenv' = case lookupTyVarEnv tenv tv of
513 Just _ -> delFromTyVarEnv tenv tv
515 -- instantiateTauTy works only (a) on types with no ForAlls,
516 -- and when (b) all the type variables are being instantiated
517 -- In return it is more polymorphic than instantiateTy
519 instantiateTauTy tenv ty = applyToTyVars lookup ty
521 lookup tv = case lookupTyVarEnv tenv tv of
522 Just ty -> ty -- Must succeed
525 instantiateThetaTy :: TyVarEnv Type -> ThetaType -> ThetaType
526 instantiateThetaTy tenv theta
527 = [(clas, map (instantiateTauTy tenv) tys) | (clas, tys) <- theta]
529 applyToTyVars :: (GenTyVar flexi1 -> GenType flexi2)
532 applyToTyVars f ty = go ty
534 go (TyVarTy tv) = f tv
535 go (TyConApp tc tys) = TyConApp tc (map go tys)
536 go (SynTy ty1 ty2) = SynTy (go ty1) (go ty2)
537 go (FunTy arg res) = FunTy (go arg) (go res)
538 go (AppTy fun arg) = mkAppTy (go fun) (go arg)
539 go (ForAllTy tv ty) = panic "instantiateTauTy"
543 %************************************************************************
545 \subsection{Boxedness and pointedness}
547 %************************************************************************
550 *unboxed* iff its representation is other than a pointer
551 Unboxed types cannot instantiate a type variable
552 Unboxed types are always unpointed.
554 *unpointed* iff it can't be a thunk, and cannot have value bottom
555 An unpointed type may or may not be unboxed.
556 (E.g. Array# is unpointed, but boxed.)
557 An unpointed type *can* instantiate a type variable,
558 provided it is boxed.
560 *primitive* iff it is a built-in type that can't be expressed
563 Currently, all primitive types are unpointed, but that's not necessarily
564 the case. (E.g. Int could be primitive.)
567 isUnboxedType :: Type -> Bool
568 isUnboxedType ty = case typePrimRep ty of
572 -- Danger! Currently the unpointed types are precisely
573 -- the primitive ones, but that might not always be the case
574 isUnpointedType :: Type -> Bool
575 isUnpointedType ty = case splitTyConApp_maybe ty of
576 Just (tc, ty_args) -> isPrimTyCon tc
579 typePrimRep :: Type -> PrimRep
580 typePrimRep ty = case splitTyConApp_maybe ty of
581 Just (tc, ty_args) -> tyConPrimRep tc
586 %************************************************************************
588 \subsection{Matching on types}
590 %************************************************************************
592 Matching is a {\em unidirectional} process, matching a type against a
593 template (which is just a type with type variables in it). The
594 matcher assumes that there are no repeated type variables in the
595 template, so that it simply returns a mapping of type variables to
596 types. It also fails on nested foralls.
598 @matchTys@ matches corresponding elements of a list of templates and
602 matchTy :: GenType Bool -- Template
603 -> GenType flexi -- Proposed instance of template
604 -> Maybe (TyVarEnv (GenType flexi)) -- Matching substitution
607 matchTys :: [GenType Bool] -- Templates
608 -> [GenType flexi] -- Proposed instance of template
609 -> Maybe (TyVarEnv (GenType flexi), -- Matching substitution
610 [GenType flexi]) -- Left over instance types
612 matchTy ty1 ty2 = match ty1 ty2 (\s -> Just s) emptyTyVarEnv
613 matchTys tys1 tys2 = match_list tys1 tys2 (\pr -> Just pr) emptyTyVarEnv
616 @match@ is the main function.
619 match :: GenType Bool -> GenType flexi -- Current match pair
620 -> (TyVarEnv (GenType flexi) -> Maybe result) -- Continuation
621 -> TyVarEnv (GenType flexi) -- Current substitution
624 -- When matching against a type variable, see if the variable
625 -- has already been bound. If so, check that what it's bound to
626 -- is the same as ty; if not, bind it and carry on.
628 match (TyVarTy v) ty k = \s -> if tyVarFlexi v then
629 -- v is a template variable
630 case lookupTyVarEnv s v of
631 Nothing -> k (addToTyVarEnv s v ty)
632 Just ty' | ty' == ty -> k s -- Succeeds
633 | otherwise -> Nothing -- Fails
635 -- v is not a template variable; ty had better match
636 -- Can't use (==) because types differ
638 TyVarTy v' | uniqueOf v == uniqueOf v'
640 other -> Nothing -- Failure
642 match (FunTy arg1 res1) (FunTy arg2 res2) k = match arg1 arg2 (match res1 res2 k)
643 match (AppTy fun1 arg1) (AppTy fun2 arg2) k = match fun1 fun2 (match arg1 arg2 k)
644 match (TyConApp tc1 tys1) (TyConApp tc2 tys2) k | tc1 == tc2
645 = match_list tys1 tys2 ( \(s,tys2') ->
652 -- With type synonyms, we have to be careful for the exact
653 -- same reasons as in the unifier. Please see the
654 -- considerable commentary there before changing anything
656 match (SynTy _ ty1) ty2 k = match ty1 ty2 k
657 match ty1 (SynTy _ ty2) k = match ty1 ty2 k
660 match _ _ _ = \s -> Nothing
662 match_list [] tys2 k = \s -> k (s, tys2)
663 match_list (ty1:tys1) [] k = \s -> Nothing -- Not enough arg tys => failure
664 match_list (ty1:tys1) (ty2:tys2) k = match ty1 ty2 (match_list tys1 tys2 k)
667 %************************************************************************
669 \subsection{Equality on types}
671 %************************************************************************
673 For the moment at least, type comparisons don't work if
674 there are embedded for-alls.
677 instance Eq (GenType flexi) where
678 ty1 == ty2 = case ty1 `cmpTy` ty2 of { EQ -> True; other -> False }
680 instance Ord (GenType flexi) where
681 compare ty1 ty2 = cmpTy ty1 ty2
683 cmpTy :: GenType flexi -> GenType flexi -> Ordering
685 = cmp emptyTyVarEnv ty1 ty2
687 -- The "env" maps type variables in ty1 to type variables in ty2
688 -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
689 -- we in effect substitute tv2 for tv1 in t1 before continuing
690 lookup env tv1 = case lookupTyVarEnv env tv1 of
695 cmp env (SynTy _ ty1) ty2 = cmp env ty1 ty2
696 cmp env ty1 (SynTy _ ty2) = cmp env ty1 ty2
698 -- Deal with equal constructors
699 cmp env (TyVarTy tv1) (TyVarTy tv2) = lookup env tv1 `compare` tv2
700 cmp env (AppTy f1 a1) (AppTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
701 cmp env (FunTy f1 a1) (FunTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
702 cmp env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmps env tys1 tys2)
703 cmp env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmp (addToTyVarEnv env tv1 tv2) t1 t2
705 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
706 cmp env (AppTy _ _) (TyVarTy _) = GT
708 cmp env (FunTy _ _) (TyVarTy _) = GT
709 cmp env (FunTy _ _) (AppTy _ _) = GT
711 cmp env (TyConApp _ _) (TyVarTy _) = GT
712 cmp env (TyConApp _ _) (AppTy _ _) = GT
713 cmp env (TyConApp _ _) (FunTy _ _) = GT
715 cmp env (ForAllTy _ _) other = GT
720 cmps env (t:ts) [] = GT
721 cmps env [] (t:ts) = LT
722 cmps env (t1:t1s) (t2:t2s) = cmp env t1 t2 `thenCmp` cmps env t1s t2s
727 %************************************************************************
731 %************************************************************************
736 showTypeCategory :: Type -> Char
738 {C,I,F,D} char, int, float, double
740 S other single-constructor type
741 {c,i,f,d} unboxed ditto
743 s *unpacked" single-cons...
749 + dictionary, unless it's a ...
752 M other (multi-constructor) data-con type
754 - reserved for others to mark as "uninteresting"
760 case splitTyConApp_maybe ty of
761 Nothing -> if maybeToBool (splitFunTy_maybe ty)
766 let utc = uniqueOf tycon in
767 if utc == charDataConKey then 'C'
768 else if utc == intDataConKey then 'I'
769 else if utc == floatDataConKey then 'F'
770 else if utc == doubleDataConKey then 'D'
771 else if utc == integerDataConKey then 'J'
772 else if utc == charPrimTyConKey then 'c'
773 else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
774 || utc == addrPrimTyConKey) then 'i'
775 else if utc == floatPrimTyConKey then 'f'
776 else if utc == doublePrimTyConKey then 'd'
777 else if isPrimTyCon tycon {- array, we hope -} then 'A'
778 else if isEnumerationTyCon tycon then 'E'
779 else if isTupleTyCon tycon then 'T'
780 else if maybeToBool (maybeTyConSingleCon tycon) then 'S'
781 else if utc == listTyConKey then 'L'
782 else 'M' -- oh, well...