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 #-} DataCon( DataCon )
88 import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
89 import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy )
92 import Var ( Var, TyVar, tyVarKind, tyVarName, setTyVarName )
96 import OccName ( mkDictOcc )
97 import Name ( Name, NamedThing(..), OccName, mkLocalName, tidyOccName )
99 import Class ( classTyCon )
100 import TyCon ( TyCon, isRecursiveTyCon,
101 isUnboxedTupleTyCon, isUnLiftedTyCon,
102 isFunTyCon, isNewTyCon, newTyConRep,
103 isAlgTyCon, isSynTyCon, tyConArity, tyConTyVars,
104 tyConKind, tyConDataCons, getSynTyConDefn,
105 tyConPrimRep, isPrimTyCon
109 import Maybes ( maybeToBool )
110 import SrcLoc ( SrcLoc, noSrcLoc )
111 import PrimRep ( PrimRep(..) )
112 import Unique ( Unique, Uniquable(..) )
113 import Util ( mapAccumL, seqList, thenCmp )
115 import UniqSet ( sizeUniqSet ) -- Should come via VarSet
119 %************************************************************************
121 \subsection{Stuff to do with kinds.}
123 %************************************************************************
126 hasMoreBoxityInfo :: Kind -> Kind -> Bool
127 hasMoreBoxityInfo k1 k2
128 | k2 `eqKind` openTypeKind = True
129 | otherwise = k1 `eqType` k2
131 defaultKind :: Kind -> Kind
132 -- Used when generalising: default kind '?' to '*'
133 defaultKind kind | kind `eqKind` openTypeKind = liftedTypeKind
138 %************************************************************************
140 \subsection{Constructor-specific functions}
142 %************************************************************************
145 ---------------------------------------------------------------------
149 mkTyVarTy :: TyVar -> Type
152 mkTyVarTys :: [TyVar] -> [Type]
153 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
155 getTyVar :: String -> Type -> TyVar
156 getTyVar msg (TyVarTy tv) = tv
157 getTyVar msg (SourceTy p) = getTyVar msg (sourceTypeRep p)
158 getTyVar msg (NoteTy _ t) = getTyVar msg t
159 getTyVar msg ty@(UsageTy _ _) = pprPanic "getTyVar: UTy:" (text msg $$ pprType ty)
160 getTyVar msg other = panic ("getTyVar: " ++ msg)
162 getTyVar_maybe :: Type -> Maybe TyVar
163 getTyVar_maybe (TyVarTy tv) = Just tv
164 getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
165 getTyVar_maybe (SourceTy p) = getTyVar_maybe (sourceTypeRep p)
166 getTyVar_maybe ty@(UsageTy _ _) = pprPanic "getTyVar_maybe: UTy:" (pprType ty)
167 getTyVar_maybe other = Nothing
169 isTyVarTy :: Type -> Bool
170 isTyVarTy (TyVarTy tv) = True
171 isTyVarTy (NoteTy _ ty) = isTyVarTy ty
172 isTyVarTy (SourceTy p) = isTyVarTy (sourceTypeRep p)
173 isTyVarTy ty@(UsageTy _ _) = pprPanic "isTyVarTy: UTy:" (pprType ty)
174 isTyVarTy other = False
178 ---------------------------------------------------------------------
181 We need to be pretty careful with AppTy to make sure we obey the
182 invariant that a TyConApp is always visibly so. mkAppTy maintains the
186 mkAppTy orig_ty1 orig_ty2
187 = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind *
188 UASSERT2( not (isUTy orig_ty2), pprType orig_ty1 <+> pprType orig_ty2 )
189 -- argument must be unannotated
192 mk_app (NoteTy _ ty1) = mk_app ty1
193 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
194 mk_app ty@(UsageTy _ _) = pprPanic "mkAppTy: UTy:" (pprType ty)
195 mk_app ty1 = AppTy orig_ty1 orig_ty2
197 mkAppTys :: Type -> [Type] -> Type
198 mkAppTys orig_ty1 [] = orig_ty1
199 -- This check for an empty list of type arguments
200 -- avoids the needless loss of a type synonym constructor.
201 -- For example: mkAppTys Rational []
202 -- returns to (Ratio Integer), which has needlessly lost
203 -- the Rational part.
204 mkAppTys orig_ty1 orig_tys2
205 = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind *
206 UASSERT2( not (any isUTy orig_tys2), pprType orig_ty1 <+> fsep (map pprType orig_tys2) )
207 -- arguments must be unannotated
210 mk_app (NoteTy _ ty1) = mk_app ty1
211 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
212 mk_app ty@(UsageTy _ _) = pprPanic "mkAppTys: UTy:" (pprType ty)
213 mk_app ty1 = foldl AppTy orig_ty1 orig_tys2
215 splitAppTy_maybe :: Type -> Maybe (Type, Type)
216 splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [unUTy ty1], unUTy ty2)
217 splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
218 splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty
219 splitAppTy_maybe (SourceTy p) = splitAppTy_maybe (sourceTypeRep p)
220 splitAppTy_maybe (TyConApp tc []) = Nothing
221 splitAppTy_maybe (TyConApp tc tys) = split tys []
223 split [ty2] acc = Just (TyConApp tc (reverse acc), ty2)
224 split (ty:tys) acc = split tys (ty:acc)
226 splitAppTy_maybe ty@(UsageTy _ _) = pprPanic "splitAppTy_maybe: UTy:" (pprType ty)
227 splitAppTy_maybe other = Nothing
229 splitAppTy :: Type -> (Type, Type)
230 splitAppTy ty = case splitAppTy_maybe ty of
232 Nothing -> panic "splitAppTy"
234 splitAppTys :: Type -> (Type, [Type])
235 splitAppTys ty = split ty ty []
237 split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
238 split orig_ty (NoteTy _ ty) args = split orig_ty ty args
239 split orig_ty (SourceTy p) args = split orig_ty (sourceTypeRep p) args
240 split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
241 (TyConApp funTyCon [], [unUTy ty1,unUTy ty2])
242 split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
243 split orig_ty (UsageTy _ _) args = pprPanic "splitAppTys: UTy:" (pprType orig_ty)
244 split orig_ty ty args = (orig_ty, args)
248 ---------------------------------------------------------------------
253 mkFunTy :: Type -> Type -> Type
254 mkFunTy arg res = UASSERT2( isUTy arg && isUTy res, pprType arg <+> pprType res )
257 mkFunTys :: [Type] -> Type -> Type
258 mkFunTys tys ty = UASSERT2( all isUTy (ty:tys), fsep (map pprType (tys++[ty])) )
261 splitFunTy :: Type -> (Type, Type)
262 splitFunTy (FunTy arg res) = (arg, res)
263 splitFunTy (NoteTy _ ty) = splitFunTy ty
264 splitFunTy (SourceTy p) = splitFunTy (sourceTypeRep p)
265 splitFunTy ty@(UsageTy _ _) = pprPanic "splitFunTy: UTy:" (pprType ty)
267 splitFunTy_maybe :: Type -> Maybe (Type, Type)
268 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
269 splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
270 splitFunTy_maybe (SourceTy p) = splitFunTy_maybe (sourceTypeRep p)
271 splitFunTy_maybe ty@(UsageTy _ _) = pprPanic "splitFunTy_maybe: UTy:" (pprType ty)
272 splitFunTy_maybe other = Nothing
274 splitFunTys :: Type -> ([Type], Type)
275 splitFunTys ty = split [] ty ty
277 split args orig_ty (FunTy arg res) = split (arg:args) res res
278 split args orig_ty (NoteTy _ ty) = split args orig_ty ty
279 split args orig_ty (SourceTy p) = split args orig_ty (sourceTypeRep p)
280 split args orig_ty (UsageTy _ _) = pprPanic "splitFunTys: UTy:" (pprType orig_ty)
281 split args orig_ty ty = (reverse args, orig_ty)
283 zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
284 zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
286 split acc [] nty ty = (reverse acc, nty)
287 split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
288 split acc xs nty (NoteTy _ ty) = split acc xs nty ty
289 split acc xs nty (SourceTy p) = split acc xs nty (sourceTypeRep p)
290 split acc xs nty (UsageTy _ _) = pprPanic "zipFunTys: UTy:" (ppr orig_xs <+> pprType orig_ty)
291 split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty)
293 funResultTy :: Type -> Type
294 funResultTy (FunTy arg res) = res
295 funResultTy (NoteTy _ ty) = funResultTy ty
296 funResultTy (SourceTy p) = funResultTy (sourceTypeRep p)
297 funResultTy (UsageTy _ ty) = funResultTy ty
298 funResultTy ty = pprPanic "funResultTy" (pprType ty)
300 funArgTy :: Type -> Type
301 funArgTy (FunTy arg res) = arg
302 funArgTy (NoteTy _ ty) = funArgTy ty
303 funArgTy (SourceTy p) = funArgTy (sourceTypeRep p)
304 funArgTy (UsageTy _ ty) = funArgTy ty
305 funArgTy ty = pprPanic "funArgTy" (pprType ty)
309 ---------------------------------------------------------------------
312 @mkTyConApp@ is a key function, because it builds a TyConApp, FunTy or SourceTy,
316 mkTyConApp :: TyCon -> [Type] -> Type
318 | isFunTyCon tycon, [ty1,ty2] <- tys
319 = FunTy (mkUTyM ty1) (mkUTyM ty2)
321 | isNewTyCon tycon, -- A saturated newtype application;
322 not (isRecursiveTyCon tycon), -- Not recursive (we don't use SourceTypes for them)
323 length tys == tyConArity tycon -- use the SourceType form
324 = SourceTy (NType tycon tys)
327 = ASSERT(not (isSynTyCon tycon))
328 UASSERT2( not (any isUTy tys), ppr tycon <+> fsep (map pprType tys) )
331 mkTyConTy :: TyCon -> Type
332 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
335 -- splitTyConApp "looks through" synonyms, because they don't
336 -- mean a distinct type, but all other type-constructor applications
337 -- including functions are returned as Just ..
339 tyConAppTyCon :: Type -> TyCon
340 tyConAppTyCon ty = fst (splitTyConApp ty)
342 tyConAppArgs :: Type -> [Type]
343 tyConAppArgs ty = snd (splitTyConApp ty)
345 splitTyConApp :: Type -> (TyCon, [Type])
346 splitTyConApp ty = case splitTyConApp_maybe ty of
348 Nothing -> pprPanic "splitTyConApp" (pprType ty)
350 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
351 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
352 splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [unUTy arg,unUTy res])
353 splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
354 splitTyConApp_maybe (SourceTy p) = splitTyConApp_maybe (sourceTypeRep p)
355 splitTyConApp_maybe (UsageTy _ ty) = splitTyConApp_maybe ty
356 splitTyConApp_maybe other = Nothing
360 ---------------------------------------------------------------------
365 mkSynTy syn_tycon tys
366 = ASSERT( isSynTyCon syn_tycon )
367 ASSERT( length tyvars == length tys )
368 NoteTy (SynNote (TyConApp syn_tycon tys))
369 (substTy (mkTyVarSubst tyvars tys) body)
371 (tyvars, body) = getSynTyConDefn syn_tycon
374 Notes on type synonyms
375 ~~~~~~~~~~~~~~~~~~~~~~
376 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
377 to return type synonyms whereever possible. Thus
382 splitFunTys (a -> Foo a) = ([a], Foo a)
385 The reason is that we then get better (shorter) type signatures in
386 interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
392 repType looks through
396 (d) usage annotations
397 It's useful in the back end.
400 repType :: Type -> Type
401 repType (ForAllTy _ ty) = repType ty
402 repType (NoteTy _ ty) = repType ty
403 repType (SourceTy p) = repType (sourceTypeRep p)
404 repType (UsageTy _ ty) = repType ty
407 splitRepFunTys :: Type -> ([Type], Type)
408 -- Like splitFunTys, but looks through newtypes and for-alls
409 splitRepFunTys ty = split [] (repType ty)
411 split args (FunTy arg res) = split (arg:args) (repType res)
412 split args ty = (reverse args, ty)
414 typePrimRep :: Type -> PrimRep
415 typePrimRep ty = case repType ty of
416 TyConApp tc _ -> tyConPrimRep tc
418 AppTy _ _ -> PtrRep -- ??
424 ---------------------------------------------------------------------
429 mkForAllTy :: TyVar -> Type -> Type
431 = mkForAllTys [tyvar] ty
433 mkForAllTys :: [TyVar] -> Type -> Type
434 mkForAllTys tyvars ty
435 = case splitUTy_maybe ty of
436 Just (u,ty1) -> UASSERT2( not (mkVarSet tyvars `intersectsVarSet` tyVarsOfType u),
437 ptext SLIT("mkForAllTys: usage scope")
438 <+> ppr tyvars <+> pprType ty )
439 mkUTy u (foldr ForAllTy ty1 tyvars) -- we lift usage annotations over foralls
440 Nothing -> foldr ForAllTy ty tyvars
442 isForAllTy :: Type -> Bool
443 isForAllTy (NoteTy _ ty) = isForAllTy ty
444 isForAllTy (ForAllTy _ _) = True
445 isForAllTy (UsageTy _ ty) = isForAllTy ty
446 isForAllTy other_ty = False
448 splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
449 splitForAllTy_maybe ty = splitFAT_m ty
451 splitFAT_m (NoteTy _ ty) = splitFAT_m ty
452 splitFAT_m (SourceTy p) = splitFAT_m (sourceTypeRep p)
453 splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
454 splitFAT_m (UsageTy _ ty) = splitFAT_m ty
455 splitFAT_m _ = Nothing
457 splitForAllTys :: Type -> ([TyVar], Type)
458 splitForAllTys ty = split ty ty []
460 split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
461 split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
462 split orig_ty (SourceTy p) tvs = split orig_ty (sourceTypeRep p) tvs
463 split orig_ty (UsageTy _ ty) tvs = split orig_ty ty tvs
464 split orig_ty t tvs = (reverse tvs, orig_ty)
467 -- (mkPiType now in CoreUtils)
469 Applying a for-all to its arguments. Lift usage annotation as required.
472 applyTy :: Type -> Type -> Type
473 applyTy (SourceTy p) arg = applyTy (sourceTypeRep p) arg
474 applyTy (NoteTy _ fun) arg = applyTy fun arg
475 applyTy (ForAllTy tv ty) arg = UASSERT2( not (isUTy arg),
476 ptext SLIT("applyTy")
477 <+> pprType ty <+> pprType arg )
478 substTy (mkTyVarSubst [tv] [arg]) ty
479 applyTy (UsageTy u ty) arg = UsageTy u (applyTy ty arg)
480 applyTy other arg = panic "applyTy"
482 applyTys :: Type -> [Type] -> Type
483 applyTys fun_ty arg_tys
484 = UASSERT2( not (any isUTy arg_tys), ptext SLIT("applyTys") <+> pprType fun_ty )
488 substTy (mkTyVarSubst tvs arg_tys) ty
490 (mu, tvs, ty) = split fun_ty arg_tys
492 split fun_ty [] = (Nothing, [], fun_ty)
493 split (NoteTy _ fun_ty) args = split fun_ty args
494 split (SourceTy p) args = split (sourceTypeRep p) args
495 split (ForAllTy tv fun_ty) (arg:args) = case split fun_ty args of
496 (mu, tvs, ty) -> (mu, tv:tvs, ty)
497 split (UsageTy u ty) args = case split ty args of
498 (Nothing, tvs, ty) -> (Just u, tvs, ty)
499 (Just _ , _ , _ ) -> pprPanic "applyTys:"
501 split other_ty args = panic "applyTys"
505 ---------------------------------------------------------------------
509 Constructing and taking apart usage types.
512 mkUTy :: Type -> Type -> Type
514 = ASSERT2( typeKind u `eqKind` usageTypeKind,
515 ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
516 UASSERT2( not (isUTy ty), ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
517 -- if u == usMany then ty else : ToDo? KSW 2000-10
524 splitUTy :: Type -> (Type {- :: $ -}, Type)
526 = case splitUTy_maybe orig_ty of
527 Just (u,ty) -> (u,ty)
529 Nothing -> pprPanic "splitUTy:" (pprType orig_ty)
531 Nothing -> (usMany,orig_ty) -- default annotation ToDo KSW 2000-10
534 splitUTy_maybe :: Type -> Maybe (Type {- :: $ -}, Type)
535 splitUTy_maybe (UsageTy u ty) = Just (u,ty)
536 splitUTy_maybe (NoteTy _ ty) = splitUTy_maybe ty
537 splitUTy_maybe other_ty = Nothing
539 isUTy :: Type -> Bool
540 -- has usage annotation
541 isUTy = maybeToBool . splitUTy_maybe
543 uaUTy :: Type -> Type
544 -- extract annotation
545 uaUTy = fst . splitUTy
547 unUTy :: Type -> Type
548 -- extract unannotated type
549 unUTy = snd . splitUTy
553 liftUTy :: (Type -> Type) -> Type -> Type
554 -- lift outer usage annot over operation on unannotated types
557 (u,ty') = splitUTy ty
563 mkUTyM :: Type -> Type
564 -- put TOP (no info) annotation on unannotated type
565 mkUTyM ty = mkUTy usMany ty
569 isUsageKind :: Kind -> Bool
571 = ASSERT( typeKind k `eqKind` superKind )
572 k `eqKind` usageTypeKind
574 isUsage :: Type -> Bool
576 = isUsageKind (typeKind ty)
578 isUTyVar :: Var -> Bool
580 = isUsageKind (tyVarKind v)
584 %************************************************************************
586 \subsection{Source types}
588 %************************************************************************
590 A "source type" is a type that is a separate type as far as the type checker is
591 concerned, but which has low-level representation as far as the back end is concerned.
593 Source types are always lifted.
595 The key function is sourceTypeRep which gives the representation of a source type:
598 sourceTypeRep :: SourceType -> Type
599 -- Convert a predicate to its "representation type";
600 -- the type of evidence for that predicate, which is actually passed at runtime
601 sourceTypeRep (IParam n ty) = ty
602 sourceTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
603 -- Note the mkTyConApp; the classTyCon might be a newtype!
604 sourceTypeRep (NType tc tys) = case newTyConRep tc of
605 (tvs, rep_ty) -> substTy (mkTyVarSubst tvs tys) rep_ty
606 -- ToDo: Consider caching this substitution in a NType
608 mkNewTyConApp :: TyCon -> [Type] -> SourceType
609 mkNewTyConApp tc tys = NType tc tys -- Here is where we might cache the substitution
611 isSourceTy :: Type -> Bool
612 isSourceTy (NoteTy _ ty) = isSourceTy ty
613 isSourceTy (UsageTy _ ty) = isSourceTy ty
614 isSourceTy (SourceTy sty) = True
619 %************************************************************************
621 \subsection{Kinds and free variables}
623 %************************************************************************
625 ---------------------------------------------------------------------
626 Finding the kind of a type
627 ~~~~~~~~~~~~~~~~~~~~~~~~~~
629 typeKind :: Type -> Kind
631 typeKind (TyVarTy tyvar) = tyVarKind tyvar
632 typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
633 typeKind (NoteTy _ ty) = typeKind ty
634 typeKind (SourceTy _) = liftedTypeKind -- Predicates are always
635 -- represented by lifted types
636 typeKind (AppTy fun arg) = funResultTy (typeKind fun)
638 typeKind (FunTy arg res) = fix_up (typeKind res)
640 fix_up (TyConApp tycon _) | tycon == typeCon
641 || tycon == openKindCon = liftedTypeKind
642 fix_up (NoteTy _ kind) = fix_up kind
644 -- The basic story is
645 -- typeKind (FunTy arg res) = typeKind res
646 -- But a function is lifted regardless of its result type
647 -- Hence the strange fix-up.
648 -- Note that 'res', being the result of a FunTy, can't have
649 -- a strange kind like (*->*).
651 typeKind (ForAllTy tv ty) = typeKind ty
652 typeKind (UsageTy _ ty) = typeKind ty -- we don't have separate kinds for ann/unann
656 ---------------------------------------------------------------------
657 Free variables of a type
658 ~~~~~~~~~~~~~~~~~~~~~~~~
661 tyVarsOfType :: Type -> TyVarSet
662 tyVarsOfType (TyVarTy tv) = unitVarSet tv
663 tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
664 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
665 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
666 tyVarsOfType (SourceTy sty) = tyVarsOfSourceType sty
667 tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
668 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
669 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
670 tyVarsOfType (UsageTy u ty) = tyVarsOfType u `unionVarSet` tyVarsOfType ty
672 tyVarsOfTypes :: [Type] -> TyVarSet
673 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
675 tyVarsOfPred :: PredType -> TyVarSet
676 tyVarsOfPred = tyVarsOfSourceType -- Just a subtype
678 tyVarsOfSourceType :: SourceType -> TyVarSet
679 tyVarsOfSourceType (IParam n ty) = tyVarsOfType ty
680 tyVarsOfSourceType (ClassP clas tys) = tyVarsOfTypes tys
681 tyVarsOfSourceType (NType tc tys) = tyVarsOfTypes tys
683 tyVarsOfTheta :: ThetaType -> TyVarSet
684 tyVarsOfTheta = foldr (unionVarSet . tyVarsOfSourceType) emptyVarSet
686 -- Add a Note with the free tyvars to the top of the type
687 addFreeTyVars :: Type -> Type
688 addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
689 addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
692 Usage annotations of a type
693 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
695 Get a list of usage annotations of a type, *in left-to-right pre-order*.
698 usageAnnOfType :: Type -> [Type]
703 goT (AppTy ty1 ty2) = goT ty1 ++ goT ty2
704 goT (TyConApp tc tys) = concatMap goT tys
705 goT (FunTy sty1 sty2) = goS sty1 ++ goS sty2
706 goT (ForAllTy mv ty) = goT ty
707 goT (SourceTy p) = goT (sourceTypeRep p)
708 goT ty@(UsageTy _ _) = pprPanic "usageAnnOfType: unexpected usage:" (pprType ty)
709 goT (NoteTy note ty) = goT ty
711 goS sty = case splitUTy sty of
712 (u,tty) -> u : goT tty
716 %************************************************************************
718 \subsection{TidyType}
720 %************************************************************************
722 tidyTy tidies up a type for printing in an error message, or in
725 It doesn't change the uniques at all, just the print names.
728 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
729 tidyTyVar env@(tidy_env, subst) tyvar
730 = case lookupVarEnv subst tyvar of
732 Just tyvar' -> -- Already substituted
735 Nothing -> -- Make a new nice name for it
737 case tidyOccName tidy_env (getOccName name) of
738 (tidy', occ') -> -- New occname reqd
739 ((tidy', subst'), tyvar')
741 subst' = extendVarEnv subst tyvar tyvar'
742 tyvar' = setTyVarName tyvar name'
743 name' = mkLocalName (getUnique name) occ' noSrcLoc
744 -- Note: make a *user* tyvar, so it printes nicely
745 -- Could extract src loc, but no need.
747 name = tyVarName tyvar
749 tidyTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
750 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
752 tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
753 -- Add the free tyvars to the env in tidy form,
754 -- so that we can tidy the type they are free in
755 tidyFreeTyVars env tyvars = foldl add env (varSetElems tyvars)
757 add env tv = fst (tidyTyVar env tv)
759 tidyType :: TidyEnv -> Type -> Type
760 tidyType env@(tidy_env, subst) ty
763 go (TyVarTy tv) = case lookupVarEnv subst tv of
764 Nothing -> TyVarTy tv
765 Just tv' -> TyVarTy tv'
766 go (TyConApp tycon tys) = let args = map go tys
767 in args `seqList` TyConApp tycon args
768 go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
769 go (SourceTy sty) = SourceTy (tidySourceType env sty)
770 go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
771 go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
772 go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty)
774 (envp, tvp) = tidyTyVar env tv
775 go (UsageTy u ty) = (UsageTy SAPPLY (go u)) SAPPLY (go ty)
777 go_note (SynNote ty) = SynNote SAPPLY (go ty)
778 go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
780 tidyTypes env tys = map (tidyType env) tys
782 tidyPred :: TidyEnv -> SourceType -> SourceType
783 tidyPred = tidySourceType
785 tidySourceType :: TidyEnv -> SourceType -> SourceType
786 tidySourceType env (IParam n ty) = IParam n (tidyType env ty)
787 tidySourceType env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
788 tidySourceType env (NType tc tys) = NType tc (tidyTypes env tys)
792 @tidyOpenType@ grabs the free type variables, tidies them
793 and then uses @tidyType@ to work over the type itself
796 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
798 = (env', tidyType env' ty)
800 env' = tidyFreeTyVars env (tyVarsOfType ty)
802 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
803 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
805 tidyTopType :: Type -> Type
806 tidyTopType ty = tidyType emptyTidyEnv ty
811 %************************************************************************
813 \subsection{Liftedness}
815 %************************************************************************
818 isUnLiftedType :: Type -> Bool
819 -- isUnLiftedType returns True for forall'd unlifted types:
820 -- x :: forall a. Int#
821 -- I found bindings like these were getting floated to the top level.
822 -- They are pretty bogus types, mind you. It would be better never to
825 isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
826 isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty
827 isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
828 isUnLiftedType (UsageTy _ ty) = isUnLiftedType ty
829 isUnLiftedType (SourceTy _) = False -- All source types are lifted
830 isUnLiftedType other = False
832 isUnboxedTupleType :: Type -> Bool
833 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
834 Just (tc, ty_args) -> isUnboxedTupleTyCon tc
837 -- Should only be applied to *types*; hence the assert
838 isAlgType :: Type -> Bool
839 isAlgType ty = case splitTyConApp_maybe ty of
840 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
846 %************************************************************************
848 \subsection{Sequencing on types
850 %************************************************************************
853 seqType :: Type -> ()
854 seqType (TyVarTy tv) = tv `seq` ()
855 seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
856 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
857 seqType (NoteTy note t2) = seqNote note `seq` seqType t2
858 seqType (SourceTy p) = seqPred p
859 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
860 seqType (ForAllTy tv ty) = tv `seq` seqType ty
861 seqType (UsageTy u ty) = seqType u `seq` seqType ty
863 seqTypes :: [Type] -> ()
865 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
867 seqNote :: TyNote -> ()
868 seqNote (SynNote ty) = seqType ty
869 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
871 seqPred :: SourceType -> ()
872 seqPred (ClassP c tys) = c `seq` seqTypes tys
873 seqPred (NType tc tys) = tc `seq` seqTypes tys
874 seqPred (IParam n ty) = n `seq` seqType ty
878 %************************************************************************
880 \subsection{Equality on types}
882 %************************************************************************
884 Comparison; don't use instances so that we know where it happens.
885 Look through newtypes but not usage types.
888 eqType t1 t2 = eq_ty emptyVarEnv t1 t2
889 eqKind = eqType -- No worries about looking
890 eqUsage = eqType -- through source types for these two
892 -- Look through Notes
893 eq_ty env (NoteTy _ t1) t2 = eq_ty env t1 t2
894 eq_ty env t1 (NoteTy _ t2) = eq_ty env t1 t2
896 -- Look through SourceTy. This is where the looping danger comes from
897 eq_ty env (SourceTy sty1) t2 = eq_ty env (sourceTypeRep sty1) t2
898 eq_ty env t1 (SourceTy sty2) = eq_ty env t1 (sourceTypeRep sty2)
900 -- The rest is plain sailing
901 eq_ty env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
902 Just tv1a -> tv1a == tv2
903 Nothing -> tv1 == tv2
904 eq_ty env (ForAllTy tv1 t1) (ForAllTy tv2 t2)
905 | tv1 == tv2 = eq_ty env t1 t2
906 | otherwise = eq_ty (extendVarEnv env tv1 tv2) t1 t2
907 eq_ty env (AppTy s1 t1) (AppTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2)
908 eq_ty env (FunTy s1 t1) (FunTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2)
909 eq_ty env (UsageTy _ t1) (UsageTy _ t2) = eq_ty env t1 t2
910 eq_ty env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 == tc2) && (eq_tys env tys1 tys2)
911 eq_ty env t1 t2 = False
913 eq_tys env [] [] = True
914 eq_tys env (t1:tys1) (t2:tys2) = (eq_ty env t1 t2) && (eq_tys env tys2 tys2)
915 eq_tys env tys1 tys2 = False