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, funResultTy,
31 mkTyConApp, mkTyConTy, splitTyConApp_maybe,
32 splitAlgTyConApp_maybe, splitAlgTyConApp,
33 mkDictTy, splitDictTy_maybe, isDictTy,
35 mkSynTy, isSynTy, deNoteType, repType,
37 mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg,
39 mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
40 isForAllTy, applyTy, applyTys, mkPiType,
42 TauType, RhoType, SigmaType, ThetaType,
45 mkSigmaTy, splitSigmaTy,
48 isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType,
52 tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind,
55 -- Tidying up for printing
57 tidyOpenType, tidyOpenTypes,
58 tidyTyVar, tidyTyVars,
62 #include "HsVersions.h"
64 import {-# SOURCE #-} DataCon( DataCon, dataConType )
65 import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
66 import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy )
69 import Var ( Id, TyVar, IdOrTyVar, UVar,
70 tyVarKind, tyVarName, isId, idType, setTyVarName, setVarOcc
75 import Name ( NamedThing(..), Provenance(..), ExportFlag(..),
76 mkWiredInTyConName, mkGlobalName, mkLocalName, mkKindOccFS, tcName,
77 tidyOccName, TidyOccEnv
80 import Class ( classTyCon, Class )
81 import TyCon ( TyCon, KindCon,
82 mkFunTyCon, mkKindCon, mkSuperKindCon,
83 matchesTyCon, isUnboxedTupleTyCon, isUnLiftedTyCon,
84 isFunTyCon, isDataTyCon, isNewTyCon,
85 isAlgTyCon, isSynTyCon, tyConArity,
86 tyConKind, tyConDataCons, getSynTyConDefn,
87 tyConPrimRep, tyConClass_maybe
91 import BasicTypes ( Unused )
92 import SrcLoc ( mkBuiltinSrcLoc, noSrcLoc )
93 import PrelMods ( pREL_GHC )
94 import Maybes ( maybeToBool )
95 import PrimRep ( PrimRep(..), isFollowableRep )
96 import Unique -- quite a few *Keys
97 import Util ( thenCmp, mapAccumL, seqList, ($!) )
102 %************************************************************************
104 \subsection{Type Classifications}
106 %************************************************************************
110 *unboxed* iff its representation is other than a pointer
111 Unboxed types cannot instantiate a type variable.
112 Unboxed types are always unlifted.
114 *lifted* A type is lifted iff it has bottom as an element.
115 Closures always have lifted types: i.e. any
116 let-bound identifier in Core must have a lifted
117 type. Operationally, a lifted object is one that
119 (NOTE: previously "pointed").
121 *algebraic* A type with one or more constructors, whether declared
122 with "data" or "newtype".
123 An algebraic type is one that can be deconstructed
124 with a case expression.
125 *NOT* the same as lifted types, because we also
126 include unboxed tuples in this classification.
128 *data* A type declared with "data". Also boxed tuples.
130 *primitive* iff it is a built-in type that can't be expressed
133 Currently, all primitive types are unlifted, but that's not necessarily
134 the case. (E.g. Int could be primitive.)
136 Some primitive types are unboxed, such as Int#, whereas some are boxed
137 but unlifted (such as ByteArray#). The only primitive types that we
138 classify as algebraic are the unboxed tuples.
140 examples of type classifications:
142 Type primitive boxed lifted algebraic
143 -----------------------------------------------------------------------------
145 ByteArray# Yes Yes No No
146 (# a, b #) Yes No No Yes
147 ( a, b ) No Yes Yes Yes
150 %************************************************************************
152 \subsection{The data type}
154 %************************************************************************
158 type SuperKind = Type
161 type TyVarSubst = TyVarEnv Type
167 Type -- Function is *not* a TyConApp
170 | TyConApp -- Application of a TyCon
171 TyCon -- *Invariant* saturated appliations of FunTyCon and
172 -- synonyms have their own constructors, below.
173 [Type] -- Might not be saturated.
175 | FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2]
179 | NoteTy -- Saturated application of a type synonym
181 Type -- The expanded version
188 = SynNote Type -- The unexpanded version of the type synonym; always a TyConApp
189 | FTVNote TyVarSet -- The free type variables of the noted expression
190 | UsgNote UsageAnn -- The usage annotation at this node
193 = UsOnce -- Used at most once
194 | UsMany -- Used possibly many times (no info; this annotation can be omitted)
195 | UsVar UVar -- Annotation is variable (should only happen inside analysis)
199 %************************************************************************
203 %************************************************************************
211 kv :: KX is a kind variable
217 | AnyBox -- Used *only* for special built-in things
218 -- like error :: forall (a::*?). String -> a
219 -- Here, the 'a' can be instantiated to a boxed or
223 bxv :: BX is a boxity variable
227 | sk -> sk -- In ptic (BX -> KX)
230 mk_kind_name key str = mkGlobalName key pREL_GHC (mkKindOccFS tcName str)
231 (LocalDef mkBuiltinSrcLoc NotExported)
232 -- mk_kind_name is a bit of a hack
233 -- The LocalDef means that we print the name without
234 -- a qualifier, which is what we want for these kinds.
235 -- It's used for both Kinds and Boxities
241 superKind :: SuperKind -- KX, the type of all kinds
242 superKindName = mk_kind_name kindConKey SLIT("KX")
243 superKind = TyConApp (mkSuperKindCon superKindName) []
245 superBoxity :: SuperKind -- BX, the type of all boxities
246 superBoxityName = mk_kind_name boxityConKey SLIT("BX")
247 superBoxity = TyConApp (mkSuperKindCon superBoxityName) []
250 Define Boxed, Unboxed, AnyBox
253 boxedKind, unboxedKind, anyBoxKind :: Kind -- Of superkind superBoxity
255 boxedConName = mk_kind_name boxedConKey SLIT("*")
256 boxedKind = TyConApp (mkKindCon boxedConName superBoxity) []
258 unboxedConName = mk_kind_name unboxedConKey SLIT("#")
259 unboxedKind = TyConApp (mkKindCon unboxedConName superBoxity) []
261 anyBoxConName = mk_kind_name anyBoxConKey SLIT("?")
262 anyBoxCon = mkKindCon anyBoxConName superBoxity -- A kind of wild card
263 anyBoxKind = TyConApp anyBoxCon []
270 typeConName = mk_kind_name typeConKey SLIT("Type")
271 typeCon = mkKindCon typeConName (superBoxity `FunTy` superKind)
274 Define (Type Boxed), (Type Unboxed), (Type AnyBox)
277 boxedTypeKind, unboxedTypeKind, openTypeKind :: Kind
278 boxedTypeKind = TyConApp typeCon [boxedKind]
279 unboxedTypeKind = TyConApp typeCon [unboxedKind]
280 openTypeKind = TyConApp typeCon [anyBoxKind]
282 mkArrowKind :: Kind -> Kind -> Kind
283 mkArrowKind k1 k2 = k1 `FunTy` k2
285 mkArrowKinds :: [Kind] -> Kind -> Kind
286 mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
290 hasMoreBoxityInfo :: Kind -> Kind -> Bool
291 hasMoreBoxityInfo k1 k2
292 | k2 == openTypeKind = ASSERT( is_type_kind k1) True
293 | otherwise = k1 == k2
295 -- Returns true for things of form (Type x)
296 is_type_kind k = case splitTyConApp_maybe k of
297 Just (tc,[_]) -> tc == typeCon
302 %************************************************************************
304 \subsection{Wired-in type constructors
306 %************************************************************************
308 We define a few wired-in type constructors here to avoid module knots
311 funTyConName = mkWiredInTyConName funTyConKey pREL_GHC SLIT("(->)") funTyCon
312 funTyCon = mkFunTyCon funTyConName (mkArrowKinds [boxedTypeKind, boxedTypeKind] boxedTypeKind)
317 %************************************************************************
319 \subsection{Constructor-specific functions}
321 %************************************************************************
324 ---------------------------------------------------------------------
328 mkTyVarTy :: TyVar -> Type
331 mkTyVarTys :: [TyVar] -> [Type]
332 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
334 getTyVar :: String -> Type -> TyVar
335 getTyVar msg (TyVarTy tv) = tv
336 getTyVar msg (NoteTy _ t) = getTyVar msg t
337 getTyVar msg other = panic ("getTyVar: " ++ msg)
339 getTyVar_maybe :: Type -> Maybe TyVar
340 getTyVar_maybe (TyVarTy tv) = Just tv
341 getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
342 getTyVar_maybe other = Nothing
344 isTyVarTy :: Type -> Bool
345 isTyVarTy (TyVarTy tv) = True
346 isTyVarTy (NoteTy _ ty) = isTyVarTy ty
347 isTyVarTy other = False
351 ---------------------------------------------------------------------
354 We need to be pretty careful with AppTy to make sure we obey the
355 invariant that a TyConApp is always visibly so. mkAppTy maintains the
359 mkAppTy orig_ty1 orig_ty2 = ASSERT2( isNotUsgTy orig_ty1 && isNotUsgTy orig_ty2, pprType orig_ty1 <+> text "to" <+> pprType orig_ty2 )
362 mk_app (NoteTy _ ty1) = mk_app ty1
363 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
364 mk_app ty1 = AppTy orig_ty1 orig_ty2
366 mkAppTys :: Type -> [Type] -> Type
367 mkAppTys orig_ty1 [] = orig_ty1
368 -- This check for an empty list of type arguments
369 -- avoids the needless of a type synonym constructor.
370 -- For example: mkAppTys Rational []
371 -- returns to (Ratio Integer), which has needlessly lost
372 -- the Rational part.
373 mkAppTys orig_ty1 orig_tys2 = ASSERT2( isNotUsgTy orig_ty1, pprType orig_ty1 )
376 mk_app (NoteTy _ ty1) = mk_app ty1
377 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
378 mk_app ty1 = ASSERT2( all isNotUsgTy orig_tys2, pprType orig_ty1 <+> text "to" <+> hsep (map pprType orig_tys2) )
379 foldl AppTy orig_ty1 orig_tys2
381 splitAppTy_maybe :: Type -> Maybe (Type, Type)
382 splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
383 splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
384 splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty
385 splitAppTy_maybe (TyConApp tc []) = Nothing
386 splitAppTy_maybe (TyConApp tc tys) = split tys []
388 split [ty2] acc = Just (TyConApp tc (reverse acc), ty2)
389 split (ty:tys) acc = split tys (ty:acc)
391 splitAppTy_maybe other = Nothing
393 splitAppTy :: Type -> (Type, Type)
394 splitAppTy ty = case splitAppTy_maybe ty of
396 Nothing -> panic "splitAppTy"
398 splitAppTys :: Type -> (Type, [Type])
399 splitAppTys ty = split ty ty []
401 split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
402 split orig_ty (NoteTy _ ty) args = split orig_ty ty args
403 split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
404 (TyConApp funTyCon [], [ty1,ty2])
405 split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
406 split orig_ty ty args = (orig_ty, args)
410 ---------------------------------------------------------------------
415 mkFunTy :: Type -> Type -> Type
416 mkFunTy arg res = FunTy arg res
418 mkFunTys :: [Type] -> Type -> Type
419 mkFunTys tys ty = foldr FunTy ty tys
421 splitFunTy_maybe :: Type -> Maybe (Type, Type)
422 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
423 splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
424 splitFunTy_maybe other = Nothing
426 splitFunTys :: Type -> ([Type], Type)
427 splitFunTys ty = split [] ty ty
429 split args orig_ty (FunTy arg res) = split (arg:args) res res
430 split args orig_ty (NoteTy _ ty) = split args orig_ty ty
431 split args orig_ty ty = (reverse args, orig_ty)
433 splitFunTysN :: String -> Int -> Type -> ([Type], Type)
434 splitFunTysN msg orig_n orig_ty = split orig_n [] orig_ty orig_ty
436 split 0 args syn_ty ty = (reverse args, syn_ty)
437 split n args syn_ty (FunTy arg res) = split (n-1) (arg:args) res res
438 split n args syn_ty (NoteTy _ ty) = split n args syn_ty ty
439 split n args syn_ty ty = pprPanic ("splitFunTysN: " ++ msg) (int orig_n <+> pprType orig_ty)
441 zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
442 zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
444 split acc [] nty ty = (reverse acc, nty)
445 split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
446 split acc xs nty (NoteTy _ ty) = split acc xs nty ty
447 split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty)
449 funResultTy :: Type -> Type
450 funResultTy (FunTy arg res) = res
451 funResultTy (NoteTy _ ty) = funResultTy ty
452 funResultTy ty = pprPanic "funResultTy" (pprType ty)
456 ---------------------------------------------------------------------
461 mkTyConApp :: TyCon -> [Type] -> Type
463 | isFunTyCon tycon && length tys == 2
465 (ty1:ty2:_) -> FunTy ty1 ty2
468 = ASSERT(not (isSynTyCon tycon))
471 mkTyConTy :: TyCon -> Type
472 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
475 -- splitTyConApp "looks through" synonyms, because they don't
476 -- mean a distinct type, but all other type-constructor applications
477 -- including functions are returned as Just ..
479 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
480 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
481 splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
482 splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
483 splitTyConApp_maybe other = Nothing
485 -- splitAlgTyConApp_maybe looks for
486 -- *saturated* applications of *algebraic* data types
487 -- "Algebraic" => newtype, data type, or dictionary (not function types)
488 -- We return the constructors too.
490 splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon])
491 splitAlgTyConApp_maybe (TyConApp tc tys)
493 tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
494 splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
495 splitAlgTyConApp_maybe other = Nothing
497 splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon])
498 -- Here the "algebraic" property is an *assertion*
499 splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
500 (tc, tys, tyConDataCons tc)
501 splitAlgTyConApp (NoteTy _ ty) = splitAlgTyConApp ty
504 "Dictionary" types are just ordinary data types, but you can
505 tell from the type constructor whether it's a dictionary or not.
508 mkDictTy :: Class -> [Type] -> Type
509 mkDictTy clas tys = TyConApp (classTyCon clas) tys
511 splitDictTy_maybe :: Type -> Maybe (Class, [Type])
512 splitDictTy_maybe (TyConApp tc tys)
513 | maybeToBool maybe_class
514 && tyConArity tc == length tys = Just (clas, tys)
516 maybe_class = tyConClass_maybe tc
517 Just clas = maybe_class
519 splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty
520 splitDictTy_maybe other = Nothing
522 isDictTy :: Type -> Bool
523 -- This version is slightly more efficient than (maybeToBool . splitDictTy)
524 isDictTy (TyConApp tc tys)
525 | maybeToBool (tyConClass_maybe tc)
526 && tyConArity tc == length tys
528 isDictTy (NoteTy _ ty) = isDictTy ty
529 isDictTy other = False
532 ---------------------------------------------------------------------
537 mkSynTy syn_tycon tys
538 = ASSERT( isSynTyCon syn_tycon )
539 ASSERT( isNotUsgTy body )
540 NoteTy (SynNote (TyConApp syn_tycon tys))
541 (substTy (mkTyVarSubst tyvars tys) body)
543 (tyvars, body) = getSynTyConDefn syn_tycon
545 isSynTy (NoteTy (SynNote _) _) = True
546 isSynTy other = False
548 deNoteType :: Type -> Type
549 -- Sorry for the cute name
550 deNoteType ty@(TyVarTy tyvar) = ty
551 deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
552 deNoteType (NoteTy _ ty) = deNoteType ty
553 deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg)
554 deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg)
555 deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty)
558 Notes on type synonyms
559 ~~~~~~~~~~~~~~~~~~~~~~
560 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
561 to return type synonyms whereever possible. Thus
566 splitFunTys (a -> Foo a) = ([a], Foo a)
569 The reason is that we then get better (shorter) type signatures in
570 interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
574 repType looks through
577 in addition to synonyms. It's useful in the back end where we're not
578 interested in newtypes anymore.
581 repType :: Type -> Type
582 repType (NoteTy _ ty) = repType ty
583 repType (ForAllTy _ ty) = repType ty
584 repType (TyConApp tc tys) | isNewTyCon tc
585 = case splitFunTy_maybe (applyTys (dataConType (head (tyConDataCons tc))) tys) of
586 Just (rep_ty, _) -> repType rep_ty
587 repType other_ty = other_ty
592 ---------------------------------------------------------------------
596 NB: Invariant: if present, usage note is at the very top of the type.
597 This should be carefully preserved.
599 In some parts of the compiler, comments use the _Once Upon a
600 Polymorphic Type_ (POPL'99) usage of "sigma = usage-annotated type;
601 tau = un-usage-annotated type"; unfortunately this conflicts with the
602 rho/tau/theta/sigma usage in the rest of the compiler.
606 mkUsgTy :: UsageAnn -> Type -> Type
608 mkUsgTy UsMany ty = ASSERT2( isNotUsgTy ty, pprType ty )
611 mkUsgTy usg ty = ASSERT2( isNotUsgTy ty, pprType ty )
612 NoteTy (UsgNote usg) ty
614 -- The isUsgTy function is utterly useless if UsManys are omitted.
615 -- Be warned! KSW 1999-04.
616 isUsgTy :: Type -> Bool
620 isUsgTy (NoteTy (UsgNote _) _) = True
621 isUsgTy other = False
624 -- The isNotUsgTy function may return a false True if UsManys are omitted;
625 -- in other words, A SSERT( isNotUsgTy ty ) may be useful but
626 -- A SSERT( not (isNotUsg ty) ) is asking for trouble. KSW 1999-04.
627 isNotUsgTy :: Type -> Bool
628 isNotUsgTy (NoteTy (UsgNote _) _) = False
629 isNotUsgTy other = True
631 -- splitUsgTy_maybe is not exported, since it is meaningless if
632 -- UsManys are omitted. It is used in several places in this module,
633 -- however. KSW 1999-04.
634 splitUsgTy_maybe :: Type -> Maybe (UsageAnn,Type)
635 splitUsgTy_maybe (NoteTy (UsgNote usg) ty2) = ASSERT( isNotUsgTy ty2 )
637 splitUsgTy_maybe ty = Nothing
639 splitUsgTy :: Type -> (UsageAnn,Type)
640 splitUsgTy ty = case splitUsgTy_maybe ty of
646 pprPanic "splitUsgTy: no usage annot:" $ pprType ty
649 tyUsg :: Type -> UsageAnn
650 tyUsg = fst . splitUsgTy
652 unUsgTy :: Type -> Type
653 -- strip outer usage annotation if present
654 unUsgTy ty = case splitUsgTy_maybe ty of
655 Just (_,ty1) -> ASSERT2( isNotUsgTy ty1, pprType ty )
662 ---------------------------------------------------------------------
666 We need to be clever here with usage annotations; they need to be
667 lifted or lowered through the forall as appropriate.
670 mkForAllTy :: TyVar -> Type -> Type
671 mkForAllTy tyvar ty = case splitUsgTy_maybe ty of
672 Just (usg,ty') -> NoteTy (UsgNote usg)
674 Nothing -> ForAllTy tyvar ty
676 mkForAllTys :: [TyVar] -> Type -> Type
677 mkForAllTys tyvars ty = case splitUsgTy_maybe ty of
678 Just (usg,ty') -> NoteTy (UsgNote usg)
679 (foldr ForAllTy ty' tyvars)
680 Nothing -> foldr ForAllTy ty tyvars
682 splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
683 splitForAllTy_maybe ty = case splitUsgTy_maybe ty of
684 Just (usg,ty') -> do (tyvar,ty'') <- splitFAT_m ty'
685 return (tyvar, NoteTy (UsgNote usg) ty'')
686 Nothing -> splitFAT_m ty
688 splitFAT_m (NoteTy _ ty) = splitFAT_m ty
689 splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
690 splitFAT_m _ = Nothing
692 isForAllTy :: Type -> Bool
693 isForAllTy (NoteTy _ ty) = isForAllTy ty
694 isForAllTy (ForAllTy tyvar ty) = True
697 splitForAllTys :: Type -> ([TyVar], Type)
698 splitForAllTys ty = case splitUsgTy_maybe ty of
699 Just (usg,ty') -> let (tvs,ty'') = split ty' ty' []
700 in (tvs, NoteTy (UsgNote usg) ty'')
701 Nothing -> split ty ty []
703 split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
704 split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
705 split orig_ty t tvs = (reverse tvs, orig_ty)
708 @mkPiType@ makes a (->) type or a forall type, depending on whether
709 it is given a type variable or a term variable.
712 mkPiType :: IdOrTyVar -> Type -> Type -- The more polymorphic version doesn't work...
713 mkPiType v ty | isId v = mkFunTy (idType v) ty
714 | otherwise = mkForAllTy v ty
717 Applying a for-all to its arguments
720 applyTy :: Type -> Type -> Type
721 applyTy (NoteTy note@(UsgNote _) fun) arg = NoteTy note (applyTy fun arg)
722 applyTy (NoteTy _ fun) arg = applyTy fun arg
723 applyTy (ForAllTy tv ty) arg = ASSERT( isNotUsgTy arg )
724 substTy (mkTyVarSubst [tv] [arg]) ty
725 applyTy other arg = panic "applyTy"
727 applyTys :: Type -> [Type] -> Type
728 applyTys fun_ty arg_tys
729 = substTy (mkTyVarSubst tvs arg_tys) ty
731 (tvs, ty) = split fun_ty arg_tys
733 split fun_ty [] = ([], fun_ty)
734 split (NoteTy _ fun_ty) args = split fun_ty args
735 split (ForAllTy tv fun_ty) (arg:args) = ASSERT2( isNotUsgTy arg, vcat (map pprType arg_tys) $$
736 text "in application of" <+> pprType fun_ty)
737 case split fun_ty args of
738 (tvs, ty) -> (tv:tvs, ty)
739 split other_ty args = panic "applyTys"
741 {- OLD version with bogus usage stuff
743 ************* CHECK WITH KEITH **************
745 go env ty [] = substTy (mkVarEnv env) ty
746 go env (NoteTy note@(UsgNote _) fun)
747 args = NoteTy note (go env fun args)
748 go env (NoteTy _ fun) args = go env fun args
749 go env (ForAllTy tv ty) (arg:args) = go ((tv,arg):env) ty args
750 go env other args = panic "applyTys"
754 Note that we allow applications to be of usage-annotated- types, as an
755 extension: we handle them by lifting the annotation outside. The
756 argument, however, must still be unannotated.
758 %************************************************************************
760 \subsection{Stuff to do with the source-language types}
762 %************************************************************************
767 type ThetaType = [(Class, [Type])]
768 type SigmaType = Type
771 @isTauTy@ tests for nested for-alls.
774 isTauTy :: Type -> Bool
775 isTauTy (TyVarTy v) = True
776 isTauTy (TyConApp _ tys) = all isTauTy tys
777 isTauTy (AppTy a b) = isTauTy a && isTauTy b
778 isTauTy (FunTy a b) = isTauTy a && isTauTy b
779 isTauTy (NoteTy _ ty) = isTauTy ty
780 isTauTy other = False
784 mkRhoTy :: [(Class, [Type])] -> Type -> Type
785 mkRhoTy theta ty = foldr (\(c,t) r -> FunTy (mkDictTy c t) r) ty theta
787 splitRhoTy :: Type -> ([(Class, [Type])], Type)
788 splitRhoTy ty = split ty ty []
790 split orig_ty (FunTy arg res) ts = case splitDictTy_maybe arg of
791 Just pair -> split res res (pair:ts)
792 Nothing -> (reverse ts, orig_ty)
793 split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts
794 split orig_ty ty ts = (reverse ts, orig_ty)
800 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
802 splitSigmaTy :: Type -> ([TyVar], [(Class, [Type])], Type)
806 (tyvars,rho) = splitForAllTys ty
807 (theta,tau) = splitRhoTy rho
811 %************************************************************************
813 \subsection{Kinds and free variables}
815 %************************************************************************
817 ---------------------------------------------------------------------
818 Finding the kind of a type
819 ~~~~~~~~~~~~~~~~~~~~~~~~~~
821 typeKind :: Type -> Kind
823 typeKind (TyVarTy tyvar) = tyVarKind tyvar
824 typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
825 typeKind (NoteTy _ ty) = typeKind ty
826 typeKind (AppTy fun arg) = funResultTy (typeKind fun)
828 typeKind (FunTy arg res) = boxedTypeKind -- A function is boxed regardless of its result type
829 -- No functions at the type level, hence we don't need
830 -- to say (typeKind res).
832 typeKind (ForAllTy tv ty) = typeKind ty
836 ---------------------------------------------------------------------
837 Free variables of a type
838 ~~~~~~~~~~~~~~~~~~~~~~~~
840 tyVarsOfType :: Type -> TyVarSet
842 tyVarsOfType (TyVarTy tv) = unitVarSet tv
843 tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
844 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
845 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
846 tyVarsOfType (NoteTy (UsgNote _) ty) = tyVarsOfType ty
847 tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
848 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
849 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
851 tyVarsOfTypes :: [Type] -> TyVarSet
852 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
854 -- Add a Note with the free tyvars to the top of the type
855 -- (but under a usage if there is one)
856 addFreeTyVars :: Type -> Type
857 addFreeTyVars (NoteTy note@(UsgNote _) ty) = NoteTy note (addFreeTyVars ty)
858 addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
859 addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
861 -- Find the free names of a type, including the type constructors and classes it mentions
862 namesOfType :: Type -> NameSet
863 namesOfType (TyVarTy tv) = unitNameSet (getName tv)
864 namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets`
866 namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1
867 namesOfType (NoteTy other_note ty2) = namesOfType ty2
868 namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
869 namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
870 namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
872 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
876 %************************************************************************
878 \subsection{TidyType}
880 %************************************************************************
882 tidyTy tidies up a type for printing in an error message, or in
885 It doesn't change the uniques at all, just the print names.
888 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
889 tidyTyVar env@(tidy_env, subst) tyvar
890 = case lookupVarEnv subst tyvar of
892 Just tyvar' -> -- Already substituted
895 Nothing -> -- Make a new nice name for it
897 case tidyOccName tidy_env (getOccName name) of
898 (tidy', occ') -> -- New occname reqd
899 ((tidy', subst'), tyvar')
901 subst' = extendVarEnv subst tyvar tyvar'
902 tyvar' = setTyVarName tyvar name'
903 name' = mkLocalName (getUnique name) occ' noSrcLoc
904 -- Note: make a *user* tyvar, so it printes nicely
905 -- Could extract src loc, but no need.
907 name = tyVarName tyvar
909 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
911 tidyType :: TidyEnv -> Type -> Type
912 tidyType env@(tidy_env, subst) ty
915 go (TyVarTy tv) = case lookupVarEnv subst tv of
916 Nothing -> TyVarTy tv
917 Just tv' -> TyVarTy tv'
918 go (TyConApp tycon tys) = let args = map go tys
919 in args `seqList` TyConApp tycon args
920 go (NoteTy note ty) = (NoteTy $! (go_note note)) $! (go ty)
921 go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg)
922 go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg)
923 go (ForAllTy tv ty) = ForAllTy tv' $! (tidyType env' ty)
925 (env', tv') = tidyTyVar env tv
927 go_note (SynNote ty) = SynNote $! (go ty)
928 go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
929 go_note note@(UsgNote _) = note -- Usage annotation is already tidy
931 tidyTypes env tys = map (tidyType env) tys
935 @tidyOpenType@ grabs the free type varibles, tidies them
936 and then uses @tidyType@ to work over the type itself
939 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
941 = (env', tidyType env' ty)
943 env' = foldl go env (varSetElems (tyVarsOfType ty))
944 go env tyvar = fst (tidyTyVar env tyvar)
946 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
947 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
949 tidyTopType :: Type -> Type
950 tidyTopType ty = tidyType emptyTidyEnv ty
954 %************************************************************************
956 \subsection{Boxedness and liftedness}
958 %************************************************************************
961 isUnboxedType :: Type -> Bool
962 isUnboxedType ty = not (isFollowableRep (typePrimRep ty))
964 isUnLiftedType :: Type -> Bool
965 isUnLiftedType ty = case splitTyConApp_maybe ty of
966 Just (tc, ty_args) -> isUnLiftedTyCon tc
969 isUnboxedTupleType :: Type -> Bool
970 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
971 Just (tc, ty_args) -> isUnboxedTupleTyCon tc
974 -- Should only be applied to *types*; hence the assert
975 isAlgType :: Type -> Bool
976 isAlgType ty = case splitTyConApp_maybe ty of
977 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
981 -- Should only be applied to *types*; hence the assert
982 isDataType :: Type -> Bool
983 isDataType ty = case splitTyConApp_maybe ty of
984 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
988 typePrimRep :: Type -> PrimRep
989 typePrimRep ty = case splitTyConApp_maybe ty of
990 Just (tc, ty_args) -> tyConPrimRep tc
994 %************************************************************************
996 \subsection{Equality on types}
998 %************************************************************************
1000 For the moment at least, type comparisons don't work if
1001 there are embedded for-alls.
1004 instance Eq Type where
1005 ty1 == ty2 = case ty1 `cmpTy` ty2 of { EQ -> True; other -> False }
1007 instance Ord Type where
1008 compare ty1 ty2 = cmpTy ty1 ty2
1010 cmpTy :: Type -> Type -> Ordering
1012 = cmp emptyVarEnv ty1 ty2
1014 -- The "env" maps type variables in ty1 to type variables in ty2
1015 -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
1016 -- we in effect substitute tv2 for tv1 in t1 before continuing
1017 lookup env tv1 = case lookupVarEnv env tv1 of
1021 -- Get rid of NoteTy
1022 cmp env (NoteTy _ ty1) ty2 = cmp env ty1 ty2
1023 cmp env ty1 (NoteTy _ ty2) = cmp env ty1 ty2
1025 -- Deal with equal constructors
1026 cmp env (TyVarTy tv1) (TyVarTy tv2) = lookup env tv1 `compare` tv2
1027 cmp env (AppTy f1 a1) (AppTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
1028 cmp env (FunTy f1 a1) (FunTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
1029 cmp env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmps env tys1 tys2)
1030 cmp env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmp (extendVarEnv env tv1 tv2) t1 t2
1032 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
1033 cmp env (AppTy _ _) (TyVarTy _) = GT
1035 cmp env (FunTy _ _) (TyVarTy _) = GT
1036 cmp env (FunTy _ _) (AppTy _ _) = GT
1038 cmp env (TyConApp _ _) (TyVarTy _) = GT
1039 cmp env (TyConApp _ _) (AppTy _ _) = GT
1040 cmp env (TyConApp _ _) (FunTy _ _) = GT
1042 cmp env (ForAllTy _ _) other = GT
1047 cmps env (t:ts) [] = GT
1048 cmps env [] (t:ts) = LT
1049 cmps env (t1:t1s) (t2:t2s) = cmp env t1 t2 `thenCmp` cmps env t1s t2s