2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
4 \section[Type]{Type - public interface}
8 -- re-exports from TypeRep:
12 superKind, superBoxity, -- KX and BX respectively
13 liftedBoxity, unliftedBoxity, -- :: BX
15 typeCon, -- :: BX -> KX
16 liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX
17 mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX
21 usageKindCon, -- :: KX
22 usageTypeKind, -- :: KX
23 usOnceTyCon, usManyTyCon, -- :: $
24 usOnce, usMany, -- :: $
26 -- exports from this module:
27 hasMoreBoxityInfo, defaultKind,
29 mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
31 mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
33 mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, splitFunTysN,
34 funResultTy, funArgTy, zipFunTys,
36 mkTyConApp, mkTyConTy,
37 tyConAppTyCon, tyConAppArgs,
38 splitTyConApp_maybe, splitTyConApp,
39 splitAlgTyConApp_maybe, splitAlgTyConApp,
41 mkUTy, splitUTy, splitUTy_maybe,
42 isUTy, uaUTy, unUTy, liftUTy, mkUTyM,
43 isUsageKind, isUsage, isUTyVar,
47 repType, splitRepFunTys, splitNewType_maybe, typePrimRep,
49 mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
50 applyTy, applyTys, hoistForAllTys, isForAllTy,
52 -- Predicates and the like
53 PredType(..), getClassPredTys_maybe, getClassPredTys,
54 isPredTy, isClassPred, isTyVarClassPred, predHasFDs,
55 mkDictTy, mkPredTy, mkPredTys, splitPredTy_maybe, predTyUnique,
56 splitDictTy, splitDictTy_maybe, isDictTy, predRepTy, splitDFunTy,
57 mkClassPred, predMentionsIPs, inheritablePred, isIPPred, mkPredName,
60 TauType, RhoType, SigmaType, ThetaType,
61 isTauTy, mkRhoTy, splitRhoTy, splitMethodTy,
62 mkSigmaTy, isSigmaTy, splitSigmaTy,
66 isUnLiftedType, isUnboxedTupleType, isAlgType,
67 isDataType, isNewType, isPrimitiveType,
70 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
71 namesOfType, usageAnnOfType, typeKind, addFreeTyVars,
74 -- Tidying up for printing
76 tidyOpenType, tidyOpenTypes,
77 tidyTyVar, tidyTyVars, tidyFreeTyVars,
78 tidyTopType, tidyPred,
85 #include "HsVersions.h"
87 -- We import the representation and primitive functions from TypeRep.
88 -- Many things are reexported, but not the representation!
94 import {-# SOURCE #-} DataCon( DataCon )
95 import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
96 import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy )
99 import Var ( Var, TyVar, tyVarKind, tyVarName, setTyVarName )
103 import OccName ( mkDictOcc )
104 import Name ( Name, NamedThing(..), OccName, mkLocalName, tidyOccName )
106 import Class ( classTyCon, classHasFDs, Class )
107 import TyCon ( TyCon,
108 isUnboxedTupleTyCon, isUnLiftedTyCon,
109 isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep,
110 isAlgTyCon, isSynTyCon, tyConArity,
111 tyConKind, tyConDataCons, getSynTyConDefn,
112 tyConPrimRep, isPrimTyCon
116 import Maybes ( maybeToBool )
117 import SrcLoc ( SrcLoc, noSrcLoc )
118 import PrimRep ( PrimRep(..) )
119 import Unique ( Unique, Uniquable(..) )
120 import Util ( mapAccumL, seqList, thenCmp )
122 import UniqSet ( sizeUniqSet ) -- Should come via VarSet
126 %************************************************************************
128 \subsection{Stuff to do with kinds.}
130 %************************************************************************
133 hasMoreBoxityInfo :: Kind -> Kind -> Bool
134 hasMoreBoxityInfo k1 k2
135 | k2 == openTypeKind = True
136 | otherwise = k1 == k2
138 defaultKind :: Kind -> Kind
139 -- Used when generalising: default kind '?' to '*'
140 defaultKind kind | kind == openTypeKind = liftedTypeKind
145 %************************************************************************
147 \subsection{Constructor-specific functions}
149 %************************************************************************
152 ---------------------------------------------------------------------
156 mkTyVarTy :: TyVar -> Type
159 mkTyVarTys :: [TyVar] -> [Type]
160 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
162 getTyVar :: String -> Type -> TyVar
163 getTyVar msg (TyVarTy tv) = tv
164 getTyVar msg (PredTy p) = getTyVar msg (predRepTy p)
165 getTyVar msg (NoteTy _ t) = getTyVar msg t
166 getTyVar msg ty@(UsageTy _ _) = pprPanic "getTyVar: UTy:" (text msg $$ pprType ty)
167 getTyVar msg other = panic ("getTyVar: " ++ msg)
169 getTyVar_maybe :: Type -> Maybe TyVar
170 getTyVar_maybe (TyVarTy tv) = Just tv
171 getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
172 getTyVar_maybe (PredTy p) = getTyVar_maybe (predRepTy p)
173 getTyVar_maybe ty@(UsageTy _ _) = pprPanic "getTyVar_maybe: UTy:" (pprType ty)
174 getTyVar_maybe other = Nothing
176 isTyVarTy :: Type -> Bool
177 isTyVarTy (TyVarTy tv) = True
178 isTyVarTy (NoteTy _ ty) = isTyVarTy ty
179 isTyVarTy (PredTy p) = isTyVarTy (predRepTy p)
180 isTyVarTy ty@(UsageTy _ _) = pprPanic "isTyVarTy: UTy:" (pprType ty)
181 isTyVarTy other = False
185 ---------------------------------------------------------------------
188 We need to be pretty careful with AppTy to make sure we obey the
189 invariant that a TyConApp is always visibly so. mkAppTy maintains the
193 mkAppTy orig_ty1 orig_ty2
194 = ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind *
195 UASSERT2( not (isUTy orig_ty2), pprType orig_ty1 <+> pprType orig_ty2 )
196 -- argument must be unannotated
199 mk_app (NoteTy _ ty1) = mk_app ty1
200 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
201 mk_app ty@(UsageTy _ _) = pprPanic "mkAppTy: UTy:" (pprType ty)
202 mk_app ty1 = AppTy orig_ty1 orig_ty2
204 mkAppTys :: Type -> [Type] -> Type
205 mkAppTys orig_ty1 [] = orig_ty1
206 -- This check for an empty list of type arguments
207 -- avoids the needless loss of a type synonym constructor.
208 -- For example: mkAppTys Rational []
209 -- returns to (Ratio Integer), which has needlessly lost
210 -- the Rational part.
211 mkAppTys orig_ty1 orig_tys2
212 = ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind *
213 UASSERT2( not (any isUTy orig_tys2), pprType orig_ty1 <+> fsep (map pprType orig_tys2) )
214 -- arguments must be unannotated
217 mk_app (NoteTy _ ty1) = mk_app ty1
218 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
219 mk_app ty@(UsageTy _ _) = pprPanic "mkAppTys: UTy:" (pprType ty)
220 mk_app ty1 = foldl AppTy orig_ty1 orig_tys2
222 splitAppTy_maybe :: Type -> Maybe (Type, Type)
223 splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [unUTy ty1], unUTy ty2)
224 splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
225 splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty
226 splitAppTy_maybe (PredTy p) = splitAppTy_maybe (predRepTy p)
227 splitAppTy_maybe (TyConApp tc []) = Nothing
228 splitAppTy_maybe (TyConApp tc tys) = split tys []
230 split [ty2] acc = Just (TyConApp tc (reverse acc), ty2)
231 split (ty:tys) acc = split tys (ty:acc)
233 splitAppTy_maybe ty@(UsageTy _ _) = pprPanic "splitAppTy_maybe: UTy:" (pprType ty)
234 splitAppTy_maybe other = Nothing
236 splitAppTy :: Type -> (Type, Type)
237 splitAppTy ty = case splitAppTy_maybe ty of
239 Nothing -> panic "splitAppTy"
241 splitAppTys :: Type -> (Type, [Type])
242 splitAppTys ty = split ty ty []
244 split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
245 split orig_ty (NoteTy _ ty) args = split orig_ty ty args
246 split orig_ty (PredTy p) args = split orig_ty (predRepTy p) args
247 split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
248 (TyConApp funTyCon [], [unUTy ty1,unUTy ty2])
249 split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
250 split orig_ty (UsageTy _ _) args = pprPanic "splitAppTys: UTy:" (pprType orig_ty)
251 split orig_ty ty args = (orig_ty, args)
255 ---------------------------------------------------------------------
260 mkFunTy :: Type -> Type -> Type
261 mkFunTy arg res = UASSERT2( isUTy arg && isUTy res, pprType arg <+> pprType res )
264 mkFunTys :: [Type] -> Type -> Type
265 mkFunTys tys ty = UASSERT2( all isUTy (ty:tys), fsep (map pprType (tys++[ty])) )
268 splitFunTy :: Type -> (Type, Type)
269 splitFunTy (FunTy arg res) = (arg, res)
270 splitFunTy (NoteTy _ ty) = splitFunTy ty
271 splitFunTy (PredTy p) = splitFunTy (predRepTy p)
272 splitFunTy ty@(UsageTy _ _) = pprPanic "splitFunTy: UTy:" (pprType ty)
274 splitFunTy_maybe :: Type -> Maybe (Type, Type)
275 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
276 splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
277 splitFunTy_maybe (PredTy p) = splitFunTy_maybe (predRepTy p)
278 splitFunTy_maybe ty@(UsageTy _ _) = pprPanic "splitFunTy_maybe: UTy:" (pprType ty)
279 splitFunTy_maybe other = Nothing
281 splitFunTys :: Type -> ([Type], Type)
282 splitFunTys ty = split [] ty ty
284 split args orig_ty (FunTy arg res) = split (arg:args) res res
285 split args orig_ty (NoteTy _ ty) = split args orig_ty ty
286 split args orig_ty (PredTy p) = split args orig_ty (predRepTy p)
287 split args orig_ty (UsageTy _ _) = pprPanic "splitFunTys: UTy:" (pprType orig_ty)
288 split args orig_ty ty = (reverse args, orig_ty)
290 splitFunTysN :: String -> Int -> Type -> ([Type], Type)
291 splitFunTysN msg orig_n orig_ty = split orig_n [] orig_ty orig_ty
293 split 0 args syn_ty ty = (reverse args, syn_ty)
294 split n args syn_ty (FunTy arg res) = split (n-1) (arg:args) res res
295 split n args syn_ty (NoteTy _ ty) = split n args syn_ty ty
296 split n args syn_ty (PredTy p) = split n args syn_ty (predRepTy p)
297 split n args syn_ty (UsageTy _ _) = pprPanic "splitFunTysN: UTy:" (pprType orig_ty)
298 split n args syn_ty ty = pprPanic ("splitFunTysN: " ++ msg) (int orig_n <+> pprType orig_ty)
300 zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
301 zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
303 split acc [] nty ty = (reverse acc, nty)
304 split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
305 split acc xs nty (NoteTy _ ty) = split acc xs nty ty
306 split acc xs nty (PredTy p) = split acc xs nty (predRepTy p)
307 split acc xs nty (UsageTy _ _) = pprPanic "zipFunTys: UTy:" (ppr orig_xs <+> pprType orig_ty)
308 split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty)
310 funResultTy :: Type -> Type
311 funResultTy (FunTy arg res) = res
312 funResultTy (NoteTy _ ty) = funResultTy ty
313 funResultTy (PredTy p) = funResultTy (predRepTy p)
314 funResultTy (UsageTy _ ty) = funResultTy ty
315 funResultTy ty = pprPanic "funResultTy" (pprType ty)
317 funArgTy :: Type -> Type
318 funArgTy (FunTy arg res) = arg
319 funArgTy (NoteTy _ ty) = funArgTy ty
320 funArgTy (PredTy p) = funArgTy (predRepTy p)
321 funArgTy (UsageTy _ ty) = funArgTy ty
322 funArgTy ty = pprPanic "funArgTy" (pprType ty)
326 ---------------------------------------------------------------------
331 mkTyConApp :: TyCon -> [Type] -> Type
333 | isFunTyCon tycon && length tys == 2
335 (ty1:ty2:_) -> FunTy (mkUTyM ty1) (mkUTyM ty2)
338 = ASSERT(not (isSynTyCon tycon))
339 UASSERT2( not (any isUTy tys), ppr tycon <+> fsep (map pprType tys) )
342 mkTyConTy :: TyCon -> Type
343 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
346 -- splitTyConApp "looks through" synonyms, because they don't
347 -- mean a distinct type, but all other type-constructor applications
348 -- including functions are returned as Just ..
350 tyConAppTyCon :: Type -> TyCon
351 tyConAppTyCon ty = case splitTyConApp_maybe ty of
353 Nothing -> pprPanic "tyConAppTyCon" (pprType ty)
355 tyConAppArgs :: Type -> [Type]
356 tyConAppArgs ty = case splitTyConApp_maybe ty of
357 Just (_,args) -> args
358 Nothing -> pprPanic "tyConAppArgs" (pprType ty)
360 splitTyConApp :: Type -> (TyCon, [Type])
361 splitTyConApp ty = case splitTyConApp_maybe ty of
363 Nothing -> pprPanic "splitTyConApp" (pprType ty)
365 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
366 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
367 splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [unUTy arg,unUTy res])
368 splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
369 splitTyConApp_maybe (PredTy p) = splitTyConApp_maybe (predRepTy p)
370 splitTyConApp_maybe (UsageTy _ ty) = splitTyConApp_maybe ty
371 splitTyConApp_maybe other = Nothing
373 -- splitAlgTyConApp_maybe looks for
374 -- *saturated* applications of *algebraic* data types
375 -- "Algebraic" => newtype, data type, or dictionary (not function types)
376 -- We return the constructors too, so there had better be some.
378 splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon])
379 splitAlgTyConApp_maybe (TyConApp tc tys)
381 tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
382 splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
383 splitAlgTyConApp_maybe (PredTy p) = splitAlgTyConApp_maybe (predRepTy p)
384 splitAlgTyConApp_maybe (UsageTy _ ty)= splitAlgTyConApp_maybe ty
385 splitAlgTyConApp_maybe other = Nothing
387 splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon])
388 -- Here the "algebraic" property is an *assertion*
389 splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
390 (tc, tys, tyConDataCons tc)
391 splitAlgTyConApp (NoteTy _ ty) = splitAlgTyConApp ty
392 splitAlgTyConApp (PredTy p) = splitAlgTyConApp (predRepTy p)
393 splitAlgTyConApp (UsageTy _ ty) = splitAlgTyConApp ty
395 splitAlgTyConApp ty = pprPanic "splitAlgTyConApp" (pprType ty)
400 ---------------------------------------------------------------------
405 mkSynTy syn_tycon tys
406 = ASSERT( isSynTyCon syn_tycon )
407 ASSERT( length tyvars == length tys )
408 NoteTy (SynNote (TyConApp syn_tycon tys))
409 (substTy (mkTyVarSubst tyvars tys) body)
411 (tyvars, body) = getSynTyConDefn syn_tycon
413 deNoteType :: Type -> Type
414 -- Remove synonyms, but not Preds
415 deNoteType ty@(TyVarTy tyvar) = ty
416 deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
417 deNoteType (PredTy p) = PredTy (deNotePred p)
418 deNoteType (NoteTy _ ty) = deNoteType ty
419 deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg)
420 deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg)
421 deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty)
422 deNoteType (UsageTy u ty) = UsageTy u (deNoteType ty)
424 deNotePred :: PredType -> PredType
425 deNotePred (ClassP c tys) = ClassP c (map deNoteType tys)
426 deNotePred (IParam n ty) = IParam n (deNoteType ty)
429 Notes on type synonyms
430 ~~~~~~~~~~~~~~~~~~~~~~
431 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
432 to return type synonyms whereever possible. Thus
437 splitFunTys (a -> Foo a) = ([a], Foo a)
440 The reason is that we then get better (shorter) type signatures in
441 interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
447 repType looks through
452 (e) usage annotations
453 It's useful in the back end where we're not
454 interested in newtypes anymore.
457 repType :: Type -> Type
458 repType (ForAllTy _ ty) = repType ty
459 repType (NoteTy _ ty) = repType ty
460 repType (PredTy p) = repType (predRepTy p)
461 repType (UsageTy _ ty) = repType ty
462 repType ty = case splitNewType_maybe ty of
463 Just ty' -> repType ty' -- Still re-apply repType in case of for-all
466 splitRepFunTys :: Type -> ([Type], Type)
467 -- Like splitFunTys, but looks through newtypes and for-alls
468 splitRepFunTys ty = split [] (repType ty)
470 split args (FunTy arg res) = split (arg:args) (repType res)
471 split args ty = (reverse args, ty)
473 typePrimRep :: Type -> PrimRep
474 typePrimRep ty = case repType ty of
475 TyConApp tc _ -> tyConPrimRep tc
477 AppTy _ _ -> PtrRep -- ??
480 splitNewType_maybe :: Type -> Maybe Type
481 -- Find the representation of a newtype, if it is one
482 -- Looks through multiple levels of newtype, but does not look through for-alls
483 splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty
484 splitNewType_maybe (PredTy p) = splitNewType_maybe (predRepTy p)
485 splitNewType_maybe (UsageTy _ ty) = splitNewType_maybe ty
486 splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of
487 Just rep_ty -> ASSERT( length tys == tyConArity tc )
488 -- The assert should hold because repType should
489 -- only be applied to *types* (of kind *)
490 Just (applyTys rep_ty tys)
492 splitNewType_maybe other = Nothing
497 ---------------------------------------------------------------------
502 mkForAllTy :: TyVar -> Type -> Type
504 = mkForAllTys [tyvar] ty
506 mkForAllTys :: [TyVar] -> Type -> Type
507 mkForAllTys tyvars ty
508 = case splitUTy_maybe ty of
509 Just (u,ty1) -> UASSERT2( not (mkVarSet tyvars `intersectsVarSet` tyVarsOfType u),
510 ptext SLIT("mkForAllTys: usage scope")
511 <+> ppr tyvars <+> pprType ty )
512 mkUTy u (foldr ForAllTy ty1 tyvars) -- we lift usage annotations over foralls
513 Nothing -> foldr ForAllTy ty tyvars
515 isForAllTy :: Type -> Bool
516 isForAllTy (NoteTy _ ty) = isForAllTy ty
517 isForAllTy (ForAllTy _ _) = True
518 isForAllTy (UsageTy _ ty) = isForAllTy ty
519 isForAllTy other_ty = False
521 splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
522 splitForAllTy_maybe ty = splitFAT_m ty
524 splitFAT_m (NoteTy _ ty) = splitFAT_m ty
525 splitFAT_m (PredTy p) = splitFAT_m (predRepTy p)
526 splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
527 splitFAT_m (UsageTy _ ty) = splitFAT_m ty
528 splitFAT_m _ = Nothing
530 splitForAllTys :: Type -> ([TyVar], Type)
531 splitForAllTys ty = split ty ty []
533 split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
534 split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
535 split orig_ty (PredTy p) tvs = split orig_ty (predRepTy p) tvs
536 split orig_ty (UsageTy _ ty) tvs = split orig_ty ty tvs
537 split orig_ty t tvs = (reverse tvs, orig_ty)
540 -- (mkPiType now in CoreUtils)
542 Applying a for-all to its arguments. Lift usage annotation as required.
545 applyTy :: Type -> Type -> Type
546 applyTy (PredTy p) arg = applyTy (predRepTy p) arg
547 applyTy (NoteTy _ fun) arg = applyTy fun arg
548 applyTy (ForAllTy tv ty) arg = UASSERT2( not (isUTy arg),
549 ptext SLIT("applyTy")
550 <+> pprType ty <+> pprType arg )
551 substTy (mkTyVarSubst [tv] [arg]) ty
552 applyTy (UsageTy u ty) arg = UsageTy u (applyTy ty arg)
553 applyTy other arg = panic "applyTy"
555 applyTys :: Type -> [Type] -> Type
556 applyTys fun_ty arg_tys
557 = UASSERT2( not (any isUTy arg_tys), ptext SLIT("applyTys") <+> pprType fun_ty )
561 substTy (mkTyVarSubst tvs arg_tys) ty
563 (mu, tvs, ty) = split fun_ty arg_tys
565 split fun_ty [] = (Nothing, [], fun_ty)
566 split (NoteTy _ fun_ty) args = split fun_ty args
567 split (PredTy p) args = split (predRepTy p) args
568 split (ForAllTy tv fun_ty) (arg:args) = case split fun_ty args of
569 (mu, tvs, ty) -> (mu, tv:tvs, ty)
570 split (UsageTy u ty) args = case split ty args of
571 (Nothing, tvs, ty) -> (Just u, tvs, ty)
572 (Just _ , _ , _ ) -> pprPanic "applyTys:"
574 split other_ty args = panic "applyTys"
578 hoistForAllTys :: Type -> Type
579 -- Move all the foralls to the top
580 -- e.g. T -> forall a. a ==> forall a. T -> a
581 -- Careful: LOSES USAGE ANNOTATIONS!
583 = case hoist ty of { (tvs, body) -> mkForAllTys tvs body }
585 hoist :: Type -> ([TyVar], Type)
586 hoist ty = case splitFunTys ty of { (args, res) ->
587 case splitForAllTys res of {
588 ([], body) -> ([], ty) ;
589 (tvs1, body1) -> case hoist body1 of { (tvs2,body2) ->
590 (tvs1 ++ tvs2, mkFunTys args body2)
595 ---------------------------------------------------------------------
599 Constructing and taking apart usage types.
602 mkUTy :: Type -> Type -> Type
604 = ASSERT2( typeKind u == usageTypeKind, ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
605 UASSERT2( not (isUTy ty), ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
606 -- if u == usMany then ty else : ToDo? KSW 2000-10
613 splitUTy :: Type -> (Type {- :: $ -}, Type)
615 = case splitUTy_maybe orig_ty of
616 Just (u,ty) -> (u,ty)
618 Nothing -> pprPanic "splitUTy:" (pprType orig_ty)
620 Nothing -> (usMany,orig_ty) -- default annotation ToDo KSW 2000-10
623 splitUTy_maybe :: Type -> Maybe (Type {- :: $ -}, Type)
624 splitUTy_maybe (UsageTy u ty) = Just (u,ty)
625 splitUTy_maybe (NoteTy _ ty) = splitUTy_maybe ty
626 splitUTy_maybe other_ty = Nothing
628 isUTy :: Type -> Bool
629 -- has usage annotation
630 isUTy = maybeToBool . splitUTy_maybe
632 uaUTy :: Type -> Type
633 -- extract annotation
634 uaUTy = fst . splitUTy
636 unUTy :: Type -> Type
637 -- extract unannotated type
638 unUTy = snd . splitUTy
642 liftUTy :: (Type -> Type) -> Type -> Type
643 -- lift outer usage annot over operation on unannotated types
646 (u,ty') = splitUTy ty
652 mkUTyM :: Type -> Type
653 -- put TOP (no info) annotation on unannotated type
654 mkUTyM ty = mkUTy usMany ty
658 isUsageKind :: Kind -> Bool
660 = ASSERT( typeKind k == superKind )
663 isUsage :: Type -> Bool
665 = isUsageKind (typeKind ty)
667 isUTyVar :: Var -> Bool
669 = isUsageKind (tyVarKind v)
673 %************************************************************************
675 \subsection{Predicates}
677 %************************************************************************
679 "Dictionary" types are just ordinary data types, but you can
680 tell from the type constructor whether it's a dictionary or not.
683 mkClassPred clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) )
686 isClassPred (ClassP clas tys) = True
687 isClassPred other = False
689 isIPPred (IParam _ _) = True
690 isIPPred other = False
692 isTyVarClassPred (ClassP clas tys) = all isTyVarTy tys
693 isTyVarClassPred other = False
695 getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
696 getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
697 getClassPredTys_maybe _ = Nothing
699 getClassPredTys :: PredType -> (Class, [Type])
700 getClassPredTys (ClassP clas tys) = (clas, tys)
702 inheritablePred :: PredType -> Bool
703 -- Can be inherited by a context. For example, consider
704 -- f x = let g y = (?v, y+x)
705 -- in (g 3 with ?v = 8,
707 -- The point is that g's type must be quantifed over ?v:
708 -- g :: (?v :: a) => a -> a
709 -- but it doesn't need to be quantified over the Num a dictionary
710 -- which can be free in g's rhs, and shared by both calls to g
711 inheritablePred (ClassP _ _) = True
712 inheritablePred other = False
714 predMentionsIPs :: PredType -> NameSet -> Bool
715 predMentionsIPs (IParam n _) ns = n `elemNameSet` ns
716 predMentionsIPs other ns = False
718 predHasFDs :: PredType -> Bool
719 -- True if the predicate has functional depenencies;
720 -- I.e. should participate in improvement
721 predHasFDs (IParam _ _) = True
722 predHasFDs (ClassP cls _) = classHasFDs cls
724 mkDictTy :: Class -> [Type] -> Type
725 mkDictTy clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) )
726 mkPredTy (ClassP clas tys)
728 mkPredTy :: PredType -> Type
729 mkPredTy pred = PredTy pred
731 mkPredTys :: ThetaType -> [Type]
732 mkPredTys preds = map PredTy preds
734 predTyUnique :: PredType -> Unique
735 predTyUnique (IParam n _) = getUnique n
736 predTyUnique (ClassP clas tys) = getUnique clas
738 predRepTy :: PredType -> Type
739 -- Convert a predicate to its "representation type";
740 -- the type of evidence for that predicate, which is actually passed at runtime
741 predRepTy (ClassP clas tys) = TyConApp (classTyCon clas) tys
742 predRepTy (IParam n ty) = ty
744 isPredTy :: Type -> Bool
745 isPredTy (NoteTy _ ty) = isPredTy ty
746 isPredTy (PredTy _) = True
747 isPredTy (UsageTy _ ty)= isPredTy ty
750 isDictTy :: Type -> Bool
751 isDictTy (NoteTy _ ty) = isDictTy ty
752 isDictTy (PredTy (ClassP _ _)) = True
753 isDictTy (UsageTy _ ty) = isDictTy ty
754 isDictTy other = False
756 splitPredTy_maybe :: Type -> Maybe PredType
757 splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty
758 splitPredTy_maybe (PredTy p) = Just p
759 splitPredTy_maybe (UsageTy _ ty)= splitPredTy_maybe ty
760 splitPredTy_maybe other = Nothing
762 splitDictTy :: Type -> (Class, [Type])
763 splitDictTy (NoteTy _ ty) = splitDictTy ty
764 splitDictTy (PredTy (ClassP clas tys)) = (clas, tys)
766 splitDictTy_maybe :: Type -> Maybe (Class, [Type])
767 splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty
768 splitDictTy_maybe (PredTy (ClassP clas tys)) = Just (clas, tys)
769 splitDictTy_maybe other = Nothing
771 splitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
772 -- Split the type of a dictionary function
774 = case splitSigmaTy ty of { (tvs, theta, tau) ->
775 case splitDictTy tau of { (clas, tys) ->
776 (tvs, theta, clas, tys) }}
778 namesOfDFunHead :: Type -> NameSet
779 -- Find the free type constructors and classes
780 -- of the head of the dfun instance type
781 -- The 'dfun_head_type' is because of
782 -- instance Foo a => Baz T where ...
783 -- The decl is an orphan if Baz and T are both not locally defined,
784 -- even if Foo *is* locally defined
785 namesOfDFunHead dfun_ty = case splitSigmaTy dfun_ty of
786 (tvs,_,head_ty) -> delListFromNameSet (namesOfType head_ty)
789 mkPredName :: Unique -> SrcLoc -> PredType -> Name
790 mkPredName uniq loc (ClassP cls tys) = mkLocalName uniq (mkDictOcc (getOccName cls)) loc
791 mkPredName uniq loc (IParam name ty) = name
794 %************************************************************************
796 \subsection{Tau, sigma and rho}
798 %************************************************************************
800 @isTauTy@ tests for nested for-alls.
803 isTauTy :: Type -> Bool
804 isTauTy (TyVarTy v) = True
805 isTauTy (TyConApp _ tys) = all isTauTy tys
806 isTauTy (AppTy a b) = isTauTy a && isTauTy b
807 isTauTy (FunTy a b) = isTauTy a && isTauTy b
808 isTauTy (PredTy p) = isTauTy (predRepTy p)
809 isTauTy (NoteTy _ ty) = isTauTy ty
810 isTauTy (UsageTy _ ty) = isTauTy ty
811 isTauTy other = False
815 mkRhoTy :: [PredType] -> Type -> Type
816 mkRhoTy theta ty = UASSERT2( not (isUTy ty), pprType ty )
817 foldr (\p r -> FunTy (mkUTyM (mkPredTy p)) (mkUTyM r)) ty theta
819 splitRhoTy :: Type -> ([PredType], Type)
820 splitRhoTy ty = split ty ty []
822 split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of
823 Just p -> split res res (p:ts)
824 Nothing -> (reverse ts, orig_ty)
825 split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts
826 split orig_ty (UsageTy _ ty) ts = split orig_ty ty ts
827 split orig_ty ty ts = (reverse ts, orig_ty)
830 The type of a method for class C is always of the form:
831 Forall a1..an. C a1..an => sig_ty
832 where sig_ty is the type given by the method's signature, and thus in general
833 is a ForallTy. At the point that splitMethodTy is called, it is expected
834 that the outer Forall has already been stripped off. splitMethodTy then
835 returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes or
839 splitMethodTy :: Type -> (PredType, Type)
840 splitMethodTy ty = split ty
842 split (FunTy arg res) = case splitPredTy_maybe arg of
844 Nothing -> panic "splitMethodTy"
845 split (NoteTy _ ty) = split ty
846 split (UsageTy _ ty) = split ty
847 split _ = panic "splitMethodTy"
851 isSigmaType returns true of any qualified type. It doesn't *necessarily* have
853 f :: (?x::Int) => Int -> Int
856 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
858 isSigmaTy :: Type -> Bool
859 isSigmaTy (ForAllTy tyvar ty) = True
860 isSigmaTy (FunTy a b) = isPredTy a
861 isSigmaTy (NoteTy _ ty) = isSigmaTy ty
862 isSigmaTy (UsageTy _ ty) = isSigmaTy ty
865 splitSigmaTy :: Type -> ([TyVar], [PredType], Type)
869 (tyvars,rho) = splitForAllTys ty
870 (theta,tau) = splitRhoTy rho
874 getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
875 -- construct a dictionary function name
876 getDFunTyKey (TyVarTy tv) = getOccName tv
877 getDFunTyKey (TyConApp tc _) = getOccName tc
878 getDFunTyKey (AppTy fun _) = getDFunTyKey fun
879 getDFunTyKey (NoteTy _ t) = getDFunTyKey t
880 getDFunTyKey (FunTy arg _) = getOccName funTyCon
881 getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
882 getDFunTyKey (UsageTy _ t) = getDFunTyKey t
883 -- PredTy shouldn't happen
887 %************************************************************************
889 \subsection{Kinds and free variables}
891 %************************************************************************
893 ---------------------------------------------------------------------
894 Finding the kind of a type
895 ~~~~~~~~~~~~~~~~~~~~~~~~~~
897 typeKind :: Type -> Kind
899 typeKind (TyVarTy tyvar) = tyVarKind tyvar
900 typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
901 typeKind (NoteTy _ ty) = typeKind ty
902 typeKind (PredTy _) = liftedTypeKind -- Predicates are always
903 -- represented by lifted types
904 typeKind (AppTy fun arg) = funResultTy (typeKind fun)
906 typeKind (FunTy arg res) = fix_up (typeKind res)
908 fix_up (TyConApp tycon _) | tycon == typeCon
909 || tycon == openKindCon = liftedTypeKind
910 fix_up (NoteTy _ kind) = fix_up kind
912 -- The basic story is
913 -- typeKind (FunTy arg res) = typeKind res
914 -- But a function is lifted regardless of its result type
915 -- Hence the strange fix-up.
916 -- Note that 'res', being the result of a FunTy, can't have
917 -- a strange kind like (*->*).
919 typeKind (ForAllTy tv ty) = typeKind ty
920 typeKind (UsageTy _ ty) = typeKind ty -- we don't have separate kinds for ann/unann
924 ---------------------------------------------------------------------
925 Free variables of a type
926 ~~~~~~~~~~~~~~~~~~~~~~~~
929 tyVarsOfType :: Type -> TyVarSet
930 tyVarsOfType (TyVarTy tv) = unitVarSet tv
931 tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
932 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
933 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
934 tyVarsOfType (PredTy p) = tyVarsOfPred p
935 tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
936 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
937 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
938 tyVarsOfType (UsageTy u ty) = tyVarsOfType u `unionVarSet` tyVarsOfType ty
940 tyVarsOfTypes :: [Type] -> TyVarSet
941 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
943 tyVarsOfPred :: PredType -> TyVarSet
944 tyVarsOfPred (ClassP clas tys) = tyVarsOfTypes tys
945 tyVarsOfPred (IParam n ty) = tyVarsOfType ty
947 tyVarsOfTheta :: ThetaType -> TyVarSet
948 tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
950 -- Add a Note with the free tyvars to the top of the type
951 addFreeTyVars :: Type -> Type
952 addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
953 addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
955 -- Find the free names of a type, including the type constructors and classes it mentions
956 namesOfType :: Type -> NameSet
957 namesOfType (TyVarTy tv) = unitNameSet (getName tv)
958 namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets`
960 namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1
961 namesOfType (NoteTy other_note ty2) = namesOfType ty2
962 namesOfType (PredTy p) = namesOfType (predRepTy p)
963 namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
964 namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
965 namesOfType (ForAllTy tyvar ty) = namesOfType ty `delFromNameSet` getName tyvar
966 namesOfType (UsageTy u ty) = namesOfType u `unionNameSets` namesOfType ty
968 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
971 Usage annotations of a type
972 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
974 Get a list of usage annotations of a type, *in left-to-right pre-order*.
977 usageAnnOfType :: Type -> [Type]
982 goT (AppTy ty1 ty2) = goT ty1 ++ goT ty2
983 goT (TyConApp tc tys) = concatMap goT tys
984 goT (FunTy sty1 sty2) = goS sty1 ++ goS sty2
985 goT (ForAllTy mv ty) = goT ty
986 goT (PredTy p) = goT (predRepTy p)
987 goT ty@(UsageTy _ _) = pprPanic "usageAnnOfType: unexpected usage:" (pprType ty)
988 goT (NoteTy note ty) = goT ty
990 goS sty = case splitUTy sty of
991 (u,tty) -> u : goT tty
995 %************************************************************************
997 \subsection{TidyType}
999 %************************************************************************
1001 tidyTy tidies up a type for printing in an error message, or in
1004 It doesn't change the uniques at all, just the print names.
1007 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
1008 tidyTyVar env@(tidy_env, subst) tyvar
1009 = case lookupVarEnv subst tyvar of
1011 Just tyvar' -> -- Already substituted
1014 Nothing -> -- Make a new nice name for it
1016 case tidyOccName tidy_env (getOccName name) of
1017 (tidy', occ') -> -- New occname reqd
1018 ((tidy', subst'), tyvar')
1020 subst' = extendVarEnv subst tyvar tyvar'
1021 tyvar' = setTyVarName tyvar name'
1022 name' = mkLocalName (getUnique name) occ' noSrcLoc
1023 -- Note: make a *user* tyvar, so it printes nicely
1024 -- Could extract src loc, but no need.
1026 name = tyVarName tyvar
1028 tidyTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
1029 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
1031 tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
1032 -- Add the free tyvars to the env in tidy form,
1033 -- so that we can tidy the type they are free in
1034 tidyFreeTyVars env tyvars = foldl add env (varSetElems tyvars)
1036 add env tv = fst (tidyTyVar env tv)
1038 tidyType :: TidyEnv -> Type -> Type
1039 tidyType env@(tidy_env, subst) ty
1042 go (TyVarTy tv) = case lookupVarEnv subst tv of
1043 Nothing -> TyVarTy tv
1044 Just tv' -> TyVarTy tv'
1045 go (TyConApp tycon tys) = let args = map go tys
1046 in args `seqList` TyConApp tycon args
1047 go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
1048 go (PredTy p) = PredTy (tidyPred env p)
1049 go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
1050 go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
1051 go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty)
1053 (envp, tvp) = tidyTyVar env tv
1054 go (UsageTy u ty) = (UsageTy SAPPLY (go u)) SAPPLY (go ty)
1056 go_note (SynNote ty) = SynNote SAPPLY (go ty)
1057 go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
1059 tidyTypes env tys = map (tidyType env) tys
1061 tidyPred :: TidyEnv -> PredType -> PredType
1062 tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
1063 tidyPred env (IParam n ty) = IParam n (tidyType env ty)
1067 @tidyOpenType@ grabs the free type variables, tidies them
1068 and then uses @tidyType@ to work over the type itself
1071 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
1073 = (env', tidyType env' ty)
1075 env' = tidyFreeTyVars env (tyVarsOfType ty)
1077 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
1078 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
1080 tidyTopType :: Type -> Type
1081 tidyTopType ty = tidyType emptyTidyEnv ty
1086 %************************************************************************
1088 \subsection{Liftedness}
1090 %************************************************************************
1093 isUnLiftedType :: Type -> Bool
1094 -- isUnLiftedType returns True for forall'd unlifted types:
1095 -- x :: forall a. Int#
1096 -- I found bindings like these were getting floated to the top level.
1097 -- They are pretty bogus types, mind you. It would be better never to
1100 isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
1101 isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty
1102 isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
1103 isUnLiftedType (UsageTy _ ty) = isUnLiftedType ty
1104 isUnLiftedType other = False
1106 isUnboxedTupleType :: Type -> Bool
1107 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
1108 Just (tc, ty_args) -> isUnboxedTupleTyCon tc
1111 -- Should only be applied to *types*; hence the assert
1112 isAlgType :: Type -> Bool
1113 isAlgType ty = case splitTyConApp_maybe ty of
1114 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1118 -- Should only be applied to *types*; hence the assert
1119 isDataType :: Type -> Bool
1120 isDataType ty = case splitTyConApp_maybe ty of
1121 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1125 isNewType :: Type -> Bool
1126 isNewType ty = case splitTyConApp_maybe ty of
1127 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1131 isPrimitiveType :: Type -> Bool
1132 -- Returns types that are opaque to Haskell.
1133 -- Most of these are unlifted, but now that we interact with .NET, we
1134 -- may have primtive (foreign-imported) types that are lifted
1135 isPrimitiveType ty = case splitTyConApp_maybe ty of
1136 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1142 %************************************************************************
1144 \subsection{Sequencing on types
1146 %************************************************************************
1149 seqType :: Type -> ()
1150 seqType (TyVarTy tv) = tv `seq` ()
1151 seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
1152 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
1153 seqType (NoteTy note t2) = seqNote note `seq` seqType t2
1154 seqType (PredTy p) = seqPred p
1155 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
1156 seqType (ForAllTy tv ty) = tv `seq` seqType ty
1157 seqType (UsageTy u ty) = seqType u `seq` seqType ty
1159 seqTypes :: [Type] -> ()
1161 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
1163 seqNote :: TyNote -> ()
1164 seqNote (SynNote ty) = seqType ty
1165 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
1167 seqPred :: PredType -> ()
1168 seqPred (ClassP c tys) = c `seq` seqTypes tys
1169 seqPred (IParam n ty) = n `seq` seqType ty
1173 %************************************************************************
1175 \subsection{Equality on types}
1177 %************************************************************************
1181 instance Eq Type where
1182 ty1 == ty2 = case ty1 `compare` ty2 of { EQ -> True; other -> False }
1184 instance Ord Type where
1185 compare ty1 ty2 = cmpTy emptyVarEnv ty1 ty2
1187 cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
1188 -- The "env" maps type variables in ty1 to type variables in ty2
1189 -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
1190 -- we in effect substitute tv2 for tv1 in t1 before continuing
1192 -- Get rid of NoteTy
1193 cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
1194 cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
1196 -- Get rid of PredTy
1197 cmpTy env (PredTy p1) (PredTy p2) = cmpPred env p1 p2
1198 cmpTy env (PredTy p1) ty2 = cmpTy env (predRepTy p1) ty2
1199 cmpTy env ty1 (PredTy p2) = cmpTy env ty1 (predRepTy p2)
1201 -- Deal with equal constructors
1202 cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
1203 Just tv1a -> tv1a `compare` tv2
1204 Nothing -> tv1 `compare` tv2
1206 cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1207 cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1208 cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
1209 cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2
1210 cmpTy env (UsageTy u1 t1) (UsageTy u2 t2) = cmpTy env u1 u2 `thenCmp` cmpTy env t1 t2
1212 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < UsageTy
1213 cmpTy env (AppTy _ _) (TyVarTy _) = GT
1215 cmpTy env (FunTy _ _) (TyVarTy _) = GT
1216 cmpTy env (FunTy _ _) (AppTy _ _) = GT
1218 cmpTy env (TyConApp _ _) (TyVarTy _) = GT
1219 cmpTy env (TyConApp _ _) (AppTy _ _) = GT
1220 cmpTy env (TyConApp _ _) (FunTy _ _) = GT
1222 cmpTy env (ForAllTy _ _) (TyVarTy _) = GT
1223 cmpTy env (ForAllTy _ _) (AppTy _ _) = GT
1224 cmpTy env (ForAllTy _ _) (FunTy _ _) = GT
1225 cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT
1227 cmpTy env (UsageTy _ _) other = GT
1232 cmpTys env [] [] = EQ
1233 cmpTys env (t:ts) [] = GT
1234 cmpTys env [] (t:ts) = LT
1235 cmpTys env (t1:t1s) (t2:t2s) = cmpTy env t1 t2 `thenCmp` cmpTys env t1s t2s
1239 instance Eq PredType where
1240 p1 == p2 = case p1 `compare` p2 of { EQ -> True; other -> False }
1242 instance Ord PredType where
1243 compare p1 p2 = cmpPred emptyVarEnv p1 p2
1245 cmpPred :: TyVarEnv TyVar -> PredType -> PredType -> Ordering
1246 cmpPred env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2)
1247 -- Compare types as well as names for implicit parameters
1248 -- This comparison is used exclusively (I think) for the
1249 -- finite map built in TcSimplify
1250 cmpPred env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
1251 cmpPred env (IParam _ _) (ClassP _ _) = LT
1252 cmpPred env (ClassP _ _) (IParam _ _) = GT