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, mkPredTy, mkPredTys,
58 isUnLiftedType, isUnboxedTupleType, isAlgType, isStrictType, isPrimitiveType,
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, isPrimTyCon,
98 isUnboxedTupleTyCon, isUnLiftedTyCon,
99 isFunTyCon, isNewTyCon, newTyConRep,
100 isAlgTyCon, isSynTyCon, tyConArity,
101 tyConKind, getSynTyConDefn,
106 import CmdLineOpts ( opt_DictsStrict )
107 import Maybes ( maybeToBool )
108 import SrcLoc ( noSrcLoc )
109 import PrimRep ( PrimRep(..) )
110 import Unique ( Uniquable(..) )
111 import Util ( mapAccumL, seqList )
113 import UniqSet ( sizeUniqSet ) -- Should come via VarSet
117 %************************************************************************
119 \subsection{Stuff to do with kinds.}
121 %************************************************************************
124 hasMoreBoxityInfo :: Kind -> Kind -> Bool
125 hasMoreBoxityInfo k1 k2
126 | k2 `eqKind` openTypeKind = True
127 | otherwise = k1 `eqType` k2
129 defaultKind :: Kind -> Kind
130 -- Used when generalising: default kind '?' to '*'
131 defaultKind kind | kind `eqKind` openTypeKind = liftedTypeKind
134 isTypeKind :: Kind -> Bool
135 -- True of kind * and *#
136 isTypeKind k = case splitTyConApp_maybe k of
137 Just (tc,[k]) -> tc == typeCon
142 %************************************************************************
144 \subsection{Constructor-specific functions}
146 %************************************************************************
149 ---------------------------------------------------------------------
153 mkTyVarTy :: TyVar -> Type
156 mkTyVarTys :: [TyVar] -> [Type]
157 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
159 getTyVar :: String -> Type -> TyVar
160 getTyVar msg (TyVarTy tv) = tv
161 getTyVar msg (SourceTy p) = getTyVar msg (sourceTypeRep p)
162 getTyVar msg (NoteTy _ t) = getTyVar msg t
163 getTyVar msg ty@(UsageTy _ _) = pprPanic "getTyVar: UTy:" (text msg $$ pprType ty)
164 getTyVar msg other = panic ("getTyVar: " ++ msg)
166 getTyVar_maybe :: Type -> Maybe TyVar
167 getTyVar_maybe (TyVarTy tv) = Just tv
168 getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
169 getTyVar_maybe (SourceTy p) = getTyVar_maybe (sourceTypeRep p)
170 getTyVar_maybe ty@(UsageTy _ _) = pprPanic "getTyVar_maybe: UTy:" (pprType ty)
171 getTyVar_maybe other = Nothing
173 isTyVarTy :: Type -> Bool
174 isTyVarTy (TyVarTy tv) = True
175 isTyVarTy (NoteTy _ ty) = isTyVarTy ty
176 isTyVarTy (SourceTy p) = isTyVarTy (sourceTypeRep p)
177 isTyVarTy ty@(UsageTy _ _) = pprPanic "isTyVarTy: UTy:" (pprType ty)
178 isTyVarTy other = False
182 ---------------------------------------------------------------------
185 We need to be pretty careful with AppTy to make sure we obey the
186 invariant that a TyConApp is always visibly so. mkAppTy maintains the
190 mkAppTy orig_ty1 orig_ty2
191 = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind *
192 UASSERT2( not (isUTy orig_ty2), pprType orig_ty1 <+> pprType orig_ty2 )
193 -- argument must be unannotated
196 mk_app (NoteTy _ ty1) = mk_app ty1
197 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
198 mk_app ty@(UsageTy _ _) = pprPanic "mkAppTy: UTy:" (pprType ty)
199 mk_app ty1 = AppTy orig_ty1 orig_ty2
201 mkAppTys :: Type -> [Type] -> Type
202 mkAppTys orig_ty1 [] = orig_ty1
203 -- This check for an empty list of type arguments
204 -- avoids the needless loss of a type synonym constructor.
205 -- For example: mkAppTys Rational []
206 -- returns to (Ratio Integer), which has needlessly lost
207 -- the Rational part.
208 mkAppTys orig_ty1 orig_tys2
209 = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind *
210 UASSERT2( not (any isUTy orig_tys2), pprType orig_ty1 <+> fsep (map pprType orig_tys2) )
211 -- arguments must be unannotated
214 mk_app (NoteTy _ ty1) = mk_app ty1
215 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
216 mk_app ty@(UsageTy _ _) = pprPanic "mkAppTys: UTy:" (pprType ty)
217 mk_app ty1 = foldl AppTy orig_ty1 orig_tys2
219 splitAppTy_maybe :: Type -> Maybe (Type, Type)
220 splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [unUTy ty1], unUTy ty2)
221 splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
222 splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty
223 splitAppTy_maybe (SourceTy p) = splitAppTy_maybe (sourceTypeRep p)
224 splitAppTy_maybe (TyConApp tc []) = Nothing
225 splitAppTy_maybe (TyConApp tc tys) = split tys []
227 split [ty2] acc = Just (TyConApp tc (reverse acc), ty2)
228 split (ty:tys) acc = split tys (ty:acc)
230 splitAppTy_maybe ty@(UsageTy _ _) = pprPanic "splitAppTy_maybe: UTy:" (pprType ty)
231 splitAppTy_maybe other = Nothing
233 splitAppTy :: Type -> (Type, Type)
234 splitAppTy ty = case splitAppTy_maybe ty of
236 Nothing -> panic "splitAppTy"
238 splitAppTys :: Type -> (Type, [Type])
239 splitAppTys ty = split ty ty []
241 split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
242 split orig_ty (NoteTy _ ty) args = split orig_ty ty args
243 split orig_ty (SourceTy p) args = split orig_ty (sourceTypeRep p) args
244 split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
245 (TyConApp funTyCon [], [unUTy ty1,unUTy ty2])
246 split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
247 split orig_ty (UsageTy _ _) args = pprPanic "splitAppTys: UTy:" (pprType orig_ty)
248 split orig_ty ty args = (orig_ty, args)
252 ---------------------------------------------------------------------
257 mkFunTy :: Type -> Type -> Type
258 mkFunTy arg res = UASSERT2( isUTy arg && isUTy res, pprType arg <+> pprType res )
261 mkFunTys :: [Type] -> Type -> Type
262 mkFunTys tys ty = UASSERT2( all isUTy (ty:tys), fsep (map pprType (tys++[ty])) )
265 splitFunTy :: Type -> (Type, Type)
266 splitFunTy (FunTy arg res) = (arg, res)
267 splitFunTy (NoteTy _ ty) = splitFunTy ty
268 splitFunTy (SourceTy p) = splitFunTy (sourceTypeRep p)
269 splitFunTy ty@(UsageTy _ _) = pprPanic "splitFunTy: UTy:" (pprType ty)
271 splitFunTy_maybe :: Type -> Maybe (Type, Type)
272 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
273 splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
274 splitFunTy_maybe (SourceTy p) = splitFunTy_maybe (sourceTypeRep p)
275 splitFunTy_maybe ty@(UsageTy _ _) = pprPanic "splitFunTy_maybe: UTy:" (pprType ty)
276 splitFunTy_maybe other = Nothing
278 splitFunTys :: Type -> ([Type], Type)
279 splitFunTys ty = split [] ty ty
281 split args orig_ty (FunTy arg res) = split (arg:args) res res
282 split args orig_ty (NoteTy _ ty) = split args orig_ty ty
283 split args orig_ty (SourceTy p) = split args orig_ty (sourceTypeRep p)
284 split args orig_ty (UsageTy _ _) = pprPanic "splitFunTys: UTy:" (pprType orig_ty)
285 split args orig_ty ty = (reverse args, orig_ty)
287 zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
288 zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
290 split acc [] nty ty = (reverse acc, nty)
291 split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
292 split acc xs nty (NoteTy _ ty) = split acc xs nty ty
293 split acc xs nty (SourceTy p) = split acc xs nty (sourceTypeRep p)
294 split acc xs nty (UsageTy _ _) = pprPanic "zipFunTys: UTy:" (ppr orig_xs <+> pprType orig_ty)
295 split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty)
297 funResultTy :: Type -> Type
298 funResultTy (FunTy arg res) = res
299 funResultTy (NoteTy _ ty) = funResultTy ty
300 funResultTy (SourceTy p) = funResultTy (sourceTypeRep p)
301 funResultTy (UsageTy _ ty) = funResultTy ty
302 funResultTy ty = pprPanic "funResultTy" (pprType ty)
304 funArgTy :: Type -> Type
305 funArgTy (FunTy arg res) = arg
306 funArgTy (NoteTy _ ty) = funArgTy ty
307 funArgTy (SourceTy p) = funArgTy (sourceTypeRep p)
308 funArgTy (UsageTy _ ty) = funArgTy ty
309 funArgTy ty = pprPanic "funArgTy" (pprType ty)
313 ---------------------------------------------------------------------
316 @mkTyConApp@ is a key function, because it builds a TyConApp, FunTy or SourceTy,
320 mkTyConApp :: TyCon -> [Type] -> Type
321 -- Assumes TyCon is not a SynTyCon; use mkSynTy instead for those
323 | isFunTyCon tycon, [ty1,ty2] <- tys
324 = FunTy (mkUTyM ty1) (mkUTyM ty2)
326 | isNewTyCon tycon, -- A saturated newtype application;
327 not (isRecursiveTyCon tycon), -- Not recursive (we don't use SourceTypes for them)
328 length tys == tyConArity tycon -- use the SourceType form
329 = SourceTy (NType tycon tys)
332 = ASSERT(not (isSynTyCon tycon))
333 UASSERT2( not (any isUTy tys), ppr tycon <+> fsep (map pprType tys) )
336 mkTyConTy :: TyCon -> Type
337 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
340 -- splitTyConApp "looks through" synonyms, because they don't
341 -- mean a distinct type, but all other type-constructor applications
342 -- including functions are returned as Just ..
344 tyConAppTyCon :: Type -> TyCon
345 tyConAppTyCon ty = fst (splitTyConApp ty)
347 tyConAppArgs :: Type -> [Type]
348 tyConAppArgs ty = snd (splitTyConApp ty)
350 splitTyConApp :: Type -> (TyCon, [Type])
351 splitTyConApp ty = case splitTyConApp_maybe ty of
353 Nothing -> pprPanic "splitTyConApp" (pprType ty)
355 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
356 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
357 splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [unUTy arg,unUTy res])
358 splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
359 splitTyConApp_maybe (SourceTy p) = splitTyConApp_maybe (sourceTypeRep p)
360 splitTyConApp_maybe (UsageTy _ ty) = splitTyConApp_maybe ty
361 splitTyConApp_maybe other = Nothing
365 ---------------------------------------------------------------------
370 mkSynTy syn_tycon tys
371 = ASSERT( isSynTyCon syn_tycon )
372 ASSERT( length tyvars == length tys )
373 NoteTy (SynNote (TyConApp syn_tycon tys))
374 (substTyWith tyvars tys body)
376 (tyvars, body) = getSynTyConDefn syn_tycon
379 Notes on type synonyms
380 ~~~~~~~~~~~~~~~~~~~~~~
381 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
382 to return type synonyms whereever possible. Thus
387 splitFunTys (a -> Foo a) = ([a], Foo a)
390 The reason is that we then get better (shorter) type signatures in
391 interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
397 repType looks through
401 (d) usage annotations
402 (e) [recursive] newtypes
403 It's useful in the back end.
405 Remember, non-recursive newtypes get expanded as part of the SourceTy case,
406 but recursive ones are represented by TyConApps and have to be expanded
410 repType :: Type -> Type
411 repType (ForAllTy _ ty) = repType ty
412 repType (NoteTy _ ty) = repType ty
413 repType (SourceTy p) = repType (sourceTypeRep p)
414 repType (UsageTy _ ty) = repType ty
415 repType (TyConApp tc tys) | isNewTyCon tc && length tys == tyConArity tc
416 = repType (newTypeRep tc tys)
419 splitRepFunTys :: Type -> ([Type], Type)
420 -- Like splitFunTys, but looks through newtypes and for-alls
421 splitRepFunTys ty = split [] (repType ty)
423 split args (FunTy arg res) = split (arg:args) (repType res)
424 split args ty = (reverse args, ty)
426 typePrimRep :: Type -> PrimRep
427 typePrimRep ty = case repType ty of
428 TyConApp tc _ -> tyConPrimRep tc
430 AppTy _ _ -> PtrRep -- ??
436 ---------------------------------------------------------------------
441 mkForAllTy :: TyVar -> Type -> Type
443 = mkForAllTys [tyvar] ty
445 mkForAllTys :: [TyVar] -> Type -> Type
446 mkForAllTys tyvars ty
447 = case splitUTy_maybe ty of
448 Just (u,ty1) -> UASSERT2( not (mkVarSet tyvars `intersectsVarSet` tyVarsOfType u),
449 ptext SLIT("mkForAllTys: usage scope")
450 <+> ppr tyvars <+> pprType ty )
451 mkUTy u (foldr ForAllTy ty1 tyvars) -- we lift usage annotations over foralls
452 Nothing -> foldr ForAllTy ty tyvars
454 isForAllTy :: Type -> Bool
455 isForAllTy (NoteTy _ ty) = isForAllTy ty
456 isForAllTy (ForAllTy _ _) = True
457 isForAllTy (UsageTy _ ty) = isForAllTy ty
458 isForAllTy other_ty = False
460 splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
461 splitForAllTy_maybe ty = splitFAT_m ty
463 splitFAT_m (NoteTy _ ty) = splitFAT_m ty
464 splitFAT_m (SourceTy p) = splitFAT_m (sourceTypeRep p)
465 splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
466 splitFAT_m (UsageTy _ ty) = splitFAT_m ty
467 splitFAT_m _ = Nothing
469 splitForAllTys :: Type -> ([TyVar], Type)
470 splitForAllTys ty = split ty ty []
472 split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
473 split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
474 split orig_ty (SourceTy p) tvs = split orig_ty (sourceTypeRep p) tvs
475 split orig_ty (UsageTy _ ty) tvs = split orig_ty ty tvs
476 split orig_ty t tvs = (reverse tvs, orig_ty)
479 -- (mkPiType now in CoreUtils)
481 Applying a for-all to its arguments. Lift usage annotation as required.
484 applyTy :: Type -> Type -> Type
485 applyTy (SourceTy p) arg = applyTy (sourceTypeRep p) arg
486 applyTy (NoteTy _ fun) arg = applyTy fun arg
487 applyTy (ForAllTy tv ty) arg = UASSERT2( not (isUTy arg),
488 ptext SLIT("applyTy")
489 <+> pprType ty <+> pprType arg )
490 substTyWith [tv] [arg] ty
491 applyTy (UsageTy u ty) arg = UsageTy u (applyTy ty arg)
492 applyTy other arg = panic "applyTy"
494 applyTys :: Type -> [Type] -> Type
495 applyTys fun_ty arg_tys
496 = UASSERT2( not (any isUTy arg_tys), ptext SLIT("applyTys") <+> pprType fun_ty )
500 substTyWith tvs arg_tys ty
502 (mu, tvs, ty) = split fun_ty arg_tys
504 split fun_ty [] = (Nothing, [], fun_ty)
505 split (NoteTy _ fun_ty) args = split fun_ty args
506 split (SourceTy p) args = split (sourceTypeRep p) args
507 split (ForAllTy tv fun_ty) (arg:args) = case split fun_ty args of
508 (mu, tvs, ty) -> (mu, tv:tvs, ty)
509 split (UsageTy u ty) args = case split ty args of
510 (Nothing, tvs, ty) -> (Just u, tvs, ty)
511 (Just _ , _ , _ ) -> pprPanic "applyTys:"
513 split other_ty args = panic "applyTys"
517 ---------------------------------------------------------------------
521 Constructing and taking apart usage types.
524 mkUTy :: Type -> Type -> Type
526 = ASSERT2( typeKind u `eqKind` usageTypeKind,
527 ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
528 UASSERT2( not (isUTy ty), ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
529 -- if u == usMany then ty else : ToDo? KSW 2000-10
536 splitUTy :: Type -> (Type {- :: $ -}, Type)
538 = case splitUTy_maybe orig_ty of
539 Just (u,ty) -> (u,ty)
541 Nothing -> pprPanic "splitUTy:" (pprType orig_ty)
543 Nothing -> (usMany,orig_ty) -- default annotation ToDo KSW 2000-10
546 splitUTy_maybe :: Type -> Maybe (Type {- :: $ -}, Type)
547 splitUTy_maybe (UsageTy u ty) = Just (u,ty)
548 splitUTy_maybe (NoteTy _ ty) = splitUTy_maybe ty
549 splitUTy_maybe other_ty = Nothing
551 isUTy :: Type -> Bool
552 -- has usage annotation
553 isUTy = maybeToBool . splitUTy_maybe
555 uaUTy :: Type -> Type
556 -- extract annotation
557 uaUTy = fst . splitUTy
559 unUTy :: Type -> Type
560 -- extract unannotated type
561 unUTy = snd . splitUTy
565 liftUTy :: (Type -> Type) -> Type -> Type
566 -- lift outer usage annot over operation on unannotated types
569 (u,ty') = splitUTy ty
575 mkUTyM :: Type -> Type
576 -- put TOP (no info) annotation on unannotated type
577 mkUTyM ty = mkUTy usMany ty
581 isUsageKind :: Kind -> Bool
583 = ASSERT( typeKind k `eqKind` superKind )
584 k `eqKind` usageTypeKind
586 isUsage :: Type -> Bool
588 = isUsageKind (typeKind ty)
590 isUTyVar :: Var -> Bool
592 = isUsageKind (tyVarKind v)
596 %************************************************************************
598 \subsection{Source types}
600 %************************************************************************
602 A "source type" is a type that is a separate type as far as the type checker is
603 concerned, but which has low-level representation as far as the back end is concerned.
605 Source types are always lifted.
607 The key function is sourceTypeRep which gives the representation of a source type:
610 mkPredTy :: PredType -> Type
611 mkPredTy pred = SourceTy pred
613 mkPredTys :: ThetaType -> [Type]
614 mkPredTys preds = map SourceTy preds
616 sourceTypeRep :: SourceType -> Type
617 -- Convert a predicate to its "representation type";
618 -- the type of evidence for that predicate, which is actually passed at runtime
619 sourceTypeRep (IParam n ty) = ty
620 sourceTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
621 -- Note the mkTyConApp; the classTyCon might be a newtype!
622 sourceTypeRep (NType tc tys) = newTypeRep tc tys
623 -- ToDo: Consider caching this substitution in a NType
625 isSourceTy :: Type -> Bool
626 isSourceTy (NoteTy _ ty) = isSourceTy ty
627 isSourceTy (UsageTy _ ty) = isSourceTy ty
628 isSourceTy (SourceTy sty) = True
632 splitNewType_maybe :: Type -> Maybe Type
633 -- Newtypes that are recursive are reprsented by TyConApp, just
634 -- as they always were. Occasionally we want to find their representation type.
635 -- NB: remember that in this module, non-recursive newtypes are transparent
637 splitNewType_maybe ty
638 = case splitTyConApp_maybe ty of
639 Just (tc,tys) | isNewTyCon tc -> ASSERT( length tys == tyConArity tc )
640 -- The assert should hold because repType should
641 -- only be applied to *types* (of kind *)
642 Just (newTypeRep tc tys)
645 -- A local helper function (not exported)
646 newTypeRep new_tycon tys = case newTyConRep new_tycon of
647 (tvs, rep_ty) -> substTyWith tvs tys rep_ty
651 %************************************************************************
653 \subsection{Kinds and free variables}
655 %************************************************************************
657 ---------------------------------------------------------------------
658 Finding the kind of a type
659 ~~~~~~~~~~~~~~~~~~~~~~~~~~
661 typeKind :: Type -> Kind
663 typeKind (TyVarTy tyvar) = tyVarKind tyvar
664 typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
665 typeKind (NoteTy _ ty) = typeKind ty
666 typeKind (SourceTy _) = liftedTypeKind -- Predicates are always
667 -- represented by lifted types
668 typeKind (AppTy fun arg) = funResultTy (typeKind fun)
670 typeKind (FunTy arg res) = fix_up (typeKind res)
672 fix_up (TyConApp tycon _) | tycon == typeCon
673 || tycon == openKindCon = liftedTypeKind
674 fix_up (NoteTy _ kind) = fix_up kind
676 -- The basic story is
677 -- typeKind (FunTy arg res) = typeKind res
678 -- But a function is lifted regardless of its result type
679 -- Hence the strange fix-up.
680 -- Note that 'res', being the result of a FunTy, can't have
681 -- a strange kind like (*->*).
683 typeKind (ForAllTy tv ty) = typeKind ty
684 typeKind (UsageTy _ ty) = typeKind ty -- we don't have separate kinds for ann/unann
688 ---------------------------------------------------------------------
689 Free variables of a type
690 ~~~~~~~~~~~~~~~~~~~~~~~~
692 tyVarsOfType :: Type -> TyVarSet
693 tyVarsOfType (TyVarTy tv) = unitVarSet tv
694 tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
695 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
696 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
697 tyVarsOfType (SourceTy sty) = tyVarsOfSourceType sty
698 tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
699 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
700 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
701 tyVarsOfType (UsageTy u ty) = tyVarsOfType u `unionVarSet` tyVarsOfType ty
703 tyVarsOfTypes :: [Type] -> TyVarSet
704 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
706 tyVarsOfPred :: PredType -> TyVarSet
707 tyVarsOfPred = tyVarsOfSourceType -- Just a subtype
709 tyVarsOfSourceType :: SourceType -> TyVarSet
710 tyVarsOfSourceType (IParam n ty) = tyVarsOfType ty
711 tyVarsOfSourceType (ClassP clas tys) = tyVarsOfTypes tys
712 tyVarsOfSourceType (NType tc tys) = tyVarsOfTypes tys
714 tyVarsOfTheta :: ThetaType -> TyVarSet
715 tyVarsOfTheta = foldr (unionVarSet . tyVarsOfSourceType) emptyVarSet
717 -- Add a Note with the free tyvars to the top of the type
718 addFreeTyVars :: Type -> Type
719 addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
720 addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
723 Usage annotations of a type
724 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
726 Get a list of usage annotations of a type, *in left-to-right pre-order*.
729 usageAnnOfType :: Type -> [Type]
734 goT (AppTy ty1 ty2) = goT ty1 ++ goT ty2
735 goT (TyConApp tc tys) = concatMap goT tys
736 goT (FunTy sty1 sty2) = goS sty1 ++ goS sty2
737 goT (ForAllTy mv ty) = goT ty
738 goT (SourceTy p) = goT (sourceTypeRep p)
739 goT ty@(UsageTy _ _) = pprPanic "usageAnnOfType: unexpected usage:" (pprType ty)
740 goT (NoteTy note ty) = goT ty
742 goS sty = case splitUTy sty of
743 (u,tty) -> u : goT tty
747 %************************************************************************
749 \subsection{TidyType}
751 %************************************************************************
753 tidyTy tidies up a type for printing in an error message, or in
756 It doesn't change the uniques at all, just the print names.
759 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
760 tidyTyVar env@(tidy_env, subst) tyvar
761 = case lookupVarEnv subst tyvar of
763 Just tyvar' -> -- Already substituted
766 Nothing -> -- Make a new nice name for it
768 case tidyOccName tidy_env (getOccName name) of
769 (tidy', occ') -> -- New occname reqd
770 ((tidy', subst'), tyvar')
772 subst' = extendVarEnv subst tyvar tyvar'
773 tyvar' = setTyVarName tyvar name'
774 name' = mkLocalName (getUnique name) occ' noSrcLoc
775 -- Note: make a *user* tyvar, so it printes nicely
776 -- Could extract src loc, but no need.
778 name = tyVarName tyvar
780 tidyTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
781 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
783 tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
784 -- Add the free tyvars to the env in tidy form,
785 -- so that we can tidy the type they are free in
786 tidyFreeTyVars env tyvars = foldl add env (varSetElems tyvars)
788 add env tv = fst (tidyTyVar env tv)
790 tidyType :: TidyEnv -> Type -> Type
791 tidyType env@(tidy_env, subst) ty
794 go (TyVarTy tv) = case lookupVarEnv subst tv of
795 Nothing -> TyVarTy tv
796 Just tv' -> TyVarTy tv'
797 go (TyConApp tycon tys) = let args = map go tys
798 in args `seqList` TyConApp tycon args
799 go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
800 go (SourceTy sty) = SourceTy (tidySourceType env sty)
801 go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
802 go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
803 go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty)
805 (envp, tvp) = tidyTyVar env tv
806 go (UsageTy u ty) = (UsageTy SAPPLY (go u)) SAPPLY (go ty)
808 go_note (SynNote ty) = SynNote SAPPLY (go ty)
809 go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
811 tidyTypes env tys = map (tidyType env) tys
813 tidyPred :: TidyEnv -> SourceType -> SourceType
814 tidyPred = tidySourceType
816 tidySourceType :: TidyEnv -> SourceType -> SourceType
817 tidySourceType env (IParam n ty) = IParam n (tidyType env ty)
818 tidySourceType env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
819 tidySourceType env (NType tc tys) = NType tc (tidyTypes env tys)
823 @tidyOpenType@ grabs the free type variables, tidies them
824 and then uses @tidyType@ to work over the type itself
827 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
829 = (env', tidyType env' ty)
831 env' = tidyFreeTyVars env (tyVarsOfType ty)
833 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
834 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
836 tidyTopType :: Type -> Type
837 tidyTopType ty = tidyType emptyTidyEnv ty
842 %************************************************************************
844 \subsection{Liftedness}
846 %************************************************************************
849 isUnLiftedType :: Type -> Bool
850 -- isUnLiftedType returns True for forall'd unlifted types:
851 -- x :: forall a. Int#
852 -- I found bindings like these were getting floated to the top level.
853 -- They are pretty bogus types, mind you. It would be better never to
856 isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
857 isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty
858 isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
859 isUnLiftedType (UsageTy _ ty) = isUnLiftedType ty
860 isUnLiftedType (SourceTy _) = False -- All source types are lifted
861 isUnLiftedType other = False
863 isUnboxedTupleType :: Type -> Bool
864 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
865 Just (tc, ty_args) -> isUnboxedTupleTyCon tc
868 -- Should only be applied to *types*; hence the assert
869 isAlgType :: Type -> Bool
870 isAlgType ty = case splitTyConApp_maybe ty of
871 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
876 @isStrictType@ computes whether an argument (or let RHS) should
877 be computed strictly or lazily, based only on its type.
878 Works just like isUnLiftedType, except that it has a special case
879 for dictionaries. Since it takes account of ClassP, you might think
880 this function should be in TcType, but isStrictType is used by DataCon,
881 which is below TcType in the hierarchy, so it's convenient to put it here.
884 isStrictType (ForAllTy tv ty) = isStrictType ty
885 isStrictType (NoteTy _ ty) = isStrictType ty
886 isStrictType (TyConApp tc _) = isUnLiftedTyCon tc
887 isStrictType (UsageTy _ ty) = isStrictType ty
888 isStrictType (SourceTy (ClassP clas _)) = opt_DictsStrict && not (isNewTyCon (classTyCon clas))
889 -- We may be strict in dictionary types, but only if it
890 -- has more than one component.
891 -- [Being strict in a single-component dictionary risks
892 -- poking the dictionary component, which is wrong.]
893 isStrictType other = False
897 isPrimitiveType :: Type -> Bool
898 -- Returns types that are opaque to Haskell.
899 -- Most of these are unlifted, but now that we interact with .NET, we
900 -- may have primtive (foreign-imported) types that are lifted
901 isPrimitiveType ty = case splitTyConApp_maybe ty of
902 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
908 %************************************************************************
910 \subsection{Sequencing on types
912 %************************************************************************
915 seqType :: Type -> ()
916 seqType (TyVarTy tv) = tv `seq` ()
917 seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
918 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
919 seqType (NoteTy note t2) = seqNote note `seq` seqType t2
920 seqType (SourceTy p) = seqPred p
921 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
922 seqType (ForAllTy tv ty) = tv `seq` seqType ty
923 seqType (UsageTy u ty) = seqType u `seq` seqType ty
925 seqTypes :: [Type] -> ()
927 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
929 seqNote :: TyNote -> ()
930 seqNote (SynNote ty) = seqType ty
931 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
933 seqPred :: SourceType -> ()
934 seqPred (ClassP c tys) = c `seq` seqTypes tys
935 seqPred (NType tc tys) = tc `seq` seqTypes tys
936 seqPred (IParam n ty) = n `seq` seqType ty
940 %************************************************************************
942 \subsection{Equality on types}
944 %************************************************************************
946 Comparison; don't use instances so that we know where it happens.
947 Look through newtypes but not usage types.
950 eqType t1 t2 = eq_ty emptyVarEnv t1 t2
951 eqKind = eqType -- No worries about looking
952 eqUsage = eqType -- through source types for these two
954 -- Look through Notes
955 eq_ty env (NoteTy _ t1) t2 = eq_ty env t1 t2
956 eq_ty env t1 (NoteTy _ t2) = eq_ty env t1 t2
958 -- Look through SourceTy. This is where the looping danger comes from
959 eq_ty env (SourceTy sty1) t2 = eq_ty env (sourceTypeRep sty1) t2
960 eq_ty env t1 (SourceTy sty2) = eq_ty env t1 (sourceTypeRep sty2)
962 -- The rest is plain sailing
963 eq_ty env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
964 Just tv1a -> tv1a == tv2
965 Nothing -> tv1 == tv2
966 eq_ty env (ForAllTy tv1 t1) (ForAllTy tv2 t2)
967 | tv1 == tv2 = eq_ty env t1 t2
968 | otherwise = eq_ty (extendVarEnv env tv1 tv2) t1 t2
969 eq_ty env (AppTy s1 t1) (AppTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2)
970 eq_ty env (FunTy s1 t1) (FunTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2)
971 eq_ty env (UsageTy _ t1) (UsageTy _ t2) = eq_ty env t1 t2
972 eq_ty env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 == tc2) && (eq_tys env tys1 tys2)
973 eq_ty env t1 t2 = False
975 eq_tys env [] [] = True
976 eq_tys env (t1:tys1) (t2:tys2) = (eq_ty env t1 t2) && (eq_tys env tys1 tys2)
977 eq_tys env tys1 tys2 = False