2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
8 Type(..), TyNote(..), UsageAnn(..), -- Representation visible to friends
11 superKind, superBoxity, -- :: SuperKind
13 boxedKind, -- :: Kind :: BX
14 anyBoxKind, -- :: Kind :: BX
15 typeCon, -- :: KindCon :: BX -> KX
16 anyBoxCon, -- :: KindCon :: BX
18 boxedTypeKind, unboxedTypeKind, openTypeKind, -- Kind :: superKind
20 mkArrowKind, mkArrowKinds, hasMoreBoxityInfo,
24 mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
26 mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
28 mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, splitFunTysN,
29 funResultTy, funArgTy,
32 mkTyConApp, mkTyConTy, splitTyConApp_maybe,
33 splitAlgTyConApp_maybe, splitAlgTyConApp,
34 mkDictTy, splitDictTy_maybe, isDictTy,
36 mkSynTy, isSynTy, deNoteType, repType, splitNewType_maybe,
38 mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg,
40 mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
41 isForAllTy, applyTy, applyTys, mkPiType,
43 TauType, RhoType, SigmaType, ThetaType,
46 mkSigmaTy, splitSigmaTy,
49 isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
53 tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind,
56 -- Tidying up for printing
58 tidyOpenType, tidyOpenTypes,
59 tidyTyVar, tidyTyVars,
67 #include "HsVersions.h"
69 import {-# SOURCE #-} DataCon( DataCon, dataConType )
70 import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
71 import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy )
74 import Var ( Id, TyVar, IdOrTyVar, UVar,
75 tyVarKind, tyVarName, isId, idType, setTyVarName, setVarOcc
80 import Name ( NamedThing(..), Provenance(..), ExportFlag(..),
81 mkWiredInTyConName, mkGlobalName, mkLocalName, mkKindOccFS, tcName,
82 tidyOccName, TidyOccEnv
85 import Class ( classTyCon, Class )
86 import TyCon ( TyCon, KindCon,
87 mkFunTyCon, mkKindCon, mkSuperKindCon,
88 matchesTyCon, isUnboxedTupleTyCon, isUnLiftedTyCon,
89 isFunTyCon, isDataTyCon, isNewTyCon,
90 isAlgTyCon, isSynTyCon, tyConArity,
91 tyConKind, tyConDataCons, getSynTyConDefn,
92 tyConPrimRep, tyConClass_maybe
96 import BasicTypes ( Unused )
97 import SrcLoc ( mkBuiltinSrcLoc, noSrcLoc )
98 import PrelMods ( pREL_GHC )
99 import Maybes ( maybeToBool )
100 import PrimRep ( PrimRep(..), isFollowableRep )
101 import Unique -- quite a few *Keys
102 import Util ( thenCmp, mapAccumL, seqList, ($!) )
104 import UniqSet ( sizeUniqSet ) -- Should come via VarSet
107 %************************************************************************
109 \subsection{Type Classifications}
111 %************************************************************************
115 *unboxed* iff its representation is other than a pointer
116 Unboxed types cannot instantiate a type variable.
117 Unboxed types are always unlifted.
119 *lifted* A type is lifted iff it has bottom as an element.
120 Closures always have lifted types: i.e. any
121 let-bound identifier in Core must have a lifted
122 type. Operationally, a lifted object is one that
124 (NOTE: previously "pointed").
126 *algebraic* A type with one or more constructors, whether declared
127 with "data" or "newtype".
128 An algebraic type is one that can be deconstructed
129 with a case expression.
130 *NOT* the same as lifted types, because we also
131 include unboxed tuples in this classification.
133 *data* A type declared with "data". Also boxed tuples.
135 *primitive* iff it is a built-in type that can't be expressed
138 Currently, all primitive types are unlifted, but that's not necessarily
139 the case. (E.g. Int could be primitive.)
141 Some primitive types are unboxed, such as Int#, whereas some are boxed
142 but unlifted (such as ByteArray#). The only primitive types that we
143 classify as algebraic are the unboxed tuples.
145 examples of type classifications:
147 Type primitive boxed lifted algebraic
148 -----------------------------------------------------------------------------
150 ByteArray# Yes Yes No No
151 (# a, b #) Yes No No Yes
152 ( a, b ) No Yes Yes Yes
155 %************************************************************************
157 \subsection{The data type}
159 %************************************************************************
163 type SuperKind = Type
166 type TyVarSubst = TyVarEnv Type
172 Type -- Function is *not* a TyConApp
175 | TyConApp -- Application of a TyCon
176 TyCon -- *Invariant* saturated appliations of FunTyCon and
177 -- synonyms have their own constructors, below.
178 [Type] -- Might not be saturated.
180 | FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2]
184 | NoteTy -- Saturated application of a type synonym
186 Type -- The expanded version
193 = SynNote Type -- The unexpanded version of the type synonym; always a TyConApp
194 | FTVNote TyVarSet -- The free type variables of the noted expression
195 | UsgNote UsageAnn -- The usage annotation at this node
198 = UsOnce -- Used at most once
199 | UsMany -- Used possibly many times (no info; this annotation can be omitted)
200 | UsVar UVar -- Annotation is variable (should only happen inside analysis)
204 %************************************************************************
208 %************************************************************************
216 kv :: KX is a kind variable
222 | AnyBox -- Used *only* for special built-in things
223 -- like error :: forall (a::*?). String -> a
224 -- Here, the 'a' can be instantiated to a boxed or
228 bxv :: BX is a boxity variable
232 | sk -> sk -- In ptic (BX -> KX)
235 mk_kind_name key str = mkGlobalName key pREL_GHC (mkKindOccFS tcName str)
236 (LocalDef mkBuiltinSrcLoc NotExported)
237 -- mk_kind_name is a bit of a hack
238 -- The LocalDef means that we print the name without
239 -- a qualifier, which is what we want for these kinds.
240 -- It's used for both Kinds and Boxities
246 superKind :: SuperKind -- KX, the type of all kinds
247 superKindName = mk_kind_name kindConKey SLIT("KX")
248 superKind = TyConApp (mkSuperKindCon superKindName) []
250 superBoxity :: SuperKind -- BX, the type of all boxities
251 superBoxityName = mk_kind_name boxityConKey SLIT("BX")
252 superBoxity = TyConApp (mkSuperKindCon superBoxityName) []
255 Define Boxed, Unboxed, AnyBox
258 boxedKind, unboxedKind, anyBoxKind :: Kind -- Of superkind superBoxity
260 boxedConName = mk_kind_name boxedConKey SLIT("*")
261 boxedKind = TyConApp (mkKindCon boxedConName superBoxity) []
263 unboxedConName = mk_kind_name unboxedConKey SLIT("#")
264 unboxedKind = TyConApp (mkKindCon unboxedConName superBoxity) []
266 anyBoxConName = mk_kind_name anyBoxConKey SLIT("?")
267 anyBoxCon = mkKindCon anyBoxConName superBoxity -- A kind of wild card
268 anyBoxKind = TyConApp anyBoxCon []
275 typeConName = mk_kind_name typeConKey SLIT("Type")
276 typeCon = mkKindCon typeConName (superBoxity `FunTy` superKind)
279 Define (Type Boxed), (Type Unboxed), (Type AnyBox)
282 boxedTypeKind, unboxedTypeKind, openTypeKind :: Kind
283 boxedTypeKind = TyConApp typeCon [boxedKind]
284 unboxedTypeKind = TyConApp typeCon [unboxedKind]
285 openTypeKind = TyConApp typeCon [anyBoxKind]
287 mkArrowKind :: Kind -> Kind -> Kind
288 mkArrowKind k1 k2 = k1 `FunTy` k2
290 mkArrowKinds :: [Kind] -> Kind -> Kind
291 mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
295 hasMoreBoxityInfo :: Kind -> Kind -> Bool
296 hasMoreBoxityInfo k1 k2
297 | k2 == openTypeKind = ASSERT( is_type_kind k1) True
298 | otherwise = k1 == k2
300 -- Returns true for things of form (Type x)
301 is_type_kind k = case splitTyConApp_maybe k of
302 Just (tc,[_]) -> tc == typeCon
307 %************************************************************************
309 \subsection{Wired-in type constructors
311 %************************************************************************
313 We define a few wired-in type constructors here to avoid module knots
316 funTyConName = mkWiredInTyConName funTyConKey pREL_GHC SLIT("(->)") funTyCon
317 funTyCon = mkFunTyCon funTyConName (mkArrowKinds [boxedTypeKind, boxedTypeKind] boxedTypeKind)
322 %************************************************************************
324 \subsection{Constructor-specific functions}
326 %************************************************************************
329 ---------------------------------------------------------------------
333 mkTyVarTy :: TyVar -> Type
336 mkTyVarTys :: [TyVar] -> [Type]
337 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
339 getTyVar :: String -> Type -> TyVar
340 getTyVar msg (TyVarTy tv) = tv
341 getTyVar msg (NoteTy _ t) = getTyVar msg t
342 getTyVar msg other = panic ("getTyVar: " ++ msg)
344 getTyVar_maybe :: Type -> Maybe TyVar
345 getTyVar_maybe (TyVarTy tv) = Just tv
346 getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
347 getTyVar_maybe other = Nothing
349 isTyVarTy :: Type -> Bool
350 isTyVarTy (TyVarTy tv) = True
351 isTyVarTy (NoteTy _ ty) = isTyVarTy ty
352 isTyVarTy other = False
356 ---------------------------------------------------------------------
359 We need to be pretty careful with AppTy to make sure we obey the
360 invariant that a TyConApp is always visibly so. mkAppTy maintains the
364 mkAppTy orig_ty1 orig_ty2 = ASSERT2( isNotUsgTy orig_ty1 && isNotUsgTy orig_ty2, pprType orig_ty1 <+> text "to" <+> pprType orig_ty2 )
367 mk_app (NoteTy _ ty1) = mk_app ty1
368 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
369 mk_app ty1 = AppTy orig_ty1 orig_ty2
371 mkAppTys :: Type -> [Type] -> Type
372 mkAppTys orig_ty1 [] = orig_ty1
373 -- This check for an empty list of type arguments
374 -- avoids the needless of a type synonym constructor.
375 -- For example: mkAppTys Rational []
376 -- returns to (Ratio Integer), which has needlessly lost
377 -- the Rational part.
378 mkAppTys orig_ty1 orig_tys2 = ASSERT2( isNotUsgTy orig_ty1, pprType orig_ty1 )
381 mk_app (NoteTy _ ty1) = mk_app ty1
382 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
383 mk_app ty1 = ASSERT2( all isNotUsgTy orig_tys2, pprType orig_ty1 <+> text "to" <+> hsep (map pprType orig_tys2) )
384 foldl AppTy orig_ty1 orig_tys2
386 splitAppTy_maybe :: Type -> Maybe (Type, Type)
387 splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
388 splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
389 splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty
390 splitAppTy_maybe (TyConApp tc []) = Nothing
391 splitAppTy_maybe (TyConApp tc tys) = split tys []
393 split [ty2] acc = Just (TyConApp tc (reverse acc), ty2)
394 split (ty:tys) acc = split tys (ty:acc)
396 splitAppTy_maybe other = Nothing
398 splitAppTy :: Type -> (Type, Type)
399 splitAppTy ty = case splitAppTy_maybe ty of
401 Nothing -> panic "splitAppTy"
403 splitAppTys :: Type -> (Type, [Type])
404 splitAppTys ty = split ty ty []
406 split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
407 split orig_ty (NoteTy _ ty) args = split orig_ty ty args
408 split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
409 (TyConApp funTyCon [], [ty1,ty2])
410 split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
411 split orig_ty ty args = (orig_ty, args)
415 ---------------------------------------------------------------------
420 mkFunTy :: Type -> Type -> Type
421 mkFunTy arg res = FunTy arg res
423 mkFunTys :: [Type] -> Type -> Type
424 mkFunTys tys ty = foldr FunTy ty tys
426 splitFunTy_maybe :: Type -> Maybe (Type, Type)
427 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
428 splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
429 splitFunTy_maybe other = Nothing
431 splitFunTys :: Type -> ([Type], Type)
432 splitFunTys ty = split [] ty ty
434 split args orig_ty (FunTy arg res) = split (arg:args) res res
435 split args orig_ty (NoteTy _ ty) = split args orig_ty ty
436 split args orig_ty ty = (reverse args, orig_ty)
438 splitFunTysN :: String -> Int -> Type -> ([Type], Type)
439 splitFunTysN msg orig_n orig_ty = split orig_n [] orig_ty orig_ty
441 split 0 args syn_ty ty = (reverse args, syn_ty)
442 split n args syn_ty (FunTy arg res) = split (n-1) (arg:args) res res
443 split n args syn_ty (NoteTy _ ty) = split n args syn_ty ty
444 split n args syn_ty ty = pprPanic ("splitFunTysN: " ++ msg) (int orig_n <+> pprType orig_ty)
446 zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
447 zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
449 split acc [] nty ty = (reverse acc, nty)
450 split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
451 split acc xs nty (NoteTy _ ty) = split acc xs nty ty
452 split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty)
454 funResultTy :: Type -> Type
455 funResultTy (FunTy arg res) = res
456 funResultTy (NoteTy _ ty) = funResultTy ty
457 funResultTy ty = pprPanic "funResultTy" (pprType ty)
459 funArgTy :: Type -> Type
460 funArgTy (FunTy arg res) = arg
461 funArgTy (NoteTy _ ty) = funArgTy ty
462 funArgTy ty = pprPanic "funArgTy" (pprType ty)
466 ---------------------------------------------------------------------
471 mkTyConApp :: TyCon -> [Type] -> Type
473 | isFunTyCon tycon && length tys == 2
475 (ty1:ty2:_) -> FunTy ty1 ty2
478 = ASSERT(not (isSynTyCon tycon))
481 mkTyConTy :: TyCon -> Type
482 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
485 -- splitTyConApp "looks through" synonyms, because they don't
486 -- mean a distinct type, but all other type-constructor applications
487 -- including functions are returned as Just ..
489 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
490 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
491 splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
492 splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
493 splitTyConApp_maybe other = Nothing
495 -- splitAlgTyConApp_maybe looks for
496 -- *saturated* applications of *algebraic* data types
497 -- "Algebraic" => newtype, data type, or dictionary (not function types)
498 -- We return the constructors too.
500 splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon])
501 splitAlgTyConApp_maybe (TyConApp tc tys)
503 tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
504 splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
505 splitAlgTyConApp_maybe other = Nothing
507 splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon])
508 -- Here the "algebraic" property is an *assertion*
509 splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
510 (tc, tys, tyConDataCons tc)
511 splitAlgTyConApp (NoteTy _ ty) = splitAlgTyConApp ty
514 "Dictionary" types are just ordinary data types, but you can
515 tell from the type constructor whether it's a dictionary or not.
518 mkDictTy :: Class -> [Type] -> Type
519 mkDictTy clas tys = TyConApp (classTyCon clas) tys
521 splitDictTy_maybe :: Type -> Maybe (Class, [Type])
522 splitDictTy_maybe (TyConApp tc tys)
523 | maybeToBool maybe_class
524 && tyConArity tc == length tys = Just (clas, tys)
526 maybe_class = tyConClass_maybe tc
527 Just clas = maybe_class
529 splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty
530 splitDictTy_maybe other = Nothing
532 isDictTy :: Type -> Bool
533 -- This version is slightly more efficient than (maybeToBool . splitDictTy)
534 isDictTy (TyConApp tc tys)
535 | maybeToBool (tyConClass_maybe tc)
536 && tyConArity tc == length tys
538 isDictTy (NoteTy _ ty) = isDictTy ty
539 isDictTy other = False
542 ---------------------------------------------------------------------
547 mkSynTy syn_tycon tys
548 = ASSERT( isSynTyCon syn_tycon )
549 ASSERT( isNotUsgTy body )
550 ASSERT( length tyvars == length tys )
551 NoteTy (SynNote (TyConApp syn_tycon tys))
552 (substTy (mkTyVarSubst tyvars tys) body)
554 (tyvars, body) = getSynTyConDefn syn_tycon
556 isSynTy (NoteTy (SynNote _) _) = True
557 isSynTy other = False
559 deNoteType :: Type -> Type
560 -- Sorry for the cute name
561 deNoteType ty@(TyVarTy tyvar) = ty
562 deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
563 deNoteType (NoteTy _ ty) = deNoteType ty
564 deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg)
565 deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg)
566 deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty)
569 Notes on type synonyms
570 ~~~~~~~~~~~~~~~~~~~~~~
571 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
572 to return type synonyms whereever possible. Thus
577 splitFunTys (a -> Foo a) = ([a], Foo a)
580 The reason is that we then get better (shorter) type signatures in
581 interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
585 repType looks through
588 in addition to synonyms. It's useful in the back end where we're not
589 interested in newtypes anymore.
592 repType :: Type -> Type
593 repType (NoteTy _ ty) = repType ty
594 repType (ForAllTy _ ty) = repType ty
595 repType (TyConApp tc tys) | isNewTyCon tc = repType (new_type_rep tc tys)
596 repType other_ty = other_ty
598 splitNewType_maybe :: Type -> Maybe Type
599 -- Find the representation of a newtype, if it is one
600 -- Looks through multiple levels of newtype
601 splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty
602 splitNewType_maybe (TyConApp tc tys) | isNewTyCon tc = case splitNewType_maybe rep_ty of
603 Just rep_ty' -> Just rep_ty'
604 Nothing -> Just rep_ty
606 rep_ty = new_type_rep tc tys
608 splitNewType_maybe other = Nothing
610 new_type_rep :: TyCon -> [Type] -> Type
611 -- The representation type for (T t1 .. tn), where T is a newtype
612 -- Looks through one layer only
614 = ASSERT( isNewTyCon tc )
615 case splitFunTy_maybe (applyTys (dataConType (head (tyConDataCons tc))) tys) of
616 Just (rep_ty, _) -> rep_ty
621 ---------------------------------------------------------------------
625 NB: Invariant: if present, usage note is at the very top of the type.
626 This should be carefully preserved.
628 In some parts of the compiler, comments use the _Once Upon a
629 Polymorphic Type_ (POPL'99) usage of "sigma = usage-annotated type;
630 tau = un-usage-annotated type"; unfortunately this conflicts with the
631 rho/tau/theta/sigma usage in the rest of the compiler.
635 mkUsgTy :: UsageAnn -> Type -> Type
637 mkUsgTy UsMany ty = ASSERT2( isNotUsgTy ty, pprType ty )
640 mkUsgTy usg ty = ASSERT2( isNotUsgTy ty, pprType ty )
641 NoteTy (UsgNote usg) ty
643 -- The isUsgTy function is utterly useless if UsManys are omitted.
644 -- Be warned! KSW 1999-04.
645 isUsgTy :: Type -> Bool
649 isUsgTy (NoteTy (UsgNote _) _) = True
650 isUsgTy other = False
653 -- The isNotUsgTy function may return a false True if UsManys are omitted;
654 -- in other words, A SSERT( isNotUsgTy ty ) may be useful but
655 -- A SSERT( not (isNotUsg ty) ) is asking for trouble. KSW 1999-04.
656 isNotUsgTy :: Type -> Bool
657 isNotUsgTy (NoteTy (UsgNote _) _) = False
658 isNotUsgTy other = True
660 -- splitUsgTy_maybe is not exported, since it is meaningless if
661 -- UsManys are omitted. It is used in several places in this module,
662 -- however. KSW 1999-04.
663 splitUsgTy_maybe :: Type -> Maybe (UsageAnn,Type)
664 splitUsgTy_maybe (NoteTy (UsgNote usg) ty2) = ASSERT( isNotUsgTy ty2 )
666 splitUsgTy_maybe ty = Nothing
668 splitUsgTy :: Type -> (UsageAnn,Type)
669 splitUsgTy ty = case splitUsgTy_maybe ty of
675 pprPanic "splitUsgTy: no usage annot:" $ pprType ty
678 tyUsg :: Type -> UsageAnn
679 tyUsg = fst . splitUsgTy
681 unUsgTy :: Type -> Type
682 -- strip outer usage annotation if present
683 unUsgTy ty = case splitUsgTy_maybe ty of
684 Just (_,ty1) -> ASSERT2( isNotUsgTy ty1, pprType ty )
691 ---------------------------------------------------------------------
695 We need to be clever here with usage annotations; they need to be
696 lifted or lowered through the forall as appropriate.
699 mkForAllTy :: TyVar -> Type -> Type
700 mkForAllTy tyvar ty = case splitUsgTy_maybe ty of
701 Just (usg,ty') -> NoteTy (UsgNote usg)
703 Nothing -> ForAllTy tyvar ty
705 mkForAllTys :: [TyVar] -> Type -> Type
706 mkForAllTys tyvars ty = case splitUsgTy_maybe ty of
707 Just (usg,ty') -> NoteTy (UsgNote usg)
708 (foldr ForAllTy ty' tyvars)
709 Nothing -> foldr ForAllTy ty tyvars
711 splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
712 splitForAllTy_maybe ty = case splitUsgTy_maybe ty of
713 Just (usg,ty') -> do (tyvar,ty'') <- splitFAT_m ty'
714 return (tyvar, NoteTy (UsgNote usg) ty'')
715 Nothing -> splitFAT_m ty
717 splitFAT_m (NoteTy _ ty) = splitFAT_m ty
718 splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
719 splitFAT_m _ = Nothing
721 isForAllTy :: Type -> Bool
722 isForAllTy (NoteTy _ ty) = isForAllTy ty
723 isForAllTy (ForAllTy tyvar ty) = True
726 splitForAllTys :: Type -> ([TyVar], Type)
727 splitForAllTys ty = case splitUsgTy_maybe ty of
728 Just (usg,ty') -> let (tvs,ty'') = split ty' ty' []
729 in (tvs, NoteTy (UsgNote usg) ty'')
730 Nothing -> split ty ty []
732 split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
733 split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
734 split orig_ty t tvs = (reverse tvs, orig_ty)
737 @mkPiType@ makes a (->) type or a forall type, depending on whether
738 it is given a type variable or a term variable.
741 mkPiType :: IdOrTyVar -> Type -> Type -- The more polymorphic version doesn't work...
742 mkPiType v ty | isId v = mkFunTy (idType v) ty
743 | otherwise = mkForAllTy v ty
746 Applying a for-all to its arguments
749 applyTy :: Type -> Type -> Type
750 applyTy (NoteTy note@(UsgNote _) fun) arg = NoteTy note (applyTy fun arg)
751 applyTy (NoteTy _ fun) arg = applyTy fun arg
752 applyTy (ForAllTy tv ty) arg = ASSERT( isNotUsgTy arg )
753 substTy (mkTyVarSubst [tv] [arg]) ty
754 applyTy other arg = panic "applyTy"
756 applyTys :: Type -> [Type] -> Type
757 applyTys fun_ty arg_tys
758 = substTy (mkTyVarSubst tvs arg_tys) ty
760 (tvs, ty) = split fun_ty arg_tys
762 split fun_ty [] = ([], fun_ty)
763 split (NoteTy _ fun_ty) args = split fun_ty args
764 split (ForAllTy tv fun_ty) (arg:args) = ASSERT2( isNotUsgTy arg, vcat (map pprType arg_tys) $$
765 text "in application of" <+> pprType fun_ty)
766 case split fun_ty args of
767 (tvs, ty) -> (tv:tvs, ty)
768 split other_ty args = panic "applyTys"
770 {- OLD version with bogus usage stuff
772 ************* CHECK WITH KEITH **************
774 go env ty [] = substTy (mkVarEnv env) ty
775 go env (NoteTy note@(UsgNote _) fun)
776 args = NoteTy note (go env fun args)
777 go env (NoteTy _ fun) args = go env fun args
778 go env (ForAllTy tv ty) (arg:args) = go ((tv,arg):env) ty args
779 go env other args = panic "applyTys"
783 Note that we allow applications to be of usage-annotated- types, as an
784 extension: we handle them by lifting the annotation outside. The
785 argument, however, must still be unannotated.
787 %************************************************************************
789 \subsection{Stuff to do with the source-language types}
791 %************************************************************************
796 type ThetaType = [(Class, [Type])]
797 type SigmaType = Type
800 @isTauTy@ tests for nested for-alls.
803 isTauTy :: Type -> Bool
804 isTauTy (TyVarTy v) = True
805 isTauTy (TyConApp _ tys) = all isTauTy tys
806 isTauTy (AppTy a b) = isTauTy a && isTauTy b
807 isTauTy (FunTy a b) = isTauTy a && isTauTy b
808 isTauTy (NoteTy _ ty) = isTauTy ty
809 isTauTy other = False
813 mkRhoTy :: [(Class, [Type])] -> Type -> Type
814 mkRhoTy theta ty = foldr (\(c,t) r -> FunTy (mkDictTy c t) r) ty theta
816 splitRhoTy :: Type -> ([(Class, [Type])], Type)
817 splitRhoTy ty = split ty ty []
819 split orig_ty (FunTy arg res) ts = case splitDictTy_maybe arg of
820 Just pair -> split res res (pair:ts)
821 Nothing -> (reverse ts, orig_ty)
822 split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts
823 split orig_ty ty ts = (reverse ts, orig_ty)
829 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
831 splitSigmaTy :: Type -> ([TyVar], [(Class, [Type])], Type)
835 (tyvars,rho) = splitForAllTys ty
836 (theta,tau) = splitRhoTy rho
840 %************************************************************************
842 \subsection{Kinds and free variables}
844 %************************************************************************
846 ---------------------------------------------------------------------
847 Finding the kind of a type
848 ~~~~~~~~~~~~~~~~~~~~~~~~~~
850 typeKind :: Type -> Kind
852 typeKind (TyVarTy tyvar) = tyVarKind tyvar
853 typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
854 typeKind (NoteTy _ ty) = typeKind ty
855 typeKind (AppTy fun arg) = funResultTy (typeKind fun)
857 typeKind (FunTy arg res) = boxedTypeKind -- A function is boxed regardless of its result type
858 -- No functions at the type level, hence we don't need
859 -- to say (typeKind res).
861 typeKind (ForAllTy tv ty) = typeKind ty
865 ---------------------------------------------------------------------
866 Free variables of a type
867 ~~~~~~~~~~~~~~~~~~~~~~~~
869 tyVarsOfType :: Type -> TyVarSet
871 tyVarsOfType (TyVarTy tv) = unitVarSet tv
872 tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
873 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
874 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
875 tyVarsOfType (NoteTy (UsgNote _) ty) = tyVarsOfType ty
876 tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
877 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
878 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
880 tyVarsOfTypes :: [Type] -> TyVarSet
881 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
883 -- Add a Note with the free tyvars to the top of the type
884 -- (but under a usage if there is one)
885 addFreeTyVars :: Type -> Type
886 addFreeTyVars (NoteTy note@(UsgNote _) ty) = NoteTy note (addFreeTyVars ty)
887 addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
888 addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
890 -- Find the free names of a type, including the type constructors and classes it mentions
891 namesOfType :: Type -> NameSet
892 namesOfType (TyVarTy tv) = unitNameSet (getName tv)
893 namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets`
895 namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1
896 namesOfType (NoteTy other_note ty2) = namesOfType ty2
897 namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
898 namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
899 namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
901 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
905 %************************************************************************
907 \subsection{TidyType}
909 %************************************************************************
911 tidyTy tidies up a type for printing in an error message, or in
914 It doesn't change the uniques at all, just the print names.
917 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
918 tidyTyVar env@(tidy_env, subst) tyvar
919 = case lookupVarEnv subst tyvar of
921 Just tyvar' -> -- Already substituted
924 Nothing -> -- Make a new nice name for it
926 case tidyOccName tidy_env (getOccName name) of
927 (tidy', occ') -> -- New occname reqd
928 ((tidy', subst'), tyvar')
930 subst' = extendVarEnv subst tyvar tyvar'
931 tyvar' = setTyVarName tyvar name'
932 name' = mkLocalName (getUnique name) occ' noSrcLoc
933 -- Note: make a *user* tyvar, so it printes nicely
934 -- Could extract src loc, but no need.
936 name = tyVarName tyvar
938 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
940 tidyType :: TidyEnv -> Type -> Type
941 tidyType env@(tidy_env, subst) ty
944 go (TyVarTy tv) = case lookupVarEnv subst tv of
945 Nothing -> TyVarTy tv
946 Just tv' -> TyVarTy tv'
947 go (TyConApp tycon tys) = let args = map go tys
948 in args `seqList` TyConApp tycon args
949 go (NoteTy note ty) = (NoteTy $! (go_note note)) $! (go ty)
950 go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg)
951 go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg)
952 go (ForAllTy tv ty) = ForAllTy tv' $! (tidyType env' ty)
954 (env', tv') = tidyTyVar env tv
956 go_note (SynNote ty) = SynNote $! (go ty)
957 go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
958 go_note note@(UsgNote _) = note -- Usage annotation is already tidy
960 tidyTypes env tys = map (tidyType env) tys
964 @tidyOpenType@ grabs the free type varibles, tidies them
965 and then uses @tidyType@ to work over the type itself
968 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
970 = (env', tidyType env' ty)
972 env' = foldl go env (varSetElems (tyVarsOfType ty))
973 go env tyvar = fst (tidyTyVar env tyvar)
975 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
976 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
978 tidyTopType :: Type -> Type
979 tidyTopType ty = tidyType emptyTidyEnv ty
983 %************************************************************************
985 \subsection{Boxedness and liftedness}
987 %************************************************************************
990 isUnboxedType :: Type -> Bool
991 isUnboxedType ty = not (isFollowableRep (typePrimRep ty))
993 isUnLiftedType :: Type -> Bool
994 isUnLiftedType ty = case splitTyConApp_maybe ty of
995 Just (tc, ty_args) -> isUnLiftedTyCon tc
998 isUnboxedTupleType :: Type -> Bool
999 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
1000 Just (tc, ty_args) -> isUnboxedTupleTyCon tc
1003 -- Should only be applied to *types*; hence the assert
1004 isAlgType :: Type -> Bool
1005 isAlgType ty = case splitTyConApp_maybe ty of
1006 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1010 -- Should only be applied to *types*; hence the assert
1011 isDataType :: Type -> Bool
1012 isDataType ty = case splitTyConApp_maybe ty of
1013 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1017 isNewType :: Type -> Bool
1018 isNewType ty = case splitTyConApp_maybe ty of
1019 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1023 typePrimRep :: Type -> PrimRep
1024 typePrimRep ty = case splitTyConApp_maybe ty of
1025 Just (tc, ty_args) -> tyConPrimRep tc
1029 %************************************************************************
1031 \subsection{Equality on types}
1033 %************************************************************************
1035 For the moment at least, type comparisons don't work if
1036 there are embedded for-alls.
1039 instance Eq Type where
1040 ty1 == ty2 = case ty1 `cmpTy` ty2 of { EQ -> True; other -> False }
1042 instance Ord Type where
1043 compare ty1 ty2 = cmpTy ty1 ty2
1045 cmpTy :: Type -> Type -> Ordering
1047 = cmp emptyVarEnv ty1 ty2
1049 -- The "env" maps type variables in ty1 to type variables in ty2
1050 -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
1051 -- we in effect substitute tv2 for tv1 in t1 before continuing
1052 lookup env tv1 = case lookupVarEnv env tv1 of
1056 -- Get rid of NoteTy
1057 cmp env (NoteTy _ ty1) ty2 = cmp env ty1 ty2
1058 cmp env ty1 (NoteTy _ ty2) = cmp env ty1 ty2
1060 -- Deal with equal constructors
1061 cmp env (TyVarTy tv1) (TyVarTy tv2) = lookup env tv1 `compare` tv2
1062 cmp env (AppTy f1 a1) (AppTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
1063 cmp env (FunTy f1 a1) (FunTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
1064 cmp env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmps env tys1 tys2)
1065 cmp env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmp (extendVarEnv env tv1 tv2) t1 t2
1067 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
1068 cmp env (AppTy _ _) (TyVarTy _) = GT
1070 cmp env (FunTy _ _) (TyVarTy _) = GT
1071 cmp env (FunTy _ _) (AppTy _ _) = GT
1073 cmp env (TyConApp _ _) (TyVarTy _) = GT
1074 cmp env (TyConApp _ _) (AppTy _ _) = GT
1075 cmp env (TyConApp _ _) (FunTy _ _) = GT
1077 cmp env (ForAllTy _ _) other = GT
1082 cmps env (t:ts) [] = GT
1083 cmps env [] (t:ts) = LT
1084 cmps env (t1:t1s) (t2:t2s) = cmp env t1 t2 `thenCmp` cmps env t1s t2s
1088 %************************************************************************
1090 \subsection{Sequencing on types
1092 %************************************************************************
1095 seqType :: Type -> ()
1096 seqType (TyVarTy tv) = tv `seq` ()
1097 seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
1098 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
1099 seqType (NoteTy note t2) = seqNote note `seq` seqType t2
1100 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
1101 seqType (ForAllTy tv ty) = tv `seq` seqType ty
1103 seqTypes :: [Type] -> ()
1105 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
1107 seqNote :: TyNote -> ()
1108 seqNote (SynNote ty) = seqType ty
1109 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
1110 seqNote (UsgNote usg) = usg `seq` ()