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, isDataType, isNewType,
69 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
70 namesOfType, usageAnnOfType, typeKind, addFreeTyVars,
73 -- Tidying up for printing
75 tidyOpenType, tidyOpenTypes,
76 tidyTyVar, tidyTyVars, tidyFreeTyVars,
77 tidyTopType, tidyPred,
84 #include "HsVersions.h"
86 -- We import the representation and primitive functions from TypeRep.
87 -- Many things are reexported, but not the representation!
93 import {-# SOURCE #-} DataCon( DataCon )
94 import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
95 import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy )
98 import Var ( Var, TyVar, tyVarKind, tyVarName, setTyVarName )
102 import OccName ( mkDictOcc )
103 import Name ( Name, NamedThing(..), OccName, mkLocalName, tidyOccName )
105 import Class ( classTyCon, classHasFDs, Class )
106 import TyCon ( TyCon,
107 isUnboxedTupleTyCon, isUnLiftedTyCon,
108 isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep,
109 isAlgTyCon, isSynTyCon, tyConArity,
110 tyConKind, tyConDataCons, getSynTyConDefn,
115 import Maybes ( maybeToBool )
116 import SrcLoc ( SrcLoc, noSrcLoc )
117 import PrimRep ( PrimRep(..) )
118 import Unique ( Unique, Uniquable(..) )
119 import Util ( mapAccumL, seqList, thenCmp )
121 import UniqSet ( sizeUniqSet ) -- Should come via VarSet
125 %************************************************************************
127 \subsection{Stuff to do with kinds.}
129 %************************************************************************
132 hasMoreBoxityInfo :: Kind -> Kind -> Bool
133 hasMoreBoxityInfo k1 k2
134 | k2 == openTypeKind = True
135 | otherwise = k1 == k2
137 defaultKind :: Kind -> Kind
138 -- Used when generalising: default kind '?' to '*'
139 defaultKind kind | kind == openTypeKind = liftedTypeKind
144 %************************************************************************
146 \subsection{Constructor-specific functions}
148 %************************************************************************
151 ---------------------------------------------------------------------
155 mkTyVarTy :: TyVar -> Type
158 mkTyVarTys :: [TyVar] -> [Type]
159 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
161 getTyVar :: String -> Type -> TyVar
162 getTyVar msg (TyVarTy tv) = tv
163 getTyVar msg (PredTy p) = getTyVar msg (predRepTy p)
164 getTyVar msg (NoteTy _ t) = getTyVar msg t
165 getTyVar msg ty@(UsageTy _ _) = pprPanic "getTyVar: UTy:" (text msg $$ pprType ty)
166 getTyVar msg other = panic ("getTyVar: " ++ msg)
168 getTyVar_maybe :: Type -> Maybe TyVar
169 getTyVar_maybe (TyVarTy tv) = Just tv
170 getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
171 getTyVar_maybe (PredTy p) = getTyVar_maybe (predRepTy p)
172 getTyVar_maybe ty@(UsageTy _ _) = pprPanic "getTyVar_maybe: UTy:" (pprType ty)
173 getTyVar_maybe other = Nothing
175 isTyVarTy :: Type -> Bool
176 isTyVarTy (TyVarTy tv) = True
177 isTyVarTy (NoteTy _ ty) = isTyVarTy ty
178 isTyVarTy (PredTy p) = isTyVarTy (predRepTy p)
179 isTyVarTy ty@(UsageTy _ _) = pprPanic "isTyVarTy: UTy:" (pprType ty)
180 isTyVarTy other = False
184 ---------------------------------------------------------------------
187 We need to be pretty careful with AppTy to make sure we obey the
188 invariant that a TyConApp is always visibly so. mkAppTy maintains the
192 mkAppTy orig_ty1 orig_ty2
193 = ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind *
194 UASSERT2( not (isUTy orig_ty2), pprType orig_ty1 <+> pprType orig_ty2 )
195 -- argument must be unannotated
198 mk_app (NoteTy _ ty1) = mk_app ty1
199 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
200 mk_app ty@(UsageTy _ _) = pprPanic "mkAppTy: UTy:" (pprType ty)
201 mk_app ty1 = AppTy orig_ty1 orig_ty2
203 mkAppTys :: Type -> [Type] -> Type
204 mkAppTys orig_ty1 [] = orig_ty1
205 -- This check for an empty list of type arguments
206 -- avoids the needless loss of a type synonym constructor.
207 -- For example: mkAppTys Rational []
208 -- returns to (Ratio Integer), which has needlessly lost
209 -- the Rational part.
210 mkAppTys orig_ty1 orig_tys2
211 = ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind *
212 UASSERT2( not (any isUTy orig_tys2), pprType orig_ty1 <+> fsep (map pprType orig_tys2) )
213 -- arguments must be unannotated
216 mk_app (NoteTy _ ty1) = mk_app ty1
217 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
218 mk_app ty@(UsageTy _ _) = pprPanic "mkAppTys: UTy:" (pprType ty)
219 mk_app ty1 = foldl AppTy orig_ty1 orig_tys2
221 splitAppTy_maybe :: Type -> Maybe (Type, Type)
222 splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [unUTy ty1], unUTy ty2)
223 splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
224 splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty
225 splitAppTy_maybe (PredTy p) = splitAppTy_maybe (predRepTy p)
226 splitAppTy_maybe (TyConApp tc []) = Nothing
227 splitAppTy_maybe (TyConApp tc tys) = split tys []
229 split [ty2] acc = Just (TyConApp tc (reverse acc), ty2)
230 split (ty:tys) acc = split tys (ty:acc)
232 splitAppTy_maybe ty@(UsageTy _ _) = pprPanic "splitAppTy_maybe: UTy:" (pprType ty)
233 splitAppTy_maybe other = Nothing
235 splitAppTy :: Type -> (Type, Type)
236 splitAppTy ty = case splitAppTy_maybe ty of
238 Nothing -> panic "splitAppTy"
240 splitAppTys :: Type -> (Type, [Type])
241 splitAppTys ty = split ty ty []
243 split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
244 split orig_ty (NoteTy _ ty) args = split orig_ty ty args
245 split orig_ty (PredTy p) args = split orig_ty (predRepTy p) args
246 split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
247 (TyConApp funTyCon [], [unUTy ty1,unUTy ty2])
248 split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
249 split orig_ty (UsageTy _ _) args = pprPanic "splitAppTys: UTy:" (pprType orig_ty)
250 split orig_ty ty args = (orig_ty, args)
254 ---------------------------------------------------------------------
259 mkFunTy :: Type -> Type -> Type
260 mkFunTy arg res = UASSERT2( isUTy arg && isUTy res, pprType arg <+> pprType res )
263 mkFunTys :: [Type] -> Type -> Type
264 mkFunTys tys ty = UASSERT2( all isUTy (ty:tys), fsep (map pprType (tys++[ty])) )
267 splitFunTy :: Type -> (Type, Type)
268 splitFunTy (FunTy arg res) = (arg, res)
269 splitFunTy (NoteTy _ ty) = splitFunTy ty
270 splitFunTy (PredTy p) = splitFunTy (predRepTy p)
271 splitFunTy ty@(UsageTy _ _) = pprPanic "splitFunTy: UTy:" (pprType ty)
273 splitFunTy_maybe :: Type -> Maybe (Type, Type)
274 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
275 splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
276 splitFunTy_maybe (PredTy p) = splitFunTy_maybe (predRepTy p)
277 splitFunTy_maybe ty@(UsageTy _ _) = pprPanic "splitFunTy_maybe: UTy:" (pprType ty)
278 splitFunTy_maybe other = Nothing
280 splitFunTys :: Type -> ([Type], Type)
281 splitFunTys ty = split [] ty ty
283 split args orig_ty (FunTy arg res) = split (arg:args) res res
284 split args orig_ty (NoteTy _ ty) = split args orig_ty ty
285 split args orig_ty (PredTy p) = split args orig_ty (predRepTy p)
286 split args orig_ty (UsageTy _ _) = pprPanic "splitFunTys: UTy:" (pprType orig_ty)
287 split args orig_ty ty = (reverse args, orig_ty)
289 splitFunTysN :: String -> Int -> Type -> ([Type], Type)
290 splitFunTysN msg orig_n orig_ty = split orig_n [] orig_ty orig_ty
292 split 0 args syn_ty ty = (reverse args, syn_ty)
293 split n args syn_ty (FunTy arg res) = split (n-1) (arg:args) res res
294 split n args syn_ty (NoteTy _ ty) = split n args syn_ty ty
295 split n args syn_ty (PredTy p) = split n args syn_ty (predRepTy p)
296 split n args syn_ty (UsageTy _ _) = pprPanic "splitFunTysN: UTy:" (pprType orig_ty)
297 split n args syn_ty ty = pprPanic ("splitFunTysN: " ++ msg) (int orig_n <+> pprType orig_ty)
299 zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
300 zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
302 split acc [] nty ty = (reverse acc, nty)
303 split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
304 split acc xs nty (NoteTy _ ty) = split acc xs nty ty
305 split acc xs nty (PredTy p) = split acc xs nty (predRepTy p)
306 split acc xs nty (UsageTy _ _) = pprPanic "zipFunTys: UTy:" (ppr orig_xs <+> pprType orig_ty)
307 split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty)
309 funResultTy :: Type -> Type
310 funResultTy (FunTy arg res) = res
311 funResultTy (NoteTy _ ty) = funResultTy ty
312 funResultTy (PredTy p) = funResultTy (predRepTy p)
313 funResultTy (UsageTy _ ty) = funResultTy ty
314 funResultTy ty = pprPanic "funResultTy" (pprType ty)
316 funArgTy :: Type -> Type
317 funArgTy (FunTy arg res) = arg
318 funArgTy (NoteTy _ ty) = funArgTy ty
319 funArgTy (PredTy p) = funArgTy (predRepTy p)
320 funArgTy (UsageTy _ ty) = funArgTy ty
321 funArgTy ty = pprPanic "funArgTy" (pprType ty)
325 ---------------------------------------------------------------------
330 mkTyConApp :: TyCon -> [Type] -> Type
332 | isFunTyCon tycon && length tys == 2
334 (ty1:ty2:_) -> FunTy (mkUTyM ty1) (mkUTyM ty2)
337 = ASSERT(not (isSynTyCon tycon))
338 UASSERT2( not (any isUTy tys), ppr tycon <+> fsep (map pprType tys) )
341 mkTyConTy :: TyCon -> Type
342 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
345 -- splitTyConApp "looks through" synonyms, because they don't
346 -- mean a distinct type, but all other type-constructor applications
347 -- including functions are returned as Just ..
349 tyConAppTyCon :: Type -> TyCon
350 tyConAppTyCon ty = case splitTyConApp_maybe ty of
352 Nothing -> pprPanic "tyConAppTyCon" (pprType ty)
354 tyConAppArgs :: Type -> [Type]
355 tyConAppArgs ty = case splitTyConApp_maybe ty of
356 Just (_,args) -> args
357 Nothing -> pprPanic "tyConAppArgs" (pprType ty)
359 splitTyConApp :: Type -> (TyCon, [Type])
360 splitTyConApp ty = case splitTyConApp_maybe ty of
362 Nothing -> pprPanic "splitTyConApp" (pprType ty)
364 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
365 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
366 splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [unUTy arg,unUTy res])
367 splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
368 splitTyConApp_maybe (PredTy p) = splitTyConApp_maybe (predRepTy p)
369 splitTyConApp_maybe (UsageTy _ ty) = splitTyConApp_maybe ty
370 splitTyConApp_maybe other = Nothing
372 -- splitAlgTyConApp_maybe looks for
373 -- *saturated* applications of *algebraic* data types
374 -- "Algebraic" => newtype, data type, or dictionary (not function types)
375 -- We return the constructors too, so there had better be some.
377 splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon])
378 splitAlgTyConApp_maybe (TyConApp tc tys)
380 tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
381 splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
382 splitAlgTyConApp_maybe (PredTy p) = splitAlgTyConApp_maybe (predRepTy p)
383 splitAlgTyConApp_maybe (UsageTy _ ty)= splitAlgTyConApp_maybe ty
384 splitAlgTyConApp_maybe other = Nothing
386 splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon])
387 -- Here the "algebraic" property is an *assertion*
388 splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
389 (tc, tys, tyConDataCons tc)
390 splitAlgTyConApp (NoteTy _ ty) = splitAlgTyConApp ty
391 splitAlgTyConApp (PredTy p) = splitAlgTyConApp (predRepTy p)
392 splitAlgTyConApp (UsageTy _ ty) = splitAlgTyConApp ty
394 splitAlgTyConApp ty = pprPanic "splitAlgTyConApp" (pprType ty)
399 ---------------------------------------------------------------------
404 mkSynTy syn_tycon tys
405 = ASSERT( isSynTyCon syn_tycon )
406 ASSERT( length tyvars == length tys )
407 NoteTy (SynNote (TyConApp syn_tycon tys))
408 (substTy (mkTyVarSubst tyvars tys) body)
410 (tyvars, body) = getSynTyConDefn syn_tycon
412 deNoteType :: Type -> Type
413 -- Remove synonyms, but not Preds
414 deNoteType ty@(TyVarTy tyvar) = ty
415 deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
416 deNoteType (PredTy p) = PredTy (deNotePred p)
417 deNoteType (NoteTy _ ty) = deNoteType ty
418 deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg)
419 deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg)
420 deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty)
421 deNoteType (UsageTy u ty) = UsageTy u (deNoteType ty)
423 deNotePred :: PredType -> PredType
424 deNotePred (ClassP c tys) = ClassP c (map deNoteType tys)
425 deNotePred (IParam n ty) = IParam n (deNoteType ty)
428 Notes on type synonyms
429 ~~~~~~~~~~~~~~~~~~~~~~
430 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
431 to return type synonyms whereever possible. Thus
436 splitFunTys (a -> Foo a) = ([a], Foo a)
439 The reason is that we then get better (shorter) type signatures in
440 interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
446 repType looks through
451 (e) usage annotations
452 It's useful in the back end where we're not
453 interested in newtypes anymore.
456 repType :: Type -> Type
457 repType (ForAllTy _ ty) = repType ty
458 repType (NoteTy _ ty) = repType ty
459 repType (PredTy p) = repType (predRepTy p)
460 repType (UsageTy _ ty) = repType ty
461 repType ty = case splitNewType_maybe ty of
462 Just ty' -> repType ty' -- Still re-apply repType in case of for-all
465 splitRepFunTys :: Type -> ([Type], Type)
466 -- Like splitFunTys, but looks through newtypes and for-alls
467 splitRepFunTys ty = split [] (repType ty)
469 split args (FunTy arg res) = split (arg:args) (repType res)
470 split args ty = (reverse args, ty)
472 typePrimRep :: Type -> PrimRep
473 typePrimRep ty = case repType ty of
474 TyConApp tc _ -> tyConPrimRep tc
476 AppTy _ _ -> PtrRep -- ??
479 splitNewType_maybe :: Type -> Maybe Type
480 -- Find the representation of a newtype, if it is one
481 -- Looks through multiple levels of newtype, but does not look through for-alls
482 splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty
483 splitNewType_maybe (PredTy p) = splitNewType_maybe (predRepTy p)
484 splitNewType_maybe (UsageTy _ ty) = splitNewType_maybe ty
485 splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of
486 Just rep_ty -> ASSERT( length tys == tyConArity tc )
487 -- The assert should hold because repType should
488 -- only be applied to *types* (of kind *)
489 Just (applyTys rep_ty tys)
491 splitNewType_maybe other = Nothing
496 ---------------------------------------------------------------------
501 mkForAllTy :: TyVar -> Type -> Type
503 = mkForAllTys [tyvar] ty
505 mkForAllTys :: [TyVar] -> Type -> Type
506 mkForAllTys tyvars ty
507 = case splitUTy_maybe ty of
508 Just (u,ty1) -> UASSERT2( not (mkVarSet tyvars `intersectsVarSet` tyVarsOfType u),
509 ptext SLIT("mkForAllTys: usage scope")
510 <+> ppr tyvars <+> pprType ty )
511 mkUTy u (foldr ForAllTy ty1 tyvars) -- we lift usage annotations over foralls
512 Nothing -> foldr ForAllTy ty tyvars
514 isForAllTy :: Type -> Bool
515 isForAllTy (NoteTy _ ty) = isForAllTy ty
516 isForAllTy (ForAllTy _ _) = True
517 isForAllTy (UsageTy _ ty) = isForAllTy ty
518 isForAllTy other_ty = False
520 splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
521 splitForAllTy_maybe ty = splitFAT_m ty
523 splitFAT_m (NoteTy _ ty) = splitFAT_m ty
524 splitFAT_m (PredTy p) = splitFAT_m (predRepTy p)
525 splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
526 splitFAT_m (UsageTy _ ty) = splitFAT_m ty
527 splitFAT_m _ = Nothing
529 splitForAllTys :: Type -> ([TyVar], Type)
530 splitForAllTys ty = split ty ty []
532 split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
533 split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
534 split orig_ty (PredTy p) tvs = split orig_ty (predRepTy p) tvs
535 split orig_ty (UsageTy _ ty) tvs = split orig_ty ty tvs
536 split orig_ty t tvs = (reverse tvs, orig_ty)
539 -- (mkPiType now in CoreUtils)
541 Applying a for-all to its arguments. Lift usage annotation as required.
544 applyTy :: Type -> Type -> Type
545 applyTy (PredTy p) arg = applyTy (predRepTy p) arg
546 applyTy (NoteTy _ fun) arg = applyTy fun arg
547 applyTy (ForAllTy tv ty) arg = UASSERT2( not (isUTy arg),
548 ptext SLIT("applyTy")
549 <+> pprType ty <+> pprType arg )
550 substTy (mkTyVarSubst [tv] [arg]) ty
551 applyTy (UsageTy u ty) arg = UsageTy u (applyTy ty arg)
552 applyTy other arg = panic "applyTy"
554 applyTys :: Type -> [Type] -> Type
555 applyTys fun_ty arg_tys
556 = UASSERT2( not (any isUTy arg_tys), ptext SLIT("applyTys") <+> pprType fun_ty )
560 substTy (mkTyVarSubst tvs arg_tys) ty
562 (mu, tvs, ty) = split fun_ty arg_tys
564 split fun_ty [] = (Nothing, [], fun_ty)
565 split (NoteTy _ fun_ty) args = split fun_ty args
566 split (PredTy p) args = split (predRepTy p) args
567 split (ForAllTy tv fun_ty) (arg:args) = case split fun_ty args of
568 (mu, tvs, ty) -> (mu, tv:tvs, ty)
569 split (UsageTy u ty) args = case split ty args of
570 (Nothing, tvs, ty) -> (Just u, tvs, ty)
571 (Just _ , _ , _ ) -> pprPanic "applyTys:"
573 split other_ty args = panic "applyTys"
577 hoistForAllTys :: Type -> Type
578 -- Move all the foralls to the top
579 -- e.g. T -> forall a. a ==> forall a. T -> a
580 -- Careful: LOSES USAGE ANNOTATIONS!
582 = case hoist ty of { (tvs, body) -> mkForAllTys tvs body }
584 hoist :: Type -> ([TyVar], Type)
585 hoist ty = case splitFunTys ty of { (args, res) ->
586 case splitForAllTys res of {
587 ([], body) -> ([], ty) ;
588 (tvs1, body1) -> case hoist body1 of { (tvs2,body2) ->
589 (tvs1 ++ tvs2, mkFunTys args body2)
594 ---------------------------------------------------------------------
598 Constructing and taking apart usage types.
601 mkUTy :: Type -> Type -> Type
603 = ASSERT2( typeKind u == usageTypeKind, ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
604 UASSERT2( not (isUTy ty), ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
605 -- if u == usMany then ty else : ToDo? KSW 2000-10
612 splitUTy :: Type -> (Type {- :: $ -}, Type)
614 = case splitUTy_maybe orig_ty of
615 Just (u,ty) -> (u,ty)
617 Nothing -> pprPanic "splitUTy:" (pprType orig_ty)
619 Nothing -> (usMany,orig_ty) -- default annotation ToDo KSW 2000-10
622 splitUTy_maybe :: Type -> Maybe (Type {- :: $ -}, Type)
623 splitUTy_maybe (UsageTy u ty) = Just (u,ty)
624 splitUTy_maybe (NoteTy _ ty) = splitUTy_maybe ty
625 splitUTy_maybe other_ty = Nothing
627 isUTy :: Type -> Bool
628 -- has usage annotation
629 isUTy = maybeToBool . splitUTy_maybe
631 uaUTy :: Type -> Type
632 -- extract annotation
633 uaUTy = fst . splitUTy
635 unUTy :: Type -> Type
636 -- extract unannotated type
637 unUTy = snd . splitUTy
641 liftUTy :: (Type -> Type) -> Type -> Type
642 -- lift outer usage annot over operation on unannotated types
645 (u,ty') = splitUTy ty
651 mkUTyM :: Type -> Type
652 -- put TOP (no info) annotation on unannotated type
653 mkUTyM ty = mkUTy usMany ty
657 isUsageKind :: Kind -> Bool
659 = ASSERT( typeKind k == superKind )
662 isUsage :: Type -> Bool
664 = isUsageKind (typeKind ty)
666 isUTyVar :: Var -> Bool
668 = isUsageKind (tyVarKind v)
672 %************************************************************************
674 \subsection{Predicates}
676 %************************************************************************
678 "Dictionary" types are just ordinary data types, but you can
679 tell from the type constructor whether it's a dictionary or not.
682 mkClassPred clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) )
685 isClassPred (ClassP clas tys) = True
686 isClassPred other = False
688 isIPPred (IParam _ _) = True
689 isIPPred other = False
691 isTyVarClassPred (ClassP clas tys) = all isTyVarTy tys
692 isTyVarClassPred other = False
694 getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
695 getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
696 getClassPredTys_maybe _ = Nothing
698 getClassPredTys :: PredType -> (Class, [Type])
699 getClassPredTys (ClassP clas tys) = (clas, tys)
701 inheritablePred :: PredType -> Bool
702 -- Can be inherited by a context. For example, consider
703 -- f x = let g y = (?v, y+x)
704 -- in (g 3 with ?v = 8,
706 -- The point is that g's type must be quantifed over ?v:
707 -- g :: (?v :: a) => a -> a
708 -- but it doesn't need to be quantified over the Num a dictionary
709 -- which can be free in g's rhs, and shared by both calls to g
710 inheritablePred (ClassP _ _) = True
711 inheritablePred other = False
713 predMentionsIPs :: PredType -> NameSet -> Bool
714 predMentionsIPs (IParam n _) ns = n `elemNameSet` ns
715 predMentionsIPs other ns = False
717 predHasFDs :: PredType -> Bool
718 -- True if the predicate has functional depenencies;
719 -- I.e. should participate in improvement
720 predHasFDs (IParam _ _) = True
721 predHasFDs (ClassP cls _) = classHasFDs cls
723 mkDictTy :: Class -> [Type] -> Type
724 mkDictTy clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) )
725 mkPredTy (ClassP clas tys)
727 mkPredTy :: PredType -> Type
728 mkPredTy pred = PredTy pred
730 mkPredTys :: ThetaType -> [Type]
731 mkPredTys preds = map PredTy preds
733 predTyUnique :: PredType -> Unique
734 predTyUnique (IParam n _) = getUnique n
735 predTyUnique (ClassP clas tys) = getUnique clas
737 predRepTy :: PredType -> Type
738 -- Convert a predicate to its "representation type";
739 -- the type of evidence for that predicate, which is actually passed at runtime
740 predRepTy (ClassP clas tys) = TyConApp (classTyCon clas) tys
741 predRepTy (IParam n ty) = ty
743 isPredTy :: Type -> Bool
744 isPredTy (NoteTy _ ty) = isPredTy ty
745 isPredTy (PredTy _) = True
746 isPredTy (UsageTy _ ty)= isPredTy ty
749 isDictTy :: Type -> Bool
750 isDictTy (NoteTy _ ty) = isDictTy ty
751 isDictTy (PredTy (ClassP _ _)) = True
752 isDictTy (UsageTy _ ty) = isDictTy ty
753 isDictTy other = False
755 splitPredTy_maybe :: Type -> Maybe PredType
756 splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty
757 splitPredTy_maybe (PredTy p) = Just p
758 splitPredTy_maybe (UsageTy _ ty)= splitPredTy_maybe ty
759 splitPredTy_maybe other = Nothing
761 splitDictTy :: Type -> (Class, [Type])
762 splitDictTy (NoteTy _ ty) = splitDictTy ty
763 splitDictTy (PredTy (ClassP clas tys)) = (clas, tys)
765 splitDictTy_maybe :: Type -> Maybe (Class, [Type])
766 splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty
767 splitDictTy_maybe (PredTy (ClassP clas tys)) = Just (clas, tys)
768 splitDictTy_maybe other = Nothing
770 splitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
771 -- Split the type of a dictionary function
773 = case splitSigmaTy ty of { (tvs, theta, tau) ->
774 case splitDictTy tau of { (clas, tys) ->
775 (tvs, theta, clas, tys) }}
777 namesOfDFunHead :: Type -> NameSet
778 -- Find the free type constructors and classes
779 -- of the head of the dfun instance type
780 -- The 'dfun_head_type' is because of
781 -- instance Foo a => Baz T where ...
782 -- The decl is an orphan if Baz and T are both not locally defined,
783 -- even if Foo *is* locally defined
784 namesOfDFunHead dfun_ty = case splitSigmaTy dfun_ty of
785 (tvs,_,head_ty) -> delListFromNameSet (namesOfType head_ty)
788 mkPredName :: Unique -> SrcLoc -> PredType -> Name
789 mkPredName uniq loc (ClassP cls tys) = mkLocalName uniq (mkDictOcc (getOccName cls)) loc
790 mkPredName uniq loc (IParam name ty) = name
793 %************************************************************************
795 \subsection{Tau, sigma and rho}
797 %************************************************************************
799 @isTauTy@ tests for nested for-alls.
802 isTauTy :: Type -> Bool
803 isTauTy (TyVarTy v) = True
804 isTauTy (TyConApp _ tys) = all isTauTy tys
805 isTauTy (AppTy a b) = isTauTy a && isTauTy b
806 isTauTy (FunTy a b) = isTauTy a && isTauTy b
807 isTauTy (PredTy p) = isTauTy (predRepTy p)
808 isTauTy (NoteTy _ ty) = isTauTy ty
809 isTauTy (UsageTy _ ty) = isTauTy ty
810 isTauTy other = False
814 mkRhoTy :: [PredType] -> Type -> Type
815 mkRhoTy theta ty = UASSERT2( not (isUTy ty), pprType ty )
816 foldr (\p r -> FunTy (mkUTyM (mkPredTy p)) (mkUTyM r)) ty theta
818 splitRhoTy :: Type -> ([PredType], Type)
819 splitRhoTy ty = split ty ty []
821 split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of
822 Just p -> split res res (p:ts)
823 Nothing -> (reverse ts, orig_ty)
824 split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts
825 split orig_ty (UsageTy _ ty) ts = split orig_ty ty ts
826 split orig_ty ty ts = (reverse ts, orig_ty)
829 The type of a method for class C is always of the form:
830 Forall a1..an. C a1..an => sig_ty
831 where sig_ty is the type given by the method's signature, and thus in general
832 is a ForallTy. At the point that splitMethodTy is called, it is expected
833 that the outer Forall has already been stripped off. splitMethodTy then
834 returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes or
838 splitMethodTy :: Type -> (PredType, Type)
839 splitMethodTy ty = split ty
841 split (FunTy arg res) = case splitPredTy_maybe arg of
843 Nothing -> panic "splitMethodTy"
844 split (NoteTy _ ty) = split ty
845 split (UsageTy _ ty) = split ty
846 split _ = panic "splitMethodTy"
850 isSigmaType returns true of any qualified type. It doesn't *necessarily* have
852 f :: (?x::Int) => Int -> Int
855 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
857 isSigmaTy :: Type -> Bool
858 isSigmaTy (ForAllTy tyvar ty) = True
859 isSigmaTy (FunTy a b) = isPredTy a
860 isSigmaTy (NoteTy _ ty) = isSigmaTy ty
861 isSigmaTy (UsageTy _ ty) = isSigmaTy ty
864 splitSigmaTy :: Type -> ([TyVar], [PredType], Type)
868 (tyvars,rho) = splitForAllTys ty
869 (theta,tau) = splitRhoTy rho
873 getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
874 -- construct a dictionary function name
875 getDFunTyKey (TyVarTy tv) = getOccName tv
876 getDFunTyKey (TyConApp tc _) = getOccName tc
877 getDFunTyKey (AppTy fun _) = getDFunTyKey fun
878 getDFunTyKey (NoteTy _ t) = getDFunTyKey t
879 getDFunTyKey (FunTy arg _) = getOccName funTyCon
880 getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
881 getDFunTyKey (UsageTy _ t) = getDFunTyKey t
882 -- PredTy shouldn't happen
886 %************************************************************************
888 \subsection{Kinds and free variables}
890 %************************************************************************
892 ---------------------------------------------------------------------
893 Finding the kind of a type
894 ~~~~~~~~~~~~~~~~~~~~~~~~~~
896 typeKind :: Type -> Kind
898 typeKind (TyVarTy tyvar) = tyVarKind tyvar
899 typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
900 typeKind (NoteTy _ ty) = typeKind ty
901 typeKind (PredTy _) = liftedTypeKind -- Predicates are always
902 -- represented by lifted types
903 typeKind (AppTy fun arg) = funResultTy (typeKind fun)
905 typeKind (FunTy arg res) = fix_up (typeKind res)
907 fix_up (TyConApp tycon _) | tycon == typeCon
908 || tycon == openKindCon = liftedTypeKind
909 fix_up (NoteTy _ kind) = fix_up kind
911 -- The basic story is
912 -- typeKind (FunTy arg res) = typeKind res
913 -- But a function is lifted regardless of its result type
914 -- Hence the strange fix-up.
915 -- Note that 'res', being the result of a FunTy, can't have
916 -- a strange kind like (*->*).
918 typeKind (ForAllTy tv ty) = typeKind ty
919 typeKind (UsageTy _ ty) = typeKind ty -- we don't have separate kinds for ann/unann
923 ---------------------------------------------------------------------
924 Free variables of a type
925 ~~~~~~~~~~~~~~~~~~~~~~~~
928 tyVarsOfType :: Type -> TyVarSet
929 tyVarsOfType (TyVarTy tv) = unitVarSet tv
930 tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
931 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
932 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
933 tyVarsOfType (PredTy p) = tyVarsOfPred p
934 tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
935 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
936 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
937 tyVarsOfType (UsageTy u ty) = tyVarsOfType u `unionVarSet` tyVarsOfType ty
939 tyVarsOfTypes :: [Type] -> TyVarSet
940 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
942 tyVarsOfPred :: PredType -> TyVarSet
943 tyVarsOfPred (ClassP clas tys) = tyVarsOfTypes tys
944 tyVarsOfPred (IParam n ty) = tyVarsOfType ty
946 tyVarsOfTheta :: ThetaType -> TyVarSet
947 tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
949 -- Add a Note with the free tyvars to the top of the type
950 addFreeTyVars :: Type -> Type
951 addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
952 addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
954 -- Find the free names of a type, including the type constructors and classes it mentions
955 namesOfType :: Type -> NameSet
956 namesOfType (TyVarTy tv) = unitNameSet (getName tv)
957 namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets`
959 namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1
960 namesOfType (NoteTy other_note ty2) = namesOfType ty2
961 namesOfType (PredTy p) = namesOfType (predRepTy p)
962 namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
963 namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
964 namesOfType (ForAllTy tyvar ty) = namesOfType ty `delFromNameSet` getName tyvar
965 namesOfType (UsageTy u ty) = namesOfType u `unionNameSets` namesOfType ty
967 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
970 Usage annotations of a type
971 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
973 Get a list of usage annotations of a type, *in left-to-right pre-order*.
976 usageAnnOfType :: Type -> [Type]
981 goT (AppTy ty1 ty2) = goT ty1 ++ goT ty2
982 goT (TyConApp tc tys) = concatMap goT tys
983 goT (FunTy sty1 sty2) = goS sty1 ++ goS sty2
984 goT (ForAllTy mv ty) = goT ty
985 goT (PredTy p) = goT (predRepTy p)
986 goT ty@(UsageTy _ _) = pprPanic "usageAnnOfType: unexpected usage:" (pprType ty)
987 goT (NoteTy note ty) = goT ty
989 goS sty = case splitUTy sty of
990 (u,tty) -> u : goT tty
994 %************************************************************************
996 \subsection{TidyType}
998 %************************************************************************
1000 tidyTy tidies up a type for printing in an error message, or in
1003 It doesn't change the uniques at all, just the print names.
1006 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
1007 tidyTyVar env@(tidy_env, subst) tyvar
1008 = case lookupVarEnv subst tyvar of
1010 Just tyvar' -> -- Already substituted
1013 Nothing -> -- Make a new nice name for it
1015 case tidyOccName tidy_env (getOccName name) of
1016 (tidy', occ') -> -- New occname reqd
1017 ((tidy', subst'), tyvar')
1019 subst' = extendVarEnv subst tyvar tyvar'
1020 tyvar' = setTyVarName tyvar name'
1021 name' = mkLocalName (getUnique name) occ' noSrcLoc
1022 -- Note: make a *user* tyvar, so it printes nicely
1023 -- Could extract src loc, but no need.
1025 name = tyVarName tyvar
1027 tidyTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
1028 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
1030 tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
1031 -- Add the free tyvars to the env in tidy form,
1032 -- so that we can tidy the type they are free in
1033 tidyFreeTyVars env tyvars = foldl add env (varSetElems tyvars)
1035 add env tv = fst (tidyTyVar env tv)
1037 tidyType :: TidyEnv -> Type -> Type
1038 tidyType env@(tidy_env, subst) ty
1041 go (TyVarTy tv) = case lookupVarEnv subst tv of
1042 Nothing -> TyVarTy tv
1043 Just tv' -> TyVarTy tv'
1044 go (TyConApp tycon tys) = let args = map go tys
1045 in args `seqList` TyConApp tycon args
1046 go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
1047 go (PredTy p) = PredTy (tidyPred env p)
1048 go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
1049 go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
1050 go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty)
1052 (envp, tvp) = tidyTyVar env tv
1053 go (UsageTy u ty) = (UsageTy SAPPLY (go u)) SAPPLY (go ty)
1055 go_note (SynNote ty) = SynNote SAPPLY (go ty)
1056 go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
1058 tidyTypes env tys = map (tidyType env) tys
1060 tidyPred :: TidyEnv -> PredType -> PredType
1061 tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
1062 tidyPred env (IParam n ty) = IParam n (tidyType env ty)
1066 @tidyOpenType@ grabs the free type variables, tidies them
1067 and then uses @tidyType@ to work over the type itself
1070 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
1072 = (env', tidyType env' ty)
1074 env' = tidyFreeTyVars env (tyVarsOfType ty)
1076 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
1077 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
1079 tidyTopType :: Type -> Type
1080 tidyTopType ty = tidyType emptyTidyEnv ty
1085 %************************************************************************
1087 \subsection{Liftedness}
1089 %************************************************************************
1092 isUnLiftedType :: Type -> Bool
1093 -- isUnLiftedType returns True for forall'd unlifted types:
1094 -- x :: forall a. Int#
1095 -- I found bindings like these were getting floated to the top level.
1096 -- They are pretty bogus types, mind you. It would be better never to
1099 isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
1100 isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty
1101 isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
1102 isUnLiftedType (UsageTy _ ty) = isUnLiftedType ty
1103 isUnLiftedType other = False
1105 isUnboxedTupleType :: Type -> Bool
1106 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
1107 Just (tc, ty_args) -> isUnboxedTupleTyCon tc
1110 -- Should only be applied to *types*; hence the assert
1111 isAlgType :: Type -> Bool
1112 isAlgType ty = case splitTyConApp_maybe ty of
1113 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1117 -- Should only be applied to *types*; hence the assert
1118 isDataType :: Type -> Bool
1119 isDataType ty = case splitTyConApp_maybe ty of
1120 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1124 isNewType :: Type -> Bool
1125 isNewType ty = case splitTyConApp_maybe ty of
1126 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1132 %************************************************************************
1134 \subsection{Sequencing on types
1136 %************************************************************************
1139 seqType :: Type -> ()
1140 seqType (TyVarTy tv) = tv `seq` ()
1141 seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
1142 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
1143 seqType (NoteTy note t2) = seqNote note `seq` seqType t2
1144 seqType (PredTy p) = seqPred p
1145 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
1146 seqType (ForAllTy tv ty) = tv `seq` seqType ty
1147 seqType (UsageTy u ty) = seqType u `seq` seqType ty
1149 seqTypes :: [Type] -> ()
1151 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
1153 seqNote :: TyNote -> ()
1154 seqNote (SynNote ty) = seqType ty
1155 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
1157 seqPred :: PredType -> ()
1158 seqPred (ClassP c tys) = c `seq` seqTypes tys
1159 seqPred (IParam n ty) = n `seq` seqType ty
1163 %************************************************************************
1165 \subsection{Equality on types}
1167 %************************************************************************
1171 instance Eq Type where
1172 ty1 == ty2 = case ty1 `compare` ty2 of { EQ -> True; other -> False }
1174 instance Ord Type where
1175 compare ty1 ty2 = cmpTy emptyVarEnv ty1 ty2
1177 cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
1178 -- The "env" maps type variables in ty1 to type variables in ty2
1179 -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
1180 -- we in effect substitute tv2 for tv1 in t1 before continuing
1182 -- Get rid of NoteTy
1183 cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
1184 cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
1186 -- Get rid of PredTy
1187 cmpTy env (PredTy p1) (PredTy p2) = cmpPred env p1 p2
1188 cmpTy env (PredTy p1) ty2 = cmpTy env (predRepTy p1) ty2
1189 cmpTy env ty1 (PredTy p2) = cmpTy env ty1 (predRepTy p2)
1191 -- Deal with equal constructors
1192 cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
1193 Just tv1a -> tv1a `compare` tv2
1194 Nothing -> tv1 `compare` tv2
1196 cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1197 cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1198 cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
1199 cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2
1200 cmpTy env (UsageTy u1 t1) (UsageTy u2 t2) = cmpTy env u1 u2 `thenCmp` cmpTy env t1 t2
1202 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < UsageTy
1203 cmpTy env (AppTy _ _) (TyVarTy _) = GT
1205 cmpTy env (FunTy _ _) (TyVarTy _) = GT
1206 cmpTy env (FunTy _ _) (AppTy _ _) = GT
1208 cmpTy env (TyConApp _ _) (TyVarTy _) = GT
1209 cmpTy env (TyConApp _ _) (AppTy _ _) = GT
1210 cmpTy env (TyConApp _ _) (FunTy _ _) = GT
1212 cmpTy env (ForAllTy _ _) (TyVarTy _) = GT
1213 cmpTy env (ForAllTy _ _) (AppTy _ _) = GT
1214 cmpTy env (ForAllTy _ _) (FunTy _ _) = GT
1215 cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT
1217 cmpTy env (UsageTy _ _) other = GT
1222 cmpTys env [] [] = EQ
1223 cmpTys env (t:ts) [] = GT
1224 cmpTys env [] (t:ts) = LT
1225 cmpTys env (t1:t1s) (t2:t2s) = cmpTy env t1 t2 `thenCmp` cmpTys env t1s t2s
1229 instance Eq PredType where
1230 p1 == p2 = case p1 `compare` p2 of { EQ -> True; other -> False }
1232 instance Ord PredType where
1233 compare p1 p2 = cmpPred emptyVarEnv p1 p2
1235 cmpPred :: TyVarEnv TyVar -> PredType -> PredType -> Ordering
1236 cmpPred env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2)
1237 -- Compare types as well as names for implicit parameters
1238 -- This comparison is used exclusively (I think) for the
1239 -- finite map built in TcSimplify
1240 cmpPred env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
1241 cmpPred env (IParam _ _) (ClassP _ _) = LT
1242 cmpPred env (ClassP _ _) (IParam _ _) = GT