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,
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, 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 mkDictTy :: Class -> [Type] -> Type
718 mkDictTy clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) )
719 mkPredTy (ClassP clas tys)
721 mkPredTy :: PredType -> Type
722 mkPredTy pred = PredTy pred
724 mkPredTys :: ThetaType -> [Type]
725 mkPredTys preds = map PredTy preds
727 predTyUnique :: PredType -> Unique
728 predTyUnique (IParam n _) = getUnique n
729 predTyUnique (ClassP clas tys) = getUnique clas
731 predRepTy :: PredType -> Type
732 -- Convert a predicate to its "representation type";
733 -- the type of evidence for that predicate, which is actually passed at runtime
734 predRepTy (ClassP clas tys) = TyConApp (classTyCon clas) tys
735 predRepTy (IParam n ty) = ty
737 isPredTy :: Type -> Bool
738 isPredTy (NoteTy _ ty) = isPredTy ty
739 isPredTy (PredTy _) = True
740 isPredTy (UsageTy _ ty)= isPredTy ty
743 isDictTy :: Type -> Bool
744 isDictTy (NoteTy _ ty) = isDictTy ty
745 isDictTy (PredTy (ClassP _ _)) = True
746 isDictTy (UsageTy _ ty) = isDictTy ty
747 isDictTy other = False
749 splitPredTy_maybe :: Type -> Maybe PredType
750 splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty
751 splitPredTy_maybe (PredTy p) = Just p
752 splitPredTy_maybe (UsageTy _ ty)= splitPredTy_maybe ty
753 splitPredTy_maybe other = Nothing
755 splitDictTy :: Type -> (Class, [Type])
756 splitDictTy (NoteTy _ ty) = splitDictTy ty
757 splitDictTy (PredTy (ClassP clas tys)) = (clas, tys)
759 splitDictTy_maybe :: Type -> Maybe (Class, [Type])
760 splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty
761 splitDictTy_maybe (PredTy (ClassP clas tys)) = Just (clas, tys)
762 splitDictTy_maybe other = Nothing
764 splitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
765 -- Split the type of a dictionary function
767 = case splitSigmaTy ty of { (tvs, theta, tau) ->
768 case splitDictTy tau of { (clas, tys) ->
769 (tvs, theta, clas, tys) }}
771 namesOfDFunHead :: Type -> NameSet
772 -- Find the free type constructors and classes
773 -- of the head of the dfun instance type
774 -- The 'dfun_head_type' is because of
775 -- instance Foo a => Baz T where ...
776 -- The decl is an orphan if Baz and T are both not locally defined,
777 -- even if Foo *is* locally defined
778 namesOfDFunHead dfun_ty = case splitSigmaTy dfun_ty of
779 (tvs,_,head_ty) -> delListFromNameSet (namesOfType head_ty)
782 mkPredName :: Unique -> SrcLoc -> PredType -> Name
783 mkPredName uniq loc (ClassP cls tys) = mkLocalName uniq (mkDictOcc (getOccName cls)) loc
784 mkPredName uniq loc (IParam name ty) = name
787 %************************************************************************
789 \subsection{Tau, sigma and rho}
791 %************************************************************************
793 @isTauTy@ tests for nested for-alls.
796 isTauTy :: Type -> Bool
797 isTauTy (TyVarTy v) = True
798 isTauTy (TyConApp _ tys) = all isTauTy tys
799 isTauTy (AppTy a b) = isTauTy a && isTauTy b
800 isTauTy (FunTy a b) = isTauTy a && isTauTy b
801 isTauTy (PredTy p) = isTauTy (predRepTy p)
802 isTauTy (NoteTy _ ty) = isTauTy ty
803 isTauTy (UsageTy _ ty) = isTauTy ty
804 isTauTy other = False
808 mkRhoTy :: [PredType] -> Type -> Type
809 mkRhoTy theta ty = UASSERT2( not (isUTy ty), pprType ty )
810 foldr (\p r -> FunTy (mkUTyM (mkPredTy p)) (mkUTyM r)) ty theta
812 splitRhoTy :: Type -> ([PredType], Type)
813 splitRhoTy ty = split ty ty []
815 split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of
816 Just p -> split res res (p:ts)
817 Nothing -> (reverse ts, orig_ty)
818 split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts
819 split orig_ty (UsageTy _ ty) ts = split orig_ty ty ts
820 split orig_ty ty ts = (reverse ts, orig_ty)
823 The type of a method for class C is always of the form:
824 Forall a1..an. C a1..an => sig_ty
825 where sig_ty is the type given by the method's signature, and thus in general
826 is a ForallTy. At the point that splitMethodTy is called, it is expected
827 that the outer Forall has already been stripped off. splitMethodTy then
828 returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes or
832 splitMethodTy :: Type -> (PredType, Type)
833 splitMethodTy ty = split ty
835 split (FunTy arg res) = case splitPredTy_maybe arg of
837 Nothing -> panic "splitMethodTy"
838 split (NoteTy _ ty) = split ty
839 split (UsageTy _ ty) = split ty
840 split _ = panic "splitMethodTy"
844 isSigmaType returns true of any qualified type. It doesn't *necessarily* have
846 f :: (?x::Int) => Int -> Int
849 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
851 isSigmaTy :: Type -> Bool
852 isSigmaTy (ForAllTy tyvar ty) = True
853 isSigmaTy (FunTy a b) = isPredTy a
854 isSigmaTy (NoteTy _ ty) = isSigmaTy ty
855 isSigmaTy (UsageTy _ ty) = isSigmaTy ty
858 splitSigmaTy :: Type -> ([TyVar], [PredType], Type)
862 (tyvars,rho) = splitForAllTys ty
863 (theta,tau) = splitRhoTy rho
867 getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
868 -- construct a dictionary function name
869 getDFunTyKey (TyVarTy tv) = getOccName tv
870 getDFunTyKey (TyConApp tc _) = getOccName tc
871 getDFunTyKey (AppTy fun _) = getDFunTyKey fun
872 getDFunTyKey (NoteTy _ t) = getDFunTyKey t
873 getDFunTyKey (FunTy arg _) = getOccName funTyCon
874 getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
875 getDFunTyKey (UsageTy _ t) = getDFunTyKey t
876 -- PredTy shouldn't happen
880 %************************************************************************
882 \subsection{Kinds and free variables}
884 %************************************************************************
886 ---------------------------------------------------------------------
887 Finding the kind of a type
888 ~~~~~~~~~~~~~~~~~~~~~~~~~~
890 typeKind :: Type -> Kind
892 typeKind (TyVarTy tyvar) = tyVarKind tyvar
893 typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
894 typeKind (NoteTy _ ty) = typeKind ty
895 typeKind (PredTy _) = liftedTypeKind -- Predicates are always
896 -- represented by lifted types
897 typeKind (AppTy fun arg) = funResultTy (typeKind fun)
899 typeKind (FunTy arg res) = fix_up (typeKind res)
901 fix_up (TyConApp tycon _) | tycon == typeCon
902 || tycon == openKindCon = liftedTypeKind
903 fix_up (NoteTy _ kind) = fix_up kind
905 -- The basic story is
906 -- typeKind (FunTy arg res) = typeKind res
907 -- But a function is lifted regardless of its result type
908 -- Hence the strange fix-up.
909 -- Note that 'res', being the result of a FunTy, can't have
910 -- a strange kind like (*->*).
912 typeKind (ForAllTy tv ty) = typeKind ty
913 typeKind (UsageTy _ ty) = typeKind ty -- we don't have separate kinds for ann/unann
917 ---------------------------------------------------------------------
918 Free variables of a type
919 ~~~~~~~~~~~~~~~~~~~~~~~~
922 tyVarsOfType :: Type -> TyVarSet
923 tyVarsOfType (TyVarTy tv) = unitVarSet tv
924 tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
925 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
926 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
927 tyVarsOfType (PredTy p) = tyVarsOfPred p
928 tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
929 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
930 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
931 tyVarsOfType (UsageTy u ty) = tyVarsOfType u `unionVarSet` tyVarsOfType ty
933 tyVarsOfTypes :: [Type] -> TyVarSet
934 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
936 tyVarsOfPred :: PredType -> TyVarSet
937 tyVarsOfPred (ClassP clas tys) = tyVarsOfTypes tys
938 tyVarsOfPred (IParam n ty) = tyVarsOfType ty
940 tyVarsOfTheta :: ThetaType -> TyVarSet
941 tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
943 -- Add a Note with the free tyvars to the top of the type
944 addFreeTyVars :: Type -> Type
945 addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
946 addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
948 -- Find the free names of a type, including the type constructors and classes it mentions
949 namesOfType :: Type -> NameSet
950 namesOfType (TyVarTy tv) = unitNameSet (getName tv)
951 namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets`
953 namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1
954 namesOfType (NoteTy other_note ty2) = namesOfType ty2
955 namesOfType (PredTy p) = namesOfType (predRepTy p)
956 namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
957 namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
958 namesOfType (ForAllTy tyvar ty) = namesOfType ty `delFromNameSet` getName tyvar
959 namesOfType (UsageTy u ty) = namesOfType u `unionNameSets` namesOfType ty
961 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
964 Usage annotations of a type
965 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
967 Get a list of usage annotations of a type, *in left-to-right pre-order*.
970 usageAnnOfType :: Type -> [Type]
975 goT (AppTy ty1 ty2) = goT ty1 ++ goT ty2
976 goT (TyConApp tc tys) = concatMap goT tys
977 goT (FunTy sty1 sty2) = goS sty1 ++ goS sty2
978 goT (ForAllTy mv ty) = goT ty
979 goT (PredTy p) = goT (predRepTy p)
980 goT ty@(UsageTy _ _) = pprPanic "usageAnnOfType: unexpected usage:" (pprType ty)
981 goT (NoteTy note ty) = goT ty
983 goS sty = case splitUTy sty of
984 (u,tty) -> u : goT tty
988 %************************************************************************
990 \subsection{TidyType}
992 %************************************************************************
994 tidyTy tidies up a type for printing in an error message, or in
997 It doesn't change the uniques at all, just the print names.
1000 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
1001 tidyTyVar env@(tidy_env, subst) tyvar
1002 = case lookupVarEnv subst tyvar of
1004 Just tyvar' -> -- Already substituted
1007 Nothing -> -- Make a new nice name for it
1009 case tidyOccName tidy_env (getOccName name) of
1010 (tidy', occ') -> -- New occname reqd
1011 ((tidy', subst'), tyvar')
1013 subst' = extendVarEnv subst tyvar tyvar'
1014 tyvar' = setTyVarName tyvar name'
1015 name' = mkLocalName (getUnique name) occ' noSrcLoc
1016 -- Note: make a *user* tyvar, so it printes nicely
1017 -- Could extract src loc, but no need.
1019 name = tyVarName tyvar
1021 tidyTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
1022 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
1024 tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
1025 -- Add the free tyvars to the env in tidy form,
1026 -- so that we can tidy the type they are free in
1027 tidyFreeTyVars env tyvars = foldl add env (varSetElems tyvars)
1029 add env tv = fst (tidyTyVar env tv)
1031 tidyType :: TidyEnv -> Type -> Type
1032 tidyType env@(tidy_env, subst) ty
1035 go (TyVarTy tv) = case lookupVarEnv subst tv of
1036 Nothing -> TyVarTy tv
1037 Just tv' -> TyVarTy tv'
1038 go (TyConApp tycon tys) = let args = map go tys
1039 in args `seqList` TyConApp tycon args
1040 go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
1041 go (PredTy p) = PredTy (tidyPred env p)
1042 go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
1043 go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
1044 go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty)
1046 (envp, tvp) = tidyTyVar env tv
1047 go (UsageTy u ty) = (UsageTy SAPPLY (go u)) SAPPLY (go ty)
1049 go_note (SynNote ty) = SynNote SAPPLY (go ty)
1050 go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
1052 tidyTypes env tys = map (tidyType env) tys
1054 tidyPred :: TidyEnv -> PredType -> PredType
1055 tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
1056 tidyPred env (IParam n ty) = IParam n (tidyType env ty)
1060 @tidyOpenType@ grabs the free type variables, tidies them
1061 and then uses @tidyType@ to work over the type itself
1064 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
1066 = (env', tidyType env' ty)
1068 env' = tidyFreeTyVars env (tyVarsOfType ty)
1070 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
1071 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
1073 tidyTopType :: Type -> Type
1074 tidyTopType ty = tidyType emptyTidyEnv ty
1079 %************************************************************************
1081 \subsection{Liftedness}
1083 %************************************************************************
1086 isUnLiftedType :: Type -> Bool
1087 -- isUnLiftedType returns True for forall'd unlifted types:
1088 -- x :: forall a. Int#
1089 -- I found bindings like these were getting floated to the top level.
1090 -- They are pretty bogus types, mind you. It would be better never to
1093 isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
1094 isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty
1095 isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
1096 isUnLiftedType (UsageTy _ ty) = isUnLiftedType ty
1097 isUnLiftedType other = False
1099 isUnboxedTupleType :: Type -> Bool
1100 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
1101 Just (tc, ty_args) -> isUnboxedTupleTyCon tc
1104 -- Should only be applied to *types*; hence the assert
1105 isAlgType :: Type -> Bool
1106 isAlgType ty = case splitTyConApp_maybe ty of
1107 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1111 -- Should only be applied to *types*; hence the assert
1112 isDataType :: Type -> Bool
1113 isDataType ty = case splitTyConApp_maybe ty of
1114 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1118 isNewType :: Type -> Bool
1119 isNewType ty = case splitTyConApp_maybe ty of
1120 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1126 %************************************************************************
1128 \subsection{Sequencing on types
1130 %************************************************************************
1133 seqType :: Type -> ()
1134 seqType (TyVarTy tv) = tv `seq` ()
1135 seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
1136 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
1137 seqType (NoteTy note t2) = seqNote note `seq` seqType t2
1138 seqType (PredTy p) = seqPred p
1139 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
1140 seqType (ForAllTy tv ty) = tv `seq` seqType ty
1141 seqType (UsageTy u ty) = seqType u `seq` seqType ty
1143 seqTypes :: [Type] -> ()
1145 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
1147 seqNote :: TyNote -> ()
1148 seqNote (SynNote ty) = seqType ty
1149 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
1151 seqPred :: PredType -> ()
1152 seqPred (ClassP c tys) = c `seq` seqTypes tys
1153 seqPred (IParam n ty) = n `seq` seqType ty
1157 %************************************************************************
1159 \subsection{Equality on types}
1161 %************************************************************************
1165 instance Eq Type where
1166 ty1 == ty2 = case ty1 `compare` ty2 of { EQ -> True; other -> False }
1168 instance Ord Type where
1169 compare ty1 ty2 = cmpTy emptyVarEnv ty1 ty2
1171 cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
1172 -- The "env" maps type variables in ty1 to type variables in ty2
1173 -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
1174 -- we in effect substitute tv2 for tv1 in t1 before continuing
1176 -- Get rid of NoteTy
1177 cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
1178 cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
1180 -- Get rid of PredTy
1181 cmpTy env (PredTy p1) (PredTy p2) = cmpPred env p1 p2
1182 cmpTy env (PredTy p1) ty2 = cmpTy env (predRepTy p1) ty2
1183 cmpTy env ty1 (PredTy p2) = cmpTy env ty1 (predRepTy p2)
1185 -- Deal with equal constructors
1186 cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
1187 Just tv1a -> tv1a `compare` tv2
1188 Nothing -> tv1 `compare` tv2
1190 cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1191 cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1192 cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
1193 cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2
1194 cmpTy env (UsageTy u1 t1) (UsageTy u2 t2) = cmpTy env u1 u2 `thenCmp` cmpTy env t1 t2
1196 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < UsageTy
1197 cmpTy env (AppTy _ _) (TyVarTy _) = GT
1199 cmpTy env (FunTy _ _) (TyVarTy _) = GT
1200 cmpTy env (FunTy _ _) (AppTy _ _) = GT
1202 cmpTy env (TyConApp _ _) (TyVarTy _) = GT
1203 cmpTy env (TyConApp _ _) (AppTy _ _) = GT
1204 cmpTy env (TyConApp _ _) (FunTy _ _) = GT
1206 cmpTy env (ForAllTy _ _) (TyVarTy _) = GT
1207 cmpTy env (ForAllTy _ _) (AppTy _ _) = GT
1208 cmpTy env (ForAllTy _ _) (FunTy _ _) = GT
1209 cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT
1211 cmpTy env (UsageTy _ _) other = GT
1216 cmpTys env [] [] = EQ
1217 cmpTys env (t:ts) [] = GT
1218 cmpTys env [] (t:ts) = LT
1219 cmpTys env (t1:t1s) (t2:t2s) = cmpTy env t1 t2 `thenCmp` cmpTys env t1s t2s
1223 instance Eq PredType where
1224 p1 == p2 = case p1 `compare` p2 of { EQ -> True; other -> False }
1226 instance Ord PredType where
1227 compare p1 p2 = cmpPred emptyVarEnv p1 p2
1229 cmpPred :: TyVarEnv TyVar -> PredType -> PredType -> Ordering
1230 cmpPred env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2)
1231 -- Compare types as well as names for implicit parameters
1232 -- This comparison is used exclusively (I think) for the
1233 -- finite map built in TcSimplify
1234 cmpPred env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
1235 cmpPred env (IParam _ _) (ClassP _ _) = LT
1236 cmpPred env (ClassP _ _) (IParam _ _) = GT