2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
4 \section[Type]{Type - public interface}
8 -- re-exports from TypeRep:
9 Type, PredType, TauType, ThetaType,
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,
34 funResultTy, funArgTy, zipFunTys,
36 mkTyConApp, mkTyConTy,
37 tyConAppTyCon, tyConAppArgs,
38 splitTyConApp_maybe, splitTyConApp,
40 mkUTy, splitUTy, splitUTy_maybe,
41 isUTy, uaUTy, unUTy, liftUTy, mkUTyM,
42 isUsageKind, isUsage, isUTyVar,
46 repType, splitRepFunTys, typePrimRep,
48 mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
49 applyTy, applyTys, isForAllTy,
52 SourceType(..), sourceTypeRep,
58 isUnLiftedType, isUnboxedTupleType, isAlgType,
61 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
62 usageAnnOfType, typeKind, addFreeTyVars,
64 -- Tidying up for printing
66 tidyOpenType, tidyOpenTypes,
67 tidyTyVar, tidyTyVars, tidyFreeTyVars,
68 tidyTopType, tidyPred,
71 eqType, eqKind, eqUsage,
78 #include "HsVersions.h"
80 -- We import the representation and primitive functions from TypeRep.
81 -- Many things are reexported, but not the representation!
87 import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
88 import {-# SOURCE #-} Subst ( substTyWith )
91 import Var ( Var, TyVar, tyVarKind, tyVarName, setTyVarName )
95 import Name ( NamedThing(..), mkLocalName, tidyOccName )
96 import Class ( classTyCon )
97 import TyCon ( TyCon, isRecursiveTyCon,
98 isUnboxedTupleTyCon, isUnLiftedTyCon,
99 isFunTyCon, isNewTyCon, newTyConRep,
100 isAlgTyCon, isSynTyCon, tyConArity,
101 tyConKind, getSynTyConDefn,
106 import Maybes ( maybeToBool )
107 import SrcLoc ( noSrcLoc )
108 import PrimRep ( PrimRep(..) )
109 import Unique ( Uniquable(..) )
110 import Util ( mapAccumL, seqList )
112 import UniqSet ( sizeUniqSet ) -- Should come via VarSet
116 %************************************************************************
118 \subsection{Stuff to do with kinds.}
120 %************************************************************************
123 hasMoreBoxityInfo :: Kind -> Kind -> Bool
124 hasMoreBoxityInfo k1 k2
125 | k2 `eqKind` openTypeKind = True
126 | otherwise = k1 `eqType` k2
128 defaultKind :: Kind -> Kind
129 -- Used when generalising: default kind '?' to '*'
130 defaultKind kind | kind `eqKind` openTypeKind = liftedTypeKind
135 %************************************************************************
137 \subsection{Constructor-specific functions}
139 %************************************************************************
142 ---------------------------------------------------------------------
146 mkTyVarTy :: TyVar -> Type
149 mkTyVarTys :: [TyVar] -> [Type]
150 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
152 getTyVar :: String -> Type -> TyVar
153 getTyVar msg (TyVarTy tv) = tv
154 getTyVar msg (SourceTy p) = getTyVar msg (sourceTypeRep p)
155 getTyVar msg (NoteTy _ t) = getTyVar msg t
156 getTyVar msg ty@(UsageTy _ _) = pprPanic "getTyVar: UTy:" (text msg $$ pprType ty)
157 getTyVar msg other = panic ("getTyVar: " ++ msg)
159 getTyVar_maybe :: Type -> Maybe TyVar
160 getTyVar_maybe (TyVarTy tv) = Just tv
161 getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
162 getTyVar_maybe (SourceTy p) = getTyVar_maybe (sourceTypeRep p)
163 getTyVar_maybe ty@(UsageTy _ _) = pprPanic "getTyVar_maybe: UTy:" (pprType ty)
164 getTyVar_maybe other = Nothing
166 isTyVarTy :: Type -> Bool
167 isTyVarTy (TyVarTy tv) = True
168 isTyVarTy (NoteTy _ ty) = isTyVarTy ty
169 isTyVarTy (SourceTy p) = isTyVarTy (sourceTypeRep p)
170 isTyVarTy ty@(UsageTy _ _) = pprPanic "isTyVarTy: UTy:" (pprType ty)
171 isTyVarTy other = False
175 ---------------------------------------------------------------------
178 We need to be pretty careful with AppTy to make sure we obey the
179 invariant that a TyConApp is always visibly so. mkAppTy maintains the
183 mkAppTy orig_ty1 orig_ty2
184 = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind *
185 UASSERT2( not (isUTy orig_ty2), pprType orig_ty1 <+> pprType orig_ty2 )
186 -- argument must be unannotated
189 mk_app (NoteTy _ ty1) = mk_app ty1
190 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
191 mk_app ty@(UsageTy _ _) = pprPanic "mkAppTy: UTy:" (pprType ty)
192 mk_app ty1 = AppTy orig_ty1 orig_ty2
194 mkAppTys :: Type -> [Type] -> Type
195 mkAppTys orig_ty1 [] = orig_ty1
196 -- This check for an empty list of type arguments
197 -- avoids the needless loss of a type synonym constructor.
198 -- For example: mkAppTys Rational []
199 -- returns to (Ratio Integer), which has needlessly lost
200 -- the Rational part.
201 mkAppTys orig_ty1 orig_tys2
202 = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind *
203 UASSERT2( not (any isUTy orig_tys2), pprType orig_ty1 <+> fsep (map pprType orig_tys2) )
204 -- arguments must be unannotated
207 mk_app (NoteTy _ ty1) = mk_app ty1
208 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
209 mk_app ty@(UsageTy _ _) = pprPanic "mkAppTys: UTy:" (pprType ty)
210 mk_app ty1 = foldl AppTy orig_ty1 orig_tys2
212 splitAppTy_maybe :: Type -> Maybe (Type, Type)
213 splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [unUTy ty1], unUTy ty2)
214 splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
215 splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty
216 splitAppTy_maybe (SourceTy p) = splitAppTy_maybe (sourceTypeRep p)
217 splitAppTy_maybe (TyConApp tc []) = Nothing
218 splitAppTy_maybe (TyConApp tc tys) = split tys []
220 split [ty2] acc = Just (TyConApp tc (reverse acc), ty2)
221 split (ty:tys) acc = split tys (ty:acc)
223 splitAppTy_maybe ty@(UsageTy _ _) = pprPanic "splitAppTy_maybe: UTy:" (pprType ty)
224 splitAppTy_maybe other = Nothing
226 splitAppTy :: Type -> (Type, Type)
227 splitAppTy ty = case splitAppTy_maybe ty of
229 Nothing -> panic "splitAppTy"
231 splitAppTys :: Type -> (Type, [Type])
232 splitAppTys ty = split ty ty []
234 split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
235 split orig_ty (NoteTy _ ty) args = split orig_ty ty args
236 split orig_ty (SourceTy p) args = split orig_ty (sourceTypeRep p) args
237 split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
238 (TyConApp funTyCon [], [unUTy ty1,unUTy ty2])
239 split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
240 split orig_ty (UsageTy _ _) args = pprPanic "splitAppTys: UTy:" (pprType orig_ty)
241 split orig_ty ty args = (orig_ty, args)
245 ---------------------------------------------------------------------
250 mkFunTy :: Type -> Type -> Type
251 mkFunTy arg res = UASSERT2( isUTy arg && isUTy res, pprType arg <+> pprType res )
254 mkFunTys :: [Type] -> Type -> Type
255 mkFunTys tys ty = UASSERT2( all isUTy (ty:tys), fsep (map pprType (tys++[ty])) )
258 splitFunTy :: Type -> (Type, Type)
259 splitFunTy (FunTy arg res) = (arg, res)
260 splitFunTy (NoteTy _ ty) = splitFunTy ty
261 splitFunTy (SourceTy p) = splitFunTy (sourceTypeRep p)
262 splitFunTy ty@(UsageTy _ _) = pprPanic "splitFunTy: UTy:" (pprType ty)
264 splitFunTy_maybe :: Type -> Maybe (Type, Type)
265 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
266 splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
267 splitFunTy_maybe (SourceTy p) = splitFunTy_maybe (sourceTypeRep p)
268 splitFunTy_maybe ty@(UsageTy _ _) = pprPanic "splitFunTy_maybe: UTy:" (pprType ty)
269 splitFunTy_maybe other = Nothing
271 splitFunTys :: Type -> ([Type], Type)
272 splitFunTys ty = split [] ty ty
274 split args orig_ty (FunTy arg res) = split (arg:args) res res
275 split args orig_ty (NoteTy _ ty) = split args orig_ty ty
276 split args orig_ty (SourceTy p) = split args orig_ty (sourceTypeRep p)
277 split args orig_ty (UsageTy _ _) = pprPanic "splitFunTys: UTy:" (pprType orig_ty)
278 split args orig_ty ty = (reverse args, orig_ty)
280 zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
281 zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
283 split acc [] nty ty = (reverse acc, nty)
284 split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
285 split acc xs nty (NoteTy _ ty) = split acc xs nty ty
286 split acc xs nty (SourceTy p) = split acc xs nty (sourceTypeRep p)
287 split acc xs nty (UsageTy _ _) = pprPanic "zipFunTys: UTy:" (ppr orig_xs <+> pprType orig_ty)
288 split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty)
290 funResultTy :: Type -> Type
291 funResultTy (FunTy arg res) = res
292 funResultTy (NoteTy _ ty) = funResultTy ty
293 funResultTy (SourceTy p) = funResultTy (sourceTypeRep p)
294 funResultTy (UsageTy _ ty) = funResultTy ty
295 funResultTy ty = pprPanic "funResultTy" (pprType ty)
297 funArgTy :: Type -> Type
298 funArgTy (FunTy arg res) = arg
299 funArgTy (NoteTy _ ty) = funArgTy ty
300 funArgTy (SourceTy p) = funArgTy (sourceTypeRep p)
301 funArgTy (UsageTy _ ty) = funArgTy ty
302 funArgTy ty = pprPanic "funArgTy" (pprType ty)
306 ---------------------------------------------------------------------
309 @mkTyConApp@ is a key function, because it builds a TyConApp, FunTy or SourceTy,
313 mkTyConApp :: TyCon -> [Type] -> Type
315 | isFunTyCon tycon, [ty1,ty2] <- tys
316 = FunTy (mkUTyM ty1) (mkUTyM ty2)
318 | isNewTyCon tycon, -- A saturated newtype application;
319 not (isRecursiveTyCon tycon), -- Not recursive (we don't use SourceTypes for them)
320 length tys == tyConArity tycon -- use the SourceType form
321 = SourceTy (NType tycon tys)
324 = ASSERT(not (isSynTyCon tycon))
325 UASSERT2( not (any isUTy tys), ppr tycon <+> fsep (map pprType tys) )
328 mkTyConTy :: TyCon -> Type
329 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
332 -- splitTyConApp "looks through" synonyms, because they don't
333 -- mean a distinct type, but all other type-constructor applications
334 -- including functions are returned as Just ..
336 tyConAppTyCon :: Type -> TyCon
337 tyConAppTyCon ty = fst (splitTyConApp ty)
339 tyConAppArgs :: Type -> [Type]
340 tyConAppArgs ty = snd (splitTyConApp ty)
342 splitTyConApp :: Type -> (TyCon, [Type])
343 splitTyConApp ty = case splitTyConApp_maybe ty of
345 Nothing -> pprPanic "splitTyConApp" (pprType ty)
347 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
348 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
349 splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [unUTy arg,unUTy res])
350 splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
351 splitTyConApp_maybe (SourceTy p) = splitTyConApp_maybe (sourceTypeRep p)
352 splitTyConApp_maybe (UsageTy _ ty) = splitTyConApp_maybe ty
353 splitTyConApp_maybe other = Nothing
357 ---------------------------------------------------------------------
362 mkSynTy syn_tycon tys
363 = ASSERT( isSynTyCon syn_tycon )
364 ASSERT( length tyvars == length tys )
365 NoteTy (SynNote (TyConApp syn_tycon tys))
366 (substTyWith tyvars tys body)
368 (tyvars, body) = getSynTyConDefn syn_tycon
371 Notes on type synonyms
372 ~~~~~~~~~~~~~~~~~~~~~~
373 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
374 to return type synonyms whereever possible. Thus
379 splitFunTys (a -> Foo a) = ([a], Foo a)
382 The reason is that we then get better (shorter) type signatures in
383 interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
389 repType looks through
393 (d) usage annotations
394 It's useful in the back end.
397 repType :: Type -> Type
398 repType (ForAllTy _ ty) = repType ty
399 repType (NoteTy _ ty) = repType ty
400 repType (SourceTy p) = repType (sourceTypeRep p)
401 repType (UsageTy _ ty) = repType ty
404 splitRepFunTys :: Type -> ([Type], Type)
405 -- Like splitFunTys, but looks through newtypes and for-alls
406 splitRepFunTys ty = split [] (repType ty)
408 split args (FunTy arg res) = split (arg:args) (repType res)
409 split args ty = (reverse args, ty)
411 typePrimRep :: Type -> PrimRep
412 typePrimRep ty = case repType ty of
413 TyConApp tc _ -> tyConPrimRep tc
415 AppTy _ _ -> PtrRep -- ??
421 ---------------------------------------------------------------------
426 mkForAllTy :: TyVar -> Type -> Type
428 = mkForAllTys [tyvar] ty
430 mkForAllTys :: [TyVar] -> Type -> Type
431 mkForAllTys tyvars ty
432 = case splitUTy_maybe ty of
433 Just (u,ty1) -> UASSERT2( not (mkVarSet tyvars `intersectsVarSet` tyVarsOfType u),
434 ptext SLIT("mkForAllTys: usage scope")
435 <+> ppr tyvars <+> pprType ty )
436 mkUTy u (foldr ForAllTy ty1 tyvars) -- we lift usage annotations over foralls
437 Nothing -> foldr ForAllTy ty tyvars
439 isForAllTy :: Type -> Bool
440 isForAllTy (NoteTy _ ty) = isForAllTy ty
441 isForAllTy (ForAllTy _ _) = True
442 isForAllTy (UsageTy _ ty) = isForAllTy ty
443 isForAllTy other_ty = False
445 splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
446 splitForAllTy_maybe ty = splitFAT_m ty
448 splitFAT_m (NoteTy _ ty) = splitFAT_m ty
449 splitFAT_m (SourceTy p) = splitFAT_m (sourceTypeRep p)
450 splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
451 splitFAT_m (UsageTy _ ty) = splitFAT_m ty
452 splitFAT_m _ = Nothing
454 splitForAllTys :: Type -> ([TyVar], Type)
455 splitForAllTys ty = split ty ty []
457 split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
458 split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
459 split orig_ty (SourceTy p) tvs = split orig_ty (sourceTypeRep p) tvs
460 split orig_ty (UsageTy _ ty) tvs = split orig_ty ty tvs
461 split orig_ty t tvs = (reverse tvs, orig_ty)
464 -- (mkPiType now in CoreUtils)
466 Applying a for-all to its arguments. Lift usage annotation as required.
469 applyTy :: Type -> Type -> Type
470 applyTy (SourceTy p) arg = applyTy (sourceTypeRep p) arg
471 applyTy (NoteTy _ fun) arg = applyTy fun arg
472 applyTy (ForAllTy tv ty) arg = UASSERT2( not (isUTy arg),
473 ptext SLIT("applyTy")
474 <+> pprType ty <+> pprType arg )
475 substTyWith [tv] [arg] ty
476 applyTy (UsageTy u ty) arg = UsageTy u (applyTy ty arg)
477 applyTy other arg = panic "applyTy"
479 applyTys :: Type -> [Type] -> Type
480 applyTys fun_ty arg_tys
481 = UASSERT2( not (any isUTy arg_tys), ptext SLIT("applyTys") <+> pprType fun_ty )
485 substTyWith tvs arg_tys ty
487 (mu, tvs, ty) = split fun_ty arg_tys
489 split fun_ty [] = (Nothing, [], fun_ty)
490 split (NoteTy _ fun_ty) args = split fun_ty args
491 split (SourceTy p) args = split (sourceTypeRep p) args
492 split (ForAllTy tv fun_ty) (arg:args) = case split fun_ty args of
493 (mu, tvs, ty) -> (mu, tv:tvs, ty)
494 split (UsageTy u ty) args = case split ty args of
495 (Nothing, tvs, ty) -> (Just u, tvs, ty)
496 (Just _ , _ , _ ) -> pprPanic "applyTys:"
498 split other_ty args = panic "applyTys"
502 ---------------------------------------------------------------------
506 Constructing and taking apart usage types.
509 mkUTy :: Type -> Type -> Type
511 = ASSERT2( typeKind u `eqKind` usageTypeKind,
512 ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
513 UASSERT2( not (isUTy ty), ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
514 -- if u == usMany then ty else : ToDo? KSW 2000-10
521 splitUTy :: Type -> (Type {- :: $ -}, Type)
523 = case splitUTy_maybe orig_ty of
524 Just (u,ty) -> (u,ty)
526 Nothing -> pprPanic "splitUTy:" (pprType orig_ty)
528 Nothing -> (usMany,orig_ty) -- default annotation ToDo KSW 2000-10
531 splitUTy_maybe :: Type -> Maybe (Type {- :: $ -}, Type)
532 splitUTy_maybe (UsageTy u ty) = Just (u,ty)
533 splitUTy_maybe (NoteTy _ ty) = splitUTy_maybe ty
534 splitUTy_maybe other_ty = Nothing
536 isUTy :: Type -> Bool
537 -- has usage annotation
538 isUTy = maybeToBool . splitUTy_maybe
540 uaUTy :: Type -> Type
541 -- extract annotation
542 uaUTy = fst . splitUTy
544 unUTy :: Type -> Type
545 -- extract unannotated type
546 unUTy = snd . splitUTy
550 liftUTy :: (Type -> Type) -> Type -> Type
551 -- lift outer usage annot over operation on unannotated types
554 (u,ty') = splitUTy ty
560 mkUTyM :: Type -> Type
561 -- put TOP (no info) annotation on unannotated type
562 mkUTyM ty = mkUTy usMany ty
566 isUsageKind :: Kind -> Bool
568 = ASSERT( typeKind k `eqKind` superKind )
569 k `eqKind` usageTypeKind
571 isUsage :: Type -> Bool
573 = isUsageKind (typeKind ty)
575 isUTyVar :: Var -> Bool
577 = isUsageKind (tyVarKind v)
581 %************************************************************************
583 \subsection{Source types}
585 %************************************************************************
587 A "source type" is a type that is a separate type as far as the type checker is
588 concerned, but which has low-level representation as far as the back end is concerned.
590 Source types are always lifted.
592 The key function is sourceTypeRep which gives the representation of a source type:
595 sourceTypeRep :: SourceType -> Type
596 -- Convert a predicate to its "representation type";
597 -- the type of evidence for that predicate, which is actually passed at runtime
598 sourceTypeRep (IParam n ty) = ty
599 sourceTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
600 -- Note the mkTyConApp; the classTyCon might be a newtype!
601 sourceTypeRep (NType tc tys) = newTypeRep tc tys
602 -- ToDo: Consider caching this substitution in a NType
604 isSourceTy :: Type -> Bool
605 isSourceTy (NoteTy _ ty) = isSourceTy ty
606 isSourceTy (UsageTy _ ty) = isSourceTy ty
607 isSourceTy (SourceTy sty) = True
611 splitNewType_maybe :: Type -> Maybe Type
612 -- Newtypes that are recursive are reprsented by TyConApp, just
613 -- as they always were. Occasionally we want to find their representation type.
614 -- NB: remember that in this module, non-recursive newtypes are transparent
616 splitNewType_maybe ty
617 = case splitTyConApp_maybe ty of
618 Just (tc,tys) | isNewTyCon tc -> ASSERT( length tys == tyConArity tc )
619 -- The assert should hold because repType should
620 -- only be applied to *types* (of kind *)
621 Just (newTypeRep tc tys)
624 -- A local helper function (not exported)
625 newTypeRep new_tycon tys = case newTyConRep new_tycon of
626 (tvs, rep_ty) -> substTyWith tvs tys rep_ty
630 %************************************************************************
632 \subsection{Kinds and free variables}
634 %************************************************************************
636 ---------------------------------------------------------------------
637 Finding the kind of a type
638 ~~~~~~~~~~~~~~~~~~~~~~~~~~
640 typeKind :: Type -> Kind
642 typeKind (TyVarTy tyvar) = tyVarKind tyvar
643 typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
644 typeKind (NoteTy _ ty) = typeKind ty
645 typeKind (SourceTy _) = liftedTypeKind -- Predicates are always
646 -- represented by lifted types
647 typeKind (AppTy fun arg) = funResultTy (typeKind fun)
649 typeKind (FunTy arg res) = fix_up (typeKind res)
651 fix_up (TyConApp tycon _) | tycon == typeCon
652 || tycon == openKindCon = liftedTypeKind
653 fix_up (NoteTy _ kind) = fix_up kind
655 -- The basic story is
656 -- typeKind (FunTy arg res) = typeKind res
657 -- But a function is lifted regardless of its result type
658 -- Hence the strange fix-up.
659 -- Note that 'res', being the result of a FunTy, can't have
660 -- a strange kind like (*->*).
662 typeKind (ForAllTy tv ty) = typeKind ty
663 typeKind (UsageTy _ ty) = typeKind ty -- we don't have separate kinds for ann/unann
667 ---------------------------------------------------------------------
668 Free variables of a type
669 ~~~~~~~~~~~~~~~~~~~~~~~~
672 tyVarsOfType :: Type -> TyVarSet
673 tyVarsOfType (TyVarTy tv) = unitVarSet tv
674 tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
675 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
676 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
677 tyVarsOfType (SourceTy sty) = tyVarsOfSourceType sty
678 tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
679 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
680 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
681 tyVarsOfType (UsageTy u ty) = tyVarsOfType u `unionVarSet` tyVarsOfType ty
683 tyVarsOfTypes :: [Type] -> TyVarSet
684 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
686 tyVarsOfPred :: PredType -> TyVarSet
687 tyVarsOfPred = tyVarsOfSourceType -- Just a subtype
689 tyVarsOfSourceType :: SourceType -> TyVarSet
690 tyVarsOfSourceType (IParam n ty) = tyVarsOfType ty
691 tyVarsOfSourceType (ClassP clas tys) = tyVarsOfTypes tys
692 tyVarsOfSourceType (NType tc tys) = tyVarsOfTypes tys
694 tyVarsOfTheta :: ThetaType -> TyVarSet
695 tyVarsOfTheta = foldr (unionVarSet . tyVarsOfSourceType) emptyVarSet
697 -- Add a Note with the free tyvars to the top of the type
698 addFreeTyVars :: Type -> Type
699 addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
700 addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
703 Usage annotations of a type
704 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
706 Get a list of usage annotations of a type, *in left-to-right pre-order*.
709 usageAnnOfType :: Type -> [Type]
714 goT (AppTy ty1 ty2) = goT ty1 ++ goT ty2
715 goT (TyConApp tc tys) = concatMap goT tys
716 goT (FunTy sty1 sty2) = goS sty1 ++ goS sty2
717 goT (ForAllTy mv ty) = goT ty
718 goT (SourceTy p) = goT (sourceTypeRep p)
719 goT ty@(UsageTy _ _) = pprPanic "usageAnnOfType: unexpected usage:" (pprType ty)
720 goT (NoteTy note ty) = goT ty
722 goS sty = case splitUTy sty of
723 (u,tty) -> u : goT tty
727 %************************************************************************
729 \subsection{TidyType}
731 %************************************************************************
733 tidyTy tidies up a type for printing in an error message, or in
736 It doesn't change the uniques at all, just the print names.
739 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
740 tidyTyVar env@(tidy_env, subst) tyvar
741 = case lookupVarEnv subst tyvar of
743 Just tyvar' -> -- Already substituted
746 Nothing -> -- Make a new nice name for it
748 case tidyOccName tidy_env (getOccName name) of
749 (tidy', occ') -> -- New occname reqd
750 ((tidy', subst'), tyvar')
752 subst' = extendVarEnv subst tyvar tyvar'
753 tyvar' = setTyVarName tyvar name'
754 name' = mkLocalName (getUnique name) occ' noSrcLoc
755 -- Note: make a *user* tyvar, so it printes nicely
756 -- Could extract src loc, but no need.
758 name = tyVarName tyvar
760 tidyTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
761 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
763 tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
764 -- Add the free tyvars to the env in tidy form,
765 -- so that we can tidy the type they are free in
766 tidyFreeTyVars env tyvars = foldl add env (varSetElems tyvars)
768 add env tv = fst (tidyTyVar env tv)
770 tidyType :: TidyEnv -> Type -> Type
771 tidyType env@(tidy_env, subst) ty
774 go (TyVarTy tv) = case lookupVarEnv subst tv of
775 Nothing -> TyVarTy tv
776 Just tv' -> TyVarTy tv'
777 go (TyConApp tycon tys) = let args = map go tys
778 in args `seqList` TyConApp tycon args
779 go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
780 go (SourceTy sty) = SourceTy (tidySourceType env sty)
781 go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
782 go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
783 go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty)
785 (envp, tvp) = tidyTyVar env tv
786 go (UsageTy u ty) = (UsageTy SAPPLY (go u)) SAPPLY (go ty)
788 go_note (SynNote ty) = SynNote SAPPLY (go ty)
789 go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
791 tidyTypes env tys = map (tidyType env) tys
793 tidyPred :: TidyEnv -> SourceType -> SourceType
794 tidyPred = tidySourceType
796 tidySourceType :: TidyEnv -> SourceType -> SourceType
797 tidySourceType env (IParam n ty) = IParam n (tidyType env ty)
798 tidySourceType env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
799 tidySourceType env (NType tc tys) = NType tc (tidyTypes env tys)
803 @tidyOpenType@ grabs the free type variables, tidies them
804 and then uses @tidyType@ to work over the type itself
807 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
809 = (env', tidyType env' ty)
811 env' = tidyFreeTyVars env (tyVarsOfType ty)
813 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
814 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
816 tidyTopType :: Type -> Type
817 tidyTopType ty = tidyType emptyTidyEnv ty
822 %************************************************************************
824 \subsection{Liftedness}
826 %************************************************************************
829 isUnLiftedType :: Type -> Bool
830 -- isUnLiftedType returns True for forall'd unlifted types:
831 -- x :: forall a. Int#
832 -- I found bindings like these were getting floated to the top level.
833 -- They are pretty bogus types, mind you. It would be better never to
836 isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
837 isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty
838 isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
839 isUnLiftedType (UsageTy _ ty) = isUnLiftedType ty
840 isUnLiftedType (SourceTy _) = False -- All source types are lifted
841 isUnLiftedType other = False
843 isUnboxedTupleType :: Type -> Bool
844 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
845 Just (tc, ty_args) -> isUnboxedTupleTyCon tc
848 -- Should only be applied to *types*; hence the assert
849 isAlgType :: Type -> Bool
850 isAlgType ty = case splitTyConApp_maybe ty of
851 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
857 %************************************************************************
859 \subsection{Sequencing on types
861 %************************************************************************
864 seqType :: Type -> ()
865 seqType (TyVarTy tv) = tv `seq` ()
866 seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
867 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
868 seqType (NoteTy note t2) = seqNote note `seq` seqType t2
869 seqType (SourceTy p) = seqPred p
870 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
871 seqType (ForAllTy tv ty) = tv `seq` seqType ty
872 seqType (UsageTy u ty) = seqType u `seq` seqType ty
874 seqTypes :: [Type] -> ()
876 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
878 seqNote :: TyNote -> ()
879 seqNote (SynNote ty) = seqType ty
880 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
882 seqPred :: SourceType -> ()
883 seqPred (ClassP c tys) = c `seq` seqTypes tys
884 seqPred (NType tc tys) = tc `seq` seqTypes tys
885 seqPred (IParam n ty) = n `seq` seqType ty
889 %************************************************************************
891 \subsection{Equality on types}
893 %************************************************************************
895 Comparison; don't use instances so that we know where it happens.
896 Look through newtypes but not usage types.
899 eqType t1 t2 = eq_ty emptyVarEnv t1 t2
900 eqKind = eqType -- No worries about looking
901 eqUsage = eqType -- through source types for these two
903 -- Look through Notes
904 eq_ty env (NoteTy _ t1) t2 = eq_ty env t1 t2
905 eq_ty env t1 (NoteTy _ t2) = eq_ty env t1 t2
907 -- Look through SourceTy. This is where the looping danger comes from
908 eq_ty env (SourceTy sty1) t2 = eq_ty env (sourceTypeRep sty1) t2
909 eq_ty env t1 (SourceTy sty2) = eq_ty env t1 (sourceTypeRep sty2)
911 -- The rest is plain sailing
912 eq_ty env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
913 Just tv1a -> tv1a == tv2
914 Nothing -> tv1 == tv2
915 eq_ty env (ForAllTy tv1 t1) (ForAllTy tv2 t2)
916 | tv1 == tv2 = eq_ty env t1 t2
917 | otherwise = eq_ty (extendVarEnv env tv1 tv2) t1 t2
918 eq_ty env (AppTy s1 t1) (AppTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2)
919 eq_ty env (FunTy s1 t1) (FunTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2)
920 eq_ty env (UsageTy _ t1) (UsageTy _ t2) = eq_ty env t1 t2
921 eq_ty env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 == tc2) && (eq_tys env tys1 tys2)
922 eq_ty env t1 t2 = False
924 eq_tys env [] [] = True
925 eq_tys env (t1:tys1) (t2:tys2) = (eq_ty env t1 t2) && (eq_tys env tys1 tys2)
926 eq_tys env tys1 tys2 = False