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
133 isTypeKind :: Kind -> Bool
134 -- True of kind * and *#
135 isTypeKind k = case splitTyConApp_maybe k of
136 Just (tc,[k]) -> tc == typeCon
141 %************************************************************************
143 \subsection{Constructor-specific functions}
145 %************************************************************************
148 ---------------------------------------------------------------------
152 mkTyVarTy :: TyVar -> Type
155 mkTyVarTys :: [TyVar] -> [Type]
156 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
158 getTyVar :: String -> Type -> TyVar
159 getTyVar msg (TyVarTy tv) = tv
160 getTyVar msg (SourceTy p) = getTyVar msg (sourceTypeRep p)
161 getTyVar msg (NoteTy _ t) = getTyVar msg t
162 getTyVar msg ty@(UsageTy _ _) = pprPanic "getTyVar: UTy:" (text msg $$ pprType ty)
163 getTyVar msg other = panic ("getTyVar: " ++ msg)
165 getTyVar_maybe :: Type -> Maybe TyVar
166 getTyVar_maybe (TyVarTy tv) = Just tv
167 getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
168 getTyVar_maybe (SourceTy p) = getTyVar_maybe (sourceTypeRep p)
169 getTyVar_maybe ty@(UsageTy _ _) = pprPanic "getTyVar_maybe: UTy:" (pprType ty)
170 getTyVar_maybe other = Nothing
172 isTyVarTy :: Type -> Bool
173 isTyVarTy (TyVarTy tv) = True
174 isTyVarTy (NoteTy _ ty) = isTyVarTy ty
175 isTyVarTy (SourceTy p) = isTyVarTy (sourceTypeRep p)
176 isTyVarTy ty@(UsageTy _ _) = pprPanic "isTyVarTy: UTy:" (pprType ty)
177 isTyVarTy other = False
181 ---------------------------------------------------------------------
184 We need to be pretty careful with AppTy to make sure we obey the
185 invariant that a TyConApp is always visibly so. mkAppTy maintains the
189 mkAppTy orig_ty1 orig_ty2
190 = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind *
191 UASSERT2( not (isUTy orig_ty2), pprType orig_ty1 <+> pprType orig_ty2 )
192 -- argument must be unannotated
195 mk_app (NoteTy _ ty1) = mk_app ty1
196 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
197 mk_app ty@(UsageTy _ _) = pprPanic "mkAppTy: UTy:" (pprType ty)
198 mk_app ty1 = AppTy orig_ty1 orig_ty2
200 mkAppTys :: Type -> [Type] -> Type
201 mkAppTys orig_ty1 [] = orig_ty1
202 -- This check for an empty list of type arguments
203 -- avoids the needless loss of a type synonym constructor.
204 -- For example: mkAppTys Rational []
205 -- returns to (Ratio Integer), which has needlessly lost
206 -- the Rational part.
207 mkAppTys orig_ty1 orig_tys2
208 = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind *
209 UASSERT2( not (any isUTy orig_tys2), pprType orig_ty1 <+> fsep (map pprType orig_tys2) )
210 -- arguments must be unannotated
213 mk_app (NoteTy _ ty1) = mk_app ty1
214 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
215 mk_app ty@(UsageTy _ _) = pprPanic "mkAppTys: UTy:" (pprType ty)
216 mk_app ty1 = foldl AppTy orig_ty1 orig_tys2
218 splitAppTy_maybe :: Type -> Maybe (Type, Type)
219 splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [unUTy ty1], unUTy ty2)
220 splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
221 splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty
222 splitAppTy_maybe (SourceTy p) = splitAppTy_maybe (sourceTypeRep p)
223 splitAppTy_maybe (TyConApp tc []) = Nothing
224 splitAppTy_maybe (TyConApp tc tys) = split tys []
226 split [ty2] acc = Just (TyConApp tc (reverse acc), ty2)
227 split (ty:tys) acc = split tys (ty:acc)
229 splitAppTy_maybe ty@(UsageTy _ _) = pprPanic "splitAppTy_maybe: UTy:" (pprType ty)
230 splitAppTy_maybe other = Nothing
232 splitAppTy :: Type -> (Type, Type)
233 splitAppTy ty = case splitAppTy_maybe ty of
235 Nothing -> panic "splitAppTy"
237 splitAppTys :: Type -> (Type, [Type])
238 splitAppTys ty = split ty ty []
240 split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
241 split orig_ty (NoteTy _ ty) args = split orig_ty ty args
242 split orig_ty (SourceTy p) args = split orig_ty (sourceTypeRep p) args
243 split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
244 (TyConApp funTyCon [], [unUTy ty1,unUTy ty2])
245 split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
246 split orig_ty (UsageTy _ _) args = pprPanic "splitAppTys: UTy:" (pprType orig_ty)
247 split orig_ty ty args = (orig_ty, args)
251 ---------------------------------------------------------------------
256 mkFunTy :: Type -> Type -> Type
257 mkFunTy arg res = UASSERT2( isUTy arg && isUTy res, pprType arg <+> pprType res )
260 mkFunTys :: [Type] -> Type -> Type
261 mkFunTys tys ty = UASSERT2( all isUTy (ty:tys), fsep (map pprType (tys++[ty])) )
264 splitFunTy :: Type -> (Type, Type)
265 splitFunTy (FunTy arg res) = (arg, res)
266 splitFunTy (NoteTy _ ty) = splitFunTy ty
267 splitFunTy (SourceTy p) = splitFunTy (sourceTypeRep p)
268 splitFunTy ty@(UsageTy _ _) = pprPanic "splitFunTy: UTy:" (pprType ty)
270 splitFunTy_maybe :: Type -> Maybe (Type, Type)
271 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
272 splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
273 splitFunTy_maybe (SourceTy p) = splitFunTy_maybe (sourceTypeRep p)
274 splitFunTy_maybe ty@(UsageTy _ _) = pprPanic "splitFunTy_maybe: UTy:" (pprType ty)
275 splitFunTy_maybe other = Nothing
277 splitFunTys :: Type -> ([Type], Type)
278 splitFunTys ty = split [] ty ty
280 split args orig_ty (FunTy arg res) = split (arg:args) res res
281 split args orig_ty (NoteTy _ ty) = split args orig_ty ty
282 split args orig_ty (SourceTy p) = split args orig_ty (sourceTypeRep p)
283 split args orig_ty (UsageTy _ _) = pprPanic "splitFunTys: UTy:" (pprType orig_ty)
284 split args orig_ty ty = (reverse args, orig_ty)
286 zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
287 zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
289 split acc [] nty ty = (reverse acc, nty)
290 split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
291 split acc xs nty (NoteTy _ ty) = split acc xs nty ty
292 split acc xs nty (SourceTy p) = split acc xs nty (sourceTypeRep p)
293 split acc xs nty (UsageTy _ _) = pprPanic "zipFunTys: UTy:" (ppr orig_xs <+> pprType orig_ty)
294 split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty)
296 funResultTy :: Type -> Type
297 funResultTy (FunTy arg res) = res
298 funResultTy (NoteTy _ ty) = funResultTy ty
299 funResultTy (SourceTy p) = funResultTy (sourceTypeRep p)
300 funResultTy (UsageTy _ ty) = funResultTy ty
301 funResultTy ty = pprPanic "funResultTy" (pprType ty)
303 funArgTy :: Type -> Type
304 funArgTy (FunTy arg res) = arg
305 funArgTy (NoteTy _ ty) = funArgTy ty
306 funArgTy (SourceTy p) = funArgTy (sourceTypeRep p)
307 funArgTy (UsageTy _ ty) = funArgTy ty
308 funArgTy ty = pprPanic "funArgTy" (pprType ty)
312 ---------------------------------------------------------------------
315 @mkTyConApp@ is a key function, because it builds a TyConApp, FunTy or SourceTy,
319 mkTyConApp :: TyCon -> [Type] -> Type
320 -- Assumes TyCon is not a SynTyCon; use mkSynTy instead for those
322 | isFunTyCon tycon, [ty1,ty2] <- tys
323 = FunTy (mkUTyM ty1) (mkUTyM ty2)
325 | isNewTyCon tycon, -- A saturated newtype application;
326 not (isRecursiveTyCon tycon), -- Not recursive (we don't use SourceTypes for them)
327 length tys == tyConArity tycon -- use the SourceType form
328 = SourceTy (NType tycon tys)
331 = ASSERT(not (isSynTyCon tycon))
332 UASSERT2( not (any isUTy tys), ppr tycon <+> fsep (map pprType tys) )
335 mkTyConTy :: TyCon -> Type
336 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
339 -- splitTyConApp "looks through" synonyms, because they don't
340 -- mean a distinct type, but all other type-constructor applications
341 -- including functions are returned as Just ..
343 tyConAppTyCon :: Type -> TyCon
344 tyConAppTyCon ty = fst (splitTyConApp ty)
346 tyConAppArgs :: Type -> [Type]
347 tyConAppArgs ty = snd (splitTyConApp ty)
349 splitTyConApp :: Type -> (TyCon, [Type])
350 splitTyConApp ty = case splitTyConApp_maybe ty of
352 Nothing -> pprPanic "splitTyConApp" (pprType ty)
354 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
355 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
356 splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [unUTy arg,unUTy res])
357 splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
358 splitTyConApp_maybe (SourceTy p) = splitTyConApp_maybe (sourceTypeRep p)
359 splitTyConApp_maybe (UsageTy _ ty) = splitTyConApp_maybe ty
360 splitTyConApp_maybe other = Nothing
364 ---------------------------------------------------------------------
369 mkSynTy syn_tycon tys
370 = ASSERT( isSynTyCon syn_tycon )
371 ASSERT( length tyvars == length tys )
372 NoteTy (SynNote (TyConApp syn_tycon tys))
373 (substTyWith tyvars tys body)
375 (tyvars, body) = getSynTyConDefn syn_tycon
378 Notes on type synonyms
379 ~~~~~~~~~~~~~~~~~~~~~~
380 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
381 to return type synonyms whereever possible. Thus
386 splitFunTys (a -> Foo a) = ([a], Foo a)
389 The reason is that we then get better (shorter) type signatures in
390 interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
396 repType looks through
400 (d) usage annotations
401 (e) [recursive] newtypes
402 It's useful in the back end.
404 Remember, non-recursive newtypes get expanded as part of the SourceTy case,
405 but recursive ones are represented by TyConApps and have to be expanded
409 repType :: Type -> Type
410 repType (ForAllTy _ ty) = repType ty
411 repType (NoteTy _ ty) = repType ty
412 repType (SourceTy p) = repType (sourceTypeRep p)
413 repType (UsageTy _ ty) = repType ty
414 repType (TyConApp tc tys) | isNewTyCon tc && length tys == tyConArity tc
415 = repType (newTypeRep tc tys)
418 splitRepFunTys :: Type -> ([Type], Type)
419 -- Like splitFunTys, but looks through newtypes and for-alls
420 splitRepFunTys ty = split [] (repType ty)
422 split args (FunTy arg res) = split (arg:args) (repType res)
423 split args ty = (reverse args, ty)
425 typePrimRep :: Type -> PrimRep
426 typePrimRep ty = case repType ty of
427 TyConApp tc _ -> tyConPrimRep tc
429 AppTy _ _ -> PtrRep -- ??
435 ---------------------------------------------------------------------
440 mkForAllTy :: TyVar -> Type -> Type
442 = mkForAllTys [tyvar] ty
444 mkForAllTys :: [TyVar] -> Type -> Type
445 mkForAllTys tyvars ty
446 = case splitUTy_maybe ty of
447 Just (u,ty1) -> UASSERT2( not (mkVarSet tyvars `intersectsVarSet` tyVarsOfType u),
448 ptext SLIT("mkForAllTys: usage scope")
449 <+> ppr tyvars <+> pprType ty )
450 mkUTy u (foldr ForAllTy ty1 tyvars) -- we lift usage annotations over foralls
451 Nothing -> foldr ForAllTy ty tyvars
453 isForAllTy :: Type -> Bool
454 isForAllTy (NoteTy _ ty) = isForAllTy ty
455 isForAllTy (ForAllTy _ _) = True
456 isForAllTy (UsageTy _ ty) = isForAllTy ty
457 isForAllTy other_ty = False
459 splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
460 splitForAllTy_maybe ty = splitFAT_m ty
462 splitFAT_m (NoteTy _ ty) = splitFAT_m ty
463 splitFAT_m (SourceTy p) = splitFAT_m (sourceTypeRep p)
464 splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
465 splitFAT_m (UsageTy _ ty) = splitFAT_m ty
466 splitFAT_m _ = Nothing
468 splitForAllTys :: Type -> ([TyVar], Type)
469 splitForAllTys ty = split ty ty []
471 split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
472 split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
473 split orig_ty (SourceTy p) tvs = split orig_ty (sourceTypeRep p) tvs
474 split orig_ty (UsageTy _ ty) tvs = split orig_ty ty tvs
475 split orig_ty t tvs = (reverse tvs, orig_ty)
478 -- (mkPiType now in CoreUtils)
480 Applying a for-all to its arguments. Lift usage annotation as required.
483 applyTy :: Type -> Type -> Type
484 applyTy (SourceTy p) arg = applyTy (sourceTypeRep p) arg
485 applyTy (NoteTy _ fun) arg = applyTy fun arg
486 applyTy (ForAllTy tv ty) arg = UASSERT2( not (isUTy arg),
487 ptext SLIT("applyTy")
488 <+> pprType ty <+> pprType arg )
489 substTyWith [tv] [arg] ty
490 applyTy (UsageTy u ty) arg = UsageTy u (applyTy ty arg)
491 applyTy other arg = panic "applyTy"
493 applyTys :: Type -> [Type] -> Type
494 applyTys fun_ty arg_tys
495 = UASSERT2( not (any isUTy arg_tys), ptext SLIT("applyTys") <+> pprType fun_ty )
499 substTyWith tvs arg_tys ty
501 (mu, tvs, ty) = split fun_ty arg_tys
503 split fun_ty [] = (Nothing, [], fun_ty)
504 split (NoteTy _ fun_ty) args = split fun_ty args
505 split (SourceTy p) args = split (sourceTypeRep p) args
506 split (ForAllTy tv fun_ty) (arg:args) = case split fun_ty args of
507 (mu, tvs, ty) -> (mu, tv:tvs, ty)
508 split (UsageTy u ty) args = case split ty args of
509 (Nothing, tvs, ty) -> (Just u, tvs, ty)
510 (Just _ , _ , _ ) -> pprPanic "applyTys:"
512 split other_ty args = panic "applyTys"
516 ---------------------------------------------------------------------
520 Constructing and taking apart usage types.
523 mkUTy :: Type -> Type -> Type
525 = ASSERT2( typeKind u `eqKind` usageTypeKind,
526 ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
527 UASSERT2( not (isUTy ty), ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
528 -- if u == usMany then ty else : ToDo? KSW 2000-10
535 splitUTy :: Type -> (Type {- :: $ -}, Type)
537 = case splitUTy_maybe orig_ty of
538 Just (u,ty) -> (u,ty)
540 Nothing -> pprPanic "splitUTy:" (pprType orig_ty)
542 Nothing -> (usMany,orig_ty) -- default annotation ToDo KSW 2000-10
545 splitUTy_maybe :: Type -> Maybe (Type {- :: $ -}, Type)
546 splitUTy_maybe (UsageTy u ty) = Just (u,ty)
547 splitUTy_maybe (NoteTy _ ty) = splitUTy_maybe ty
548 splitUTy_maybe other_ty = Nothing
550 isUTy :: Type -> Bool
551 -- has usage annotation
552 isUTy = maybeToBool . splitUTy_maybe
554 uaUTy :: Type -> Type
555 -- extract annotation
556 uaUTy = fst . splitUTy
558 unUTy :: Type -> Type
559 -- extract unannotated type
560 unUTy = snd . splitUTy
564 liftUTy :: (Type -> Type) -> Type -> Type
565 -- lift outer usage annot over operation on unannotated types
568 (u,ty') = splitUTy ty
574 mkUTyM :: Type -> Type
575 -- put TOP (no info) annotation on unannotated type
576 mkUTyM ty = mkUTy usMany ty
580 isUsageKind :: Kind -> Bool
582 = ASSERT( typeKind k `eqKind` superKind )
583 k `eqKind` usageTypeKind
585 isUsage :: Type -> Bool
587 = isUsageKind (typeKind ty)
589 isUTyVar :: Var -> Bool
591 = isUsageKind (tyVarKind v)
595 %************************************************************************
597 \subsection{Source types}
599 %************************************************************************
601 A "source type" is a type that is a separate type as far as the type checker is
602 concerned, but which has low-level representation as far as the back end is concerned.
604 Source types are always lifted.
606 The key function is sourceTypeRep which gives the representation of a source type:
609 sourceTypeRep :: SourceType -> Type
610 -- Convert a predicate to its "representation type";
611 -- the type of evidence for that predicate, which is actually passed at runtime
612 sourceTypeRep (IParam n ty) = ty
613 sourceTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
614 -- Note the mkTyConApp; the classTyCon might be a newtype!
615 sourceTypeRep (NType tc tys) = newTypeRep tc tys
616 -- ToDo: Consider caching this substitution in a NType
618 isSourceTy :: Type -> Bool
619 isSourceTy (NoteTy _ ty) = isSourceTy ty
620 isSourceTy (UsageTy _ ty) = isSourceTy ty
621 isSourceTy (SourceTy sty) = True
625 splitNewType_maybe :: Type -> Maybe Type
626 -- Newtypes that are recursive are reprsented by TyConApp, just
627 -- as they always were. Occasionally we want to find their representation type.
628 -- NB: remember that in this module, non-recursive newtypes are transparent
630 splitNewType_maybe ty
631 = case splitTyConApp_maybe ty of
632 Just (tc,tys) | isNewTyCon tc -> ASSERT( length tys == tyConArity tc )
633 -- The assert should hold because repType should
634 -- only be applied to *types* (of kind *)
635 Just (newTypeRep tc tys)
638 -- A local helper function (not exported)
639 newTypeRep new_tycon tys = case newTyConRep new_tycon of
640 (tvs, rep_ty) -> substTyWith tvs tys rep_ty
644 %************************************************************************
646 \subsection{Kinds and free variables}
648 %************************************************************************
650 ---------------------------------------------------------------------
651 Finding the kind of a type
652 ~~~~~~~~~~~~~~~~~~~~~~~~~~
654 typeKind :: Type -> Kind
656 typeKind (TyVarTy tyvar) = tyVarKind tyvar
657 typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
658 typeKind (NoteTy _ ty) = typeKind ty
659 typeKind (SourceTy _) = liftedTypeKind -- Predicates are always
660 -- represented by lifted types
661 typeKind (AppTy fun arg) = funResultTy (typeKind fun)
663 typeKind (FunTy arg res) = fix_up (typeKind res)
665 fix_up (TyConApp tycon _) | tycon == typeCon
666 || tycon == openKindCon = liftedTypeKind
667 fix_up (NoteTy _ kind) = fix_up kind
669 -- The basic story is
670 -- typeKind (FunTy arg res) = typeKind res
671 -- But a function is lifted regardless of its result type
672 -- Hence the strange fix-up.
673 -- Note that 'res', being the result of a FunTy, can't have
674 -- a strange kind like (*->*).
676 typeKind (ForAllTy tv ty) = typeKind ty
677 typeKind (UsageTy _ ty) = typeKind ty -- we don't have separate kinds for ann/unann
681 ---------------------------------------------------------------------
682 Free variables of a type
683 ~~~~~~~~~~~~~~~~~~~~~~~~
686 tyVarsOfType :: Type -> TyVarSet
687 tyVarsOfType (TyVarTy tv) = unitVarSet tv
688 tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
689 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
690 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
691 tyVarsOfType (SourceTy sty) = tyVarsOfSourceType sty
692 tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
693 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
694 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
695 tyVarsOfType (UsageTy u ty) = tyVarsOfType u `unionVarSet` tyVarsOfType ty
697 tyVarsOfTypes :: [Type] -> TyVarSet
698 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
700 tyVarsOfPred :: PredType -> TyVarSet
701 tyVarsOfPred = tyVarsOfSourceType -- Just a subtype
703 tyVarsOfSourceType :: SourceType -> TyVarSet
704 tyVarsOfSourceType (IParam n ty) = tyVarsOfType ty
705 tyVarsOfSourceType (ClassP clas tys) = tyVarsOfTypes tys
706 tyVarsOfSourceType (NType tc tys) = tyVarsOfTypes tys
708 tyVarsOfTheta :: ThetaType -> TyVarSet
709 tyVarsOfTheta = foldr (unionVarSet . tyVarsOfSourceType) emptyVarSet
711 -- Add a Note with the free tyvars to the top of the type
712 addFreeTyVars :: Type -> Type
713 addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
714 addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
717 Usage annotations of a type
718 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
720 Get a list of usage annotations of a type, *in left-to-right pre-order*.
723 usageAnnOfType :: Type -> [Type]
728 goT (AppTy ty1 ty2) = goT ty1 ++ goT ty2
729 goT (TyConApp tc tys) = concatMap goT tys
730 goT (FunTy sty1 sty2) = goS sty1 ++ goS sty2
731 goT (ForAllTy mv ty) = goT ty
732 goT (SourceTy p) = goT (sourceTypeRep p)
733 goT ty@(UsageTy _ _) = pprPanic "usageAnnOfType: unexpected usage:" (pprType ty)
734 goT (NoteTy note ty) = goT ty
736 goS sty = case splitUTy sty of
737 (u,tty) -> u : goT tty
741 %************************************************************************
743 \subsection{TidyType}
745 %************************************************************************
747 tidyTy tidies up a type for printing in an error message, or in
750 It doesn't change the uniques at all, just the print names.
753 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
754 tidyTyVar env@(tidy_env, subst) tyvar
755 = case lookupVarEnv subst tyvar of
757 Just tyvar' -> -- Already substituted
760 Nothing -> -- Make a new nice name for it
762 case tidyOccName tidy_env (getOccName name) of
763 (tidy', occ') -> -- New occname reqd
764 ((tidy', subst'), tyvar')
766 subst' = extendVarEnv subst tyvar tyvar'
767 tyvar' = setTyVarName tyvar name'
768 name' = mkLocalName (getUnique name) occ' noSrcLoc
769 -- Note: make a *user* tyvar, so it printes nicely
770 -- Could extract src loc, but no need.
772 name = tyVarName tyvar
774 tidyTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
775 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
777 tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
778 -- Add the free tyvars to the env in tidy form,
779 -- so that we can tidy the type they are free in
780 tidyFreeTyVars env tyvars = foldl add env (varSetElems tyvars)
782 add env tv = fst (tidyTyVar env tv)
784 tidyType :: TidyEnv -> Type -> Type
785 tidyType env@(tidy_env, subst) ty
788 go (TyVarTy tv) = case lookupVarEnv subst tv of
789 Nothing -> TyVarTy tv
790 Just tv' -> TyVarTy tv'
791 go (TyConApp tycon tys) = let args = map go tys
792 in args `seqList` TyConApp tycon args
793 go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
794 go (SourceTy sty) = SourceTy (tidySourceType env sty)
795 go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
796 go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
797 go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty)
799 (envp, tvp) = tidyTyVar env tv
800 go (UsageTy u ty) = (UsageTy SAPPLY (go u)) SAPPLY (go ty)
802 go_note (SynNote ty) = SynNote SAPPLY (go ty)
803 go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
805 tidyTypes env tys = map (tidyType env) tys
807 tidyPred :: TidyEnv -> SourceType -> SourceType
808 tidyPred = tidySourceType
810 tidySourceType :: TidyEnv -> SourceType -> SourceType
811 tidySourceType env (IParam n ty) = IParam n (tidyType env ty)
812 tidySourceType env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
813 tidySourceType env (NType tc tys) = NType tc (tidyTypes env tys)
817 @tidyOpenType@ grabs the free type variables, tidies them
818 and then uses @tidyType@ to work over the type itself
821 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
823 = (env', tidyType env' ty)
825 env' = tidyFreeTyVars env (tyVarsOfType ty)
827 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
828 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
830 tidyTopType :: Type -> Type
831 tidyTopType ty = tidyType emptyTidyEnv ty
836 %************************************************************************
838 \subsection{Liftedness}
840 %************************************************************************
843 isUnLiftedType :: Type -> Bool
844 -- isUnLiftedType returns True for forall'd unlifted types:
845 -- x :: forall a. Int#
846 -- I found bindings like these were getting floated to the top level.
847 -- They are pretty bogus types, mind you. It would be better never to
850 isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
851 isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty
852 isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
853 isUnLiftedType (UsageTy _ ty) = isUnLiftedType ty
854 isUnLiftedType (SourceTy _) = False -- All source types are lifted
855 isUnLiftedType other = False
857 isUnboxedTupleType :: Type -> Bool
858 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
859 Just (tc, ty_args) -> isUnboxedTupleTyCon tc
862 -- Should only be applied to *types*; hence the assert
863 isAlgType :: Type -> Bool
864 isAlgType ty = case splitTyConApp_maybe ty of
865 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
871 %************************************************************************
873 \subsection{Sequencing on types
875 %************************************************************************
878 seqType :: Type -> ()
879 seqType (TyVarTy tv) = tv `seq` ()
880 seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
881 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
882 seqType (NoteTy note t2) = seqNote note `seq` seqType t2
883 seqType (SourceTy p) = seqPred p
884 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
885 seqType (ForAllTy tv ty) = tv `seq` seqType ty
886 seqType (UsageTy u ty) = seqType u `seq` seqType ty
888 seqTypes :: [Type] -> ()
890 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
892 seqNote :: TyNote -> ()
893 seqNote (SynNote ty) = seqType ty
894 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
896 seqPred :: SourceType -> ()
897 seqPred (ClassP c tys) = c `seq` seqTypes tys
898 seqPred (NType tc tys) = tc `seq` seqTypes tys
899 seqPred (IParam n ty) = n `seq` seqType ty
903 %************************************************************************
905 \subsection{Equality on types}
907 %************************************************************************
909 Comparison; don't use instances so that we know where it happens.
910 Look through newtypes but not usage types.
913 eqType t1 t2 = eq_ty emptyVarEnv t1 t2
914 eqKind = eqType -- No worries about looking
915 eqUsage = eqType -- through source types for these two
917 -- Look through Notes
918 eq_ty env (NoteTy _ t1) t2 = eq_ty env t1 t2
919 eq_ty env t1 (NoteTy _ t2) = eq_ty env t1 t2
921 -- Look through SourceTy. This is where the looping danger comes from
922 eq_ty env (SourceTy sty1) t2 = eq_ty env (sourceTypeRep sty1) t2
923 eq_ty env t1 (SourceTy sty2) = eq_ty env t1 (sourceTypeRep sty2)
925 -- The rest is plain sailing
926 eq_ty env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
927 Just tv1a -> tv1a == tv2
928 Nothing -> tv1 == tv2
929 eq_ty env (ForAllTy tv1 t1) (ForAllTy tv2 t2)
930 | tv1 == tv2 = eq_ty env t1 t2
931 | otherwise = eq_ty (extendVarEnv env tv1 tv2) t1 t2
932 eq_ty env (AppTy s1 t1) (AppTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2)
933 eq_ty env (FunTy s1 t1) (FunTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2)
934 eq_ty env (UsageTy _ t1) (UsageTy _ t2) = eq_ty env t1 t2
935 eq_ty env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 == tc2) && (eq_tys env tys1 tys2)
936 eq_ty env t1 t2 = False
938 eq_tys env [] [] = True
939 eq_tys env (t1:tys1) (t2:tys2) = (eq_ty env t1 t2) && (eq_tys env tys1 tys2)
940 eq_tys env tys1 tys2 = False