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, funResultTy,
31 mkTyConApp, mkTyConTy, splitTyConApp_maybe,
32 splitAlgTyConApp_maybe, splitAlgTyConApp,
33 mkDictTy, splitDictTy_maybe, isDictTy,
35 mkSynTy, isSynTy, deNoteType,
37 mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg,
39 mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
40 applyTy, applyTys, isForAllTy,
43 TauType, RhoType, SigmaType, ThetaType,
46 mkSigmaTy, splitSigmaTy,
49 isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType,
53 tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind,
57 substTy, substTheta, fullSubstTy, substTyVar,
58 substTopTy, substTopTheta,
60 -- Tidying up for printing
62 tidyOpenType, tidyOpenTypes,
63 tidyTyVar, tidyTyVars,
67 #include "HsVersions.h"
69 import {-# SOURCE #-} DataCon( DataCon )
70 import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
73 import Var ( Id, TyVar, IdOrTyVar, UVar,
74 tyVarKind, tyVarName, isId, idType, setTyVarName, setVarOcc
79 import Name ( NamedThing(..), Provenance(..), ExportFlag(..),
80 mkWiredInTyConName, mkGlobalName, mkLocalName, mkKindOccFS, tcName,
81 tidyOccName, TidyOccEnv
84 import Class ( classTyCon, Class )
85 import TyCon ( TyCon, KindCon,
86 mkFunTyCon, mkKindCon, mkSuperKindCon,
87 matchesTyCon, isUnboxedTupleTyCon, isUnLiftedTyCon,
88 isFunTyCon, isDataTyCon,
89 isAlgTyCon, isSynTyCon, tyConArity,
90 tyConKind, tyConDataCons, getSynTyConDefn,
91 tyConPrimRep, tyConClass_maybe
95 import BasicTypes ( Unused )
96 import SrcLoc ( mkBuiltinSrcLoc, noSrcLoc )
97 import PrelMods ( pREL_GHC )
98 import Maybes ( maybeToBool )
99 import PrimRep ( PrimRep(..), isFollowableRep )
100 import Unique -- quite a few *Keys
101 import Util ( thenCmp, mapAccumL, seqList, ($!) )
106 %************************************************************************
108 \subsection{Type Classifications}
110 %************************************************************************
114 *unboxed* iff its representation is other than a pointer
115 Unboxed types cannot instantiate a type variable.
116 Unboxed types are always unlifted.
118 *lifted* A type is lifted iff it has bottom as an element.
119 Closures always have lifted types: i.e. any
120 let-bound identifier in Core must have a lifted
121 type. Operationally, a lifted object is one that
123 (NOTE: previously "pointed").
125 *algebraic* A type with one or more constructors, whether declared
126 with "data" or "newtype".
127 An algebraic type is one that can be deconstructed
128 with a case expression.
129 *NOT* the same as lifted types, because we also
130 include unboxed tuples in this classification.
132 *data* A type declared with "data". Also boxed tuples.
134 *primitive* iff it is a built-in type that can't be expressed
137 Currently, all primitive types are unlifted, but that's not necessarily
138 the case. (E.g. Int could be primitive.)
140 Some primitive types are unboxed, such as Int#, whereas some are boxed
141 but unlifted (such as ByteArray#). The only primitive types that we
142 classify as algebraic are the unboxed tuples.
144 examples of type classifications:
146 Type primitive boxed lifted algebraic
147 -----------------------------------------------------------------------------
149 ByteArray# Yes Yes No No
150 (# a, b #) Yes No No Yes
151 ( a, b ) No Yes Yes Yes
154 %************************************************************************
156 \subsection{The data type}
158 %************************************************************************
162 type SuperKind = Type
165 type TyVarSubst = TyVarEnv Type
171 Type -- Function is *not* a TyConApp
174 | TyConApp -- Application of a TyCon
175 TyCon -- *Invariant* saturated appliations of FunTyCon and
176 -- synonyms have their own constructors, below.
177 [Type] -- Might not be saturated.
179 | FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2]
183 | NoteTy -- Saturated application of a type synonym
185 Type -- The expanded version
192 = SynNote Type -- The unexpanded version of the type synonym; always a TyConApp
193 | FTVNote TyVarSet -- The free type variables of the noted expression
194 | UsgNote UsageAnn -- The usage annotation at this node
197 = UsOnce -- Used at most once
198 | UsMany -- Used possibly many times (no info; this annotation can be omitted)
199 | UsVar UVar -- Annotation is variable (should only happen inside analysis)
203 %************************************************************************
207 %************************************************************************
215 kv :: KX is a kind variable
221 | AnyBox -- Used *only* for special built-in things
222 -- like error :: forall (a::*?). String -> a
223 -- Here, the 'a' can be instantiated to a boxed or
227 bxv :: BX is a boxity variable
231 | sk -> sk -- In ptic (BX -> KX)
234 mk_kind_name key str = mkGlobalName key pREL_GHC (mkKindOccFS tcName str)
235 (LocalDef mkBuiltinSrcLoc NotExported)
236 -- mk_kind_name is a bit of a hack
237 -- The LocalDef means that we print the name without
238 -- a qualifier, which is what we want for these kinds.
239 -- It's used for both Kinds and Boxities
245 superKind :: SuperKind -- KX, the type of all kinds
246 superKindName = mk_kind_name kindConKey SLIT("KX")
247 superKind = TyConApp (mkSuperKindCon superKindName) []
249 superBoxity :: SuperKind -- BX, the type of all boxities
250 superBoxityName = mk_kind_name boxityConKey SLIT("BX")
251 superBoxity = TyConApp (mkSuperKindCon superBoxityName) []
254 Define Boxed, Unboxed, AnyBox
257 boxedKind, unboxedKind, anyBoxKind :: Kind -- Of superkind superBoxity
259 boxedConName = mk_kind_name boxedConKey SLIT("*")
260 boxedKind = TyConApp (mkKindCon boxedConName superBoxity) []
262 unboxedConName = mk_kind_name unboxedConKey SLIT("#")
263 unboxedKind = TyConApp (mkKindCon unboxedConName superBoxity) []
265 anyBoxConName = mk_kind_name anyBoxConKey SLIT("?")
266 anyBoxCon = mkKindCon anyBoxConName superBoxity -- A kind of wild card
267 anyBoxKind = TyConApp anyBoxCon []
274 typeConName = mk_kind_name typeConKey SLIT("Type")
275 typeCon = mkKindCon typeConName (superBoxity `FunTy` superKind)
278 Define (Type Boxed), (Type Unboxed), (Type AnyBox)
281 boxedTypeKind, unboxedTypeKind, openTypeKind :: Kind
282 boxedTypeKind = TyConApp typeCon [boxedKind]
283 unboxedTypeKind = TyConApp typeCon [unboxedKind]
284 openTypeKind = TyConApp typeCon [anyBoxKind]
286 mkArrowKind :: Kind -> Kind -> Kind
287 mkArrowKind k1 k2 = k1 `FunTy` k2
289 mkArrowKinds :: [Kind] -> Kind -> Kind
290 mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
294 hasMoreBoxityInfo :: Kind -> Kind -> Bool
295 hasMoreBoxityInfo k1 k2
296 | k2 == openTypeKind = ASSERT( is_type_kind k1) True
297 | otherwise = k1 == k2
299 -- Returns true for things of form (Type x)
300 is_type_kind k = case splitTyConApp_maybe k of
301 Just (tc,[_]) -> tc == typeCon
306 %************************************************************************
308 \subsection{Wired-in type constructors
310 %************************************************************************
312 We define a few wired-in type constructors here to avoid module knots
315 funTyConName = mkWiredInTyConName funTyConKey pREL_GHC SLIT("(->)") funTyCon
316 funTyCon = mkFunTyCon funTyConName (mkArrowKinds [boxedTypeKind, boxedTypeKind] boxedTypeKind)
321 %************************************************************************
323 \subsection{Constructor-specific functions}
325 %************************************************************************
328 ---------------------------------------------------------------------
332 mkTyVarTy :: TyVar -> Type
335 mkTyVarTys :: [TyVar] -> [Type]
336 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
338 getTyVar :: String -> Type -> TyVar
339 getTyVar msg (TyVarTy tv) = tv
340 getTyVar msg (NoteTy _ t) = getTyVar msg t
341 getTyVar msg other = panic ("getTyVar: " ++ msg)
343 getTyVar_maybe :: Type -> Maybe TyVar
344 getTyVar_maybe (TyVarTy tv) = Just tv
345 getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
346 getTyVar_maybe other = Nothing
348 isTyVarTy :: Type -> Bool
349 isTyVarTy (TyVarTy tv) = True
350 isTyVarTy (NoteTy _ ty) = isTyVarTy ty
351 isTyVarTy other = False
355 ---------------------------------------------------------------------
358 We need to be pretty careful with AppTy to make sure we obey the
359 invariant that a TyConApp is always visibly so. mkAppTy maintains the
363 mkAppTy orig_ty1 orig_ty2 = ASSERT2( isNotUsgTy orig_ty1 && isNotUsgTy orig_ty2, pprType orig_ty1 <+> text "to" <+> pprType orig_ty2 )
366 mk_app (NoteTy _ ty1) = mk_app ty1
367 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
368 mk_app ty1 = AppTy orig_ty1 orig_ty2
370 mkAppTys :: Type -> [Type] -> Type
371 mkAppTys orig_ty1 [] = orig_ty1
372 -- This check for an empty list of type arguments
373 -- avoids the needless of a type synonym constructor.
374 -- For example: mkAppTys Rational []
375 -- returns to (Ratio Integer), which has needlessly lost
376 -- the Rational part.
377 mkAppTys orig_ty1 orig_tys2 = ASSERT2( isNotUsgTy orig_ty1, pprType orig_ty1 )
380 mk_app (NoteTy _ ty1) = mk_app ty1
381 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
382 mk_app ty1 = ASSERT2( all isNotUsgTy orig_tys2, pprType orig_ty1 <+> text "to" <+> hsep (map pprType orig_tys2) )
383 foldl AppTy orig_ty1 orig_tys2
385 splitAppTy_maybe :: Type -> Maybe (Type, Type)
386 splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
387 splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
388 splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty
389 splitAppTy_maybe (TyConApp tc []) = Nothing
390 splitAppTy_maybe (TyConApp tc tys) = split tys []
392 split [ty2] acc = Just (TyConApp tc (reverse acc), ty2)
393 split (ty:tys) acc = split tys (ty:acc)
395 splitAppTy_maybe other = Nothing
397 splitAppTy :: Type -> (Type, Type)
398 splitAppTy ty = case splitAppTy_maybe ty of
400 Nothing -> panic "splitAppTy"
402 splitAppTys :: Type -> (Type, [Type])
403 splitAppTys ty = split ty ty []
405 split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
406 split orig_ty (NoteTy _ ty) args = split orig_ty ty args
407 split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
408 (TyConApp funTyCon [], [ty1,ty2])
409 split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
410 split orig_ty ty args = (orig_ty, args)
414 ---------------------------------------------------------------------
419 mkFunTy :: Type -> Type -> Type
420 mkFunTy arg res = FunTy arg res
422 mkFunTys :: [Type] -> Type -> Type
423 mkFunTys tys ty = foldr FunTy ty tys
425 splitFunTy_maybe :: Type -> Maybe (Type, Type)
426 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
427 splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
428 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 zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
439 zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
441 split acc [] nty ty = (reverse acc, nty)
442 split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
443 split acc xs nty (NoteTy _ ty) = split acc xs nty ty
444 split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty)
446 funResultTy :: Type -> Type
447 funResultTy (FunTy arg res) = res
448 funResultTy (NoteTy _ ty) = funResultTy ty
449 funResultTy ty = pprPanic "funResultTy" (pprType ty)
453 ---------------------------------------------------------------------
458 mkTyConApp :: TyCon -> [Type] -> Type
460 | isFunTyCon tycon && length tys == 2
462 (ty1:ty2:_) -> FunTy ty1 ty2
465 = ASSERT(not (isSynTyCon tycon))
468 mkTyConTy :: TyCon -> Type
469 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
472 -- splitTyConApp "looks through" synonyms, because they don't
473 -- mean a distinct type, but all other type-constructor applications
474 -- including functions are returned as Just ..
476 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
477 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
478 splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
479 splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
480 splitTyConApp_maybe other = Nothing
482 -- splitAlgTyConApp_maybe looks for
483 -- *saturated* applications of *algebraic* data types
484 -- "Algebraic" => newtype, data type, or dictionary (not function types)
485 -- We return the constructors too.
487 splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon])
488 splitAlgTyConApp_maybe (TyConApp tc tys)
490 tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
491 splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
492 splitAlgTyConApp_maybe other = Nothing
494 splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon])
495 -- Here the "algebraic" property is an *assertion*
496 splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
497 (tc, tys, tyConDataCons tc)
498 splitAlgTyConApp (NoteTy _ ty) = splitAlgTyConApp ty
501 "Dictionary" types are just ordinary data types, but you can
502 tell from the type constructor whether it's a dictionary or not.
505 mkDictTy :: Class -> [Type] -> Type
506 mkDictTy clas tys = TyConApp (classTyCon clas) tys
508 splitDictTy_maybe :: Type -> Maybe (Class, [Type])
509 splitDictTy_maybe (TyConApp tc tys)
510 | maybeToBool maybe_class
511 && tyConArity tc == length tys = Just (clas, tys)
513 maybe_class = tyConClass_maybe tc
514 Just clas = maybe_class
516 splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty
517 splitDictTy_maybe other = Nothing
519 isDictTy :: Type -> Bool
520 -- This version is slightly more efficient than (maybeToBool . splitDictTy)
521 isDictTy (TyConApp tc tys)
522 | maybeToBool (tyConClass_maybe tc)
523 && tyConArity tc == length tys
525 isDictTy (NoteTy _ ty) = isDictTy ty
526 isDictTy other = False
530 ---------------------------------------------------------------------
535 mkSynTy syn_tycon tys
536 = ASSERT( isSynTyCon syn_tycon )
537 ASSERT( isNotUsgTy body )
538 NoteTy (SynNote (TyConApp syn_tycon tys))
539 (substTopTy (zipVarEnv tyvars tys) body)
541 (tyvars, body) = getSynTyConDefn syn_tycon
543 isSynTy (NoteTy (SynNote _) _) = True
544 isSynTy other = False
546 deNoteType :: Type -> Type
547 -- Sorry for the cute name
548 deNoteType ty@(TyVarTy tyvar) = ty
549 deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
550 deNoteType (NoteTy _ ty) = deNoteType ty
551 deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg)
552 deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg)
553 deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty)
556 Notes on type synonyms
557 ~~~~~~~~~~~~~~~~~~~~~~
558 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
559 to return type synonyms whereever possible. Thus
564 splitFunTys (a -> Foo a) = ([a], Foo a)
567 The reason is that we then get better (shorter) type signatures in
568 interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
573 ---------------------------------------------------------------------
577 NB: Invariant: if present, usage note is at the very top of the type.
578 This should be carefully preserved.
580 In some parts of the compiler, comments use the _Once Upon a
581 Polymorphic Type_ (POPL'99) usage of "sigma = usage-annotated type;
582 tau = un-usage-annotated type"; unfortunately this conflicts with the
583 rho/tau/theta/sigma usage in the rest of the compiler.
587 mkUsgTy :: UsageAnn -> Type -> Type
589 mkUsgTy UsMany ty = ASSERT2( isNotUsgTy ty, pprType ty )
592 mkUsgTy usg ty = ASSERT2( isNotUsgTy ty, pprType ty )
593 NoteTy (UsgNote usg) ty
595 -- The isUsgTy function is utterly useless if UsManys are omitted.
596 -- Be warned! KSW 1999-04.
597 isUsgTy :: Type -> Bool
601 isUsgTy (NoteTy (UsgNote _) _) = True
602 isUsgTy other = False
605 -- The isNotUsgTy function may return a false True if UsManys are omitted;
606 -- in other words, A SSERT( isNotUsgTy ty ) may be useful but
607 -- A SSERT( not (isNotUsg ty) ) is asking for trouble. KSW 1999-04.
608 isNotUsgTy :: Type -> Bool
609 isNotUsgTy (NoteTy (UsgNote _) _) = False
610 isNotUsgTy other = True
612 -- splitUsgTy_maybe is not exported, since it is meaningless if
613 -- UsManys are omitted. It is used in several places in this module,
614 -- however. KSW 1999-04.
615 splitUsgTy_maybe :: Type -> Maybe (UsageAnn,Type)
616 splitUsgTy_maybe (NoteTy (UsgNote usg) ty2) = ASSERT( isNotUsgTy ty2 )
618 splitUsgTy_maybe ty = Nothing
620 splitUsgTy :: Type -> (UsageAnn,Type)
621 splitUsgTy ty = case splitUsgTy_maybe ty of
627 pprPanic "splitUsgTy: no usage annot:" $ pprType ty
630 tyUsg :: Type -> UsageAnn
631 tyUsg = fst . splitUsgTy
633 unUsgTy :: Type -> Type
634 -- strip outer usage annotation if present
635 unUsgTy ty = case splitUsgTy_maybe ty of
636 Just (_,ty1) -> ASSERT2( isNotUsgTy ty1, pprType ty )
643 ---------------------------------------------------------------------
647 We need to be clever here with usage annotations; they need to be
648 lifted or lowered through the forall as appropriate.
651 mkForAllTy :: TyVar -> Type -> Type
652 mkForAllTy tyvar ty = case splitUsgTy_maybe ty of
653 Just (usg,ty') -> NoteTy (UsgNote usg)
655 Nothing -> ForAllTy tyvar ty
657 mkForAllTys :: [TyVar] -> Type -> Type
658 mkForAllTys tyvars ty = case splitUsgTy_maybe ty of
659 Just (usg,ty') -> NoteTy (UsgNote usg)
660 (foldr ForAllTy ty' tyvars)
661 Nothing -> foldr ForAllTy ty tyvars
663 splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
664 splitForAllTy_maybe ty = case splitUsgTy_maybe ty of
665 Just (usg,ty') -> do (tyvar,ty'') <- splitFAT_m ty'
666 return (tyvar, NoteTy (UsgNote usg) ty'')
667 Nothing -> splitFAT_m ty
669 splitFAT_m (NoteTy _ ty) = splitFAT_m ty
670 splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
671 splitFAT_m _ = Nothing
673 isForAllTy :: Type -> Bool
674 isForAllTy (NoteTy _ ty) = isForAllTy ty
675 isForAllTy (ForAllTy tyvar ty) = True
678 splitForAllTys :: Type -> ([TyVar], Type)
679 splitForAllTys ty = case splitUsgTy_maybe ty of
680 Just (usg,ty') -> let (tvs,ty'') = split ty' ty' []
681 in (tvs, NoteTy (UsgNote usg) ty'')
682 Nothing -> split ty ty []
684 split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
685 split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
686 split orig_ty t tvs = (reverse tvs, orig_ty)
689 @mkPiType@ makes a (->) type or a forall type, depending on whether
690 it is given a type variable or a term variable.
693 mkPiType :: IdOrTyVar -> Type -> Type -- The more polymorphic version doesn't work...
694 mkPiType v ty | isId v = mkFunTy (idType v) ty
695 | otherwise = mkForAllTy v ty
699 applyTy :: Type -> Type -> Type
700 applyTy (NoteTy note@(UsgNote _) fun) arg = NoteTy note (applyTy fun arg)
701 applyTy (NoteTy _ fun) arg = applyTy fun arg
702 applyTy (ForAllTy tv ty) arg = ASSERT( isNotUsgTy arg )
703 substTy (mkVarEnv [(tv,arg)]) ty
704 applyTy other arg = panic "applyTy"
706 applyTys :: Type -> [Type] -> Type
707 applyTys fun_ty arg_tys
708 = go [] fun_ty arg_tys
710 go env ty [] = substTy (mkVarEnv env) ty
711 go env (NoteTy note@(UsgNote _) fun)
712 args = NoteTy note (go env fun args)
713 go env (NoteTy _ fun) args = go env fun args
714 go env (ForAllTy tv ty) (arg:args) = ASSERT2( isNotUsgTy arg, vcat ((map pprType arg_tys) ++ [text "in application of" <+> pprType fun_ty]) )
715 go ((tv,arg):env) ty args
716 go env other args = panic "applyTys"
719 Note that we allow applications to be of usage-annotated- types, as an
720 extension: we handle them by lifting the annotation outside. The
721 argument, however, must still be unannotated.
723 %************************************************************************
725 \subsection{Stuff to do with the source-language types}
727 %************************************************************************
732 type ThetaType = [(Class, [Type])]
733 type SigmaType = Type
736 @isTauTy@ tests for nested for-alls.
739 isTauTy :: Type -> Bool
740 isTauTy (TyVarTy v) = True
741 isTauTy (TyConApp _ tys) = all isTauTy tys
742 isTauTy (AppTy a b) = isTauTy a && isTauTy b
743 isTauTy (FunTy a b) = isTauTy a && isTauTy b
744 isTauTy (NoteTy _ ty) = isTauTy ty
745 isTauTy other = False
749 mkRhoTy :: [(Class, [Type])] -> Type -> Type
750 mkRhoTy theta ty = foldr (\(c,t) r -> FunTy (mkDictTy c t) r) ty theta
752 splitRhoTy :: Type -> ([(Class, [Type])], Type)
753 splitRhoTy ty = split ty ty []
755 split orig_ty (FunTy arg res) ts = case splitDictTy_maybe arg of
756 Just pair -> split res res (pair:ts)
757 Nothing -> (reverse ts, orig_ty)
758 split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts
759 split orig_ty ty ts = (reverse ts, orig_ty)
765 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
767 splitSigmaTy :: Type -> ([TyVar], [(Class, [Type])], Type)
771 (tyvars,rho) = splitForAllTys ty
772 (theta,tau) = splitRhoTy rho
776 %************************************************************************
778 \subsection{Kinds and free variables}
780 %************************************************************************
782 ---------------------------------------------------------------------
783 Finding the kind of a type
784 ~~~~~~~~~~~~~~~~~~~~~~~~~~
786 typeKind :: Type -> Kind
788 typeKind (TyVarTy tyvar) = tyVarKind tyvar
789 typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
790 typeKind (NoteTy _ ty) = typeKind ty
791 typeKind (AppTy fun arg) = funResultTy (typeKind fun)
792 typeKind (FunTy fun arg) = typeKindF arg
793 typeKind (ForAllTy _ ty) = typeKindF ty -- We could make this a new kind polyTypeKind
794 -- to prevent a forall type unifying with a
795 -- boxed type variable, but I didn't think it
798 -- The complication is that a *function* is boxed even if
799 -- its *result* type is unboxed. Seems wierd.
801 typeKindF :: Type -> Kind
802 typeKindF (NoteTy _ ty) = typeKindF ty
803 typeKindF (FunTy _ ty) = typeKindF ty
804 typeKindF (ForAllTy _ ty) = typeKindF ty
805 typeKindF other = fix_up (typeKind other)
807 fix_up (TyConApp kc _) | kc == typeCon = boxedTypeKind
808 -- Functions at the type level are always boxed
809 fix_up (NoteTy _ kind) = fix_up kind
814 ---------------------------------------------------------------------
815 Free variables of a type
816 ~~~~~~~~~~~~~~~~~~~~~~~~
818 tyVarsOfType :: Type -> TyVarSet
820 tyVarsOfType (TyVarTy tv) = unitVarSet tv
821 tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
822 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
823 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
824 tyVarsOfType (NoteTy (UsgNote _) ty) = tyVarsOfType ty
825 tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
826 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
827 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
829 tyVarsOfTypes :: [Type] -> TyVarSet
830 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
832 -- Add a Note with the free tyvars to the top of the type
833 -- (but under a usage if there is one)
834 addFreeTyVars :: Type -> Type
835 addFreeTyVars (NoteTy note@(UsgNote _) ty) = NoteTy note (addFreeTyVars ty)
836 addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
837 addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
839 -- Find the free names of a type, including the type constructors and classes it mentions
840 namesOfType :: Type -> NameSet
841 namesOfType (TyVarTy tv) = unitNameSet (getName tv)
842 namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets`
844 namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1
845 namesOfType (NoteTy other_note ty2) = namesOfType ty2
846 namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
847 namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
848 namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
850 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
854 %************************************************************************
856 \subsection{Instantiating a type}
858 %************************************************************************
860 @substTy@ applies a substitution to a type. It deals correctly with name capture.
863 substTy :: TyVarSubst -> Type -> Type
865 | isEmptyVarEnv tenv = ty
866 | otherwise = subst_ty tenv tset ty
868 tset = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet tenv
869 -- If ty doesn't have any for-alls, then this thunk
870 -- will never be evaluated
872 substTheta :: TyVarSubst -> ThetaType -> ThetaType
873 substTheta tenv theta
874 | isEmptyVarEnv tenv = theta
875 | otherwise = [(clas, map (subst_ty tenv tset) tys) | (clas, tys) <- theta]
877 tset = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet tenv
878 -- If ty doesn't have any for-alls, then this thunk
879 -- will never be evaluated
881 substTopTy :: TyVarSubst -> Type -> Type
882 substTopTy = substTy -- Called when doing top-level substitutions.
883 -- Here we expect that the free vars of the range of the
884 -- substitution will be empty; but during typechecking I'm
885 -- a bit dubious about that (mutable tyvars bouund to Int, say)
886 -- So I've left it as substTy for the moment. SLPJ Nov 98
887 substTopTheta = substTheta
890 @fullSubstTy@ is like @substTy@ except that it needs to be given a set
891 of in-scope type variables. In exchange it's a bit more efficient, at least
892 if you happen to have that set lying around.
895 fullSubstTy :: TyVarSubst -- Substitution to apply
896 -> TyVarSet -- Superset of the free tyvars of
897 -- the range of the tyvar env
899 -- ASSUMPTION: The substitution is idempotent.
900 -- Equivalently: No tyvar is both in scope, and in the domain of the substitution.
901 fullSubstTy tenv tset ty | isEmptyVarEnv tenv = ty
902 | otherwise = subst_ty tenv tset ty
904 -- subst_ty does the business
905 subst_ty tenv tset ty
908 go (TyConApp tc tys) = let args = map go tys
909 in args `seqList` TyConApp tc args
910 go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
911 go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
912 go (NoteTy (UsgNote usg) ty2) = (NoteTy $! (UsgNote usg)) $! (go ty2) -- Keep usage annot
913 go (FunTy arg res) = FunTy (go arg) (go res)
914 go (AppTy fun arg) = mkAppTy (go fun) (go arg)
915 go ty@(TyVarTy tv) = case (lookupVarEnv tenv tv) of
918 go (ForAllTy tv ty) = case substTyVar tenv tset tv of
919 (tenv', tset', tv') -> ForAllTy tv' $! (subst_ty tenv' tset' ty)
921 substTyVar :: TyVarSubst -> TyVarSet -> TyVar
922 -> (TyVarSubst, TyVarSet, TyVar)
924 substTyVar tenv tset tv
925 | not (tv `elemVarSet` tset) -- No need to clone
926 -- But must delete from substitution
927 = (tenv `delVarEnv` tv, tset `extendVarSet` tv, tv)
929 | otherwise -- The forall's variable is in scope so
930 -- we'd better rename it away from the in-scope variables
931 -- Extending the substitution to do this renaming also
932 -- has the (correct) effect of discarding any existing
933 -- substitution for that variable
934 = (extendVarEnv tenv tv (TyVarTy tv'), tset `extendVarSet` tv', tv')
936 tv' = uniqAway tset tv
940 %************************************************************************
942 \subsection{TidyType}
944 %************************************************************************
946 tidyTy tidies up a type for printing in an error message, or in
949 It doesn't change the uniques at all, just the print names.
952 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
953 tidyTyVar env@(tidy_env, subst) tyvar
954 = case lookupVarEnv subst tyvar of
956 Just tyvar' -> -- Already substituted
959 Nothing -> -- Make a new nice name for it
961 case tidyOccName tidy_env (getOccName name) of
962 (tidy', occ') -> -- New occname reqd
963 ((tidy', subst'), tyvar')
965 subst' = extendVarEnv subst tyvar tyvar'
966 tyvar' = setTyVarName tyvar name'
967 name' = mkLocalName (getUnique name) occ' noSrcLoc
968 -- Note: make a *user* tyvar, so it printes nicely
969 -- Could extract src loc, but no need.
971 name = tyVarName tyvar
973 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
975 tidyType :: TidyEnv -> Type -> Type
976 tidyType env@(tidy_env, subst) ty
979 go (TyVarTy tv) = case lookupVarEnv subst tv of
980 Nothing -> TyVarTy tv
981 Just tv' -> TyVarTy tv'
982 go (TyConApp tycon tys) = let args = map go tys
983 in args `seqList` TyConApp tycon args
984 go (NoteTy note ty) = (NoteTy $! (go_note note)) $! (go ty)
985 go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg)
986 go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg)
987 go (ForAllTy tv ty) = ForAllTy tv' $! (tidyType env' ty)
989 (env', tv') = tidyTyVar env tv
991 go_note (SynNote ty) = SynNote $! (go ty)
992 go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
993 go_note note@(UsgNote _) = note -- Usage annotation is already tidy
995 tidyTypes env tys = map (tidyType env) tys
999 @tidyOpenType@ grabs the free type varibles, tidies them
1000 and then uses @tidyType@ to work over the type itself
1003 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
1005 = (env', tidyType env' ty)
1007 env' = foldl go env (varSetElems (tyVarsOfType ty))
1008 go env tyvar = fst (tidyTyVar env tyvar)
1010 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
1011 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
1013 tidyTopType :: Type -> Type
1014 tidyTopType ty = tidyType emptyTidyEnv ty
1018 %************************************************************************
1020 \subsection{Boxedness and liftedness}
1022 %************************************************************************
1025 isUnboxedType :: Type -> Bool
1026 isUnboxedType ty = not (isFollowableRep (typePrimRep ty))
1028 isUnLiftedType :: Type -> Bool
1029 isUnLiftedType ty = case splitTyConApp_maybe ty of
1030 Just (tc, ty_args) -> isUnLiftedTyCon tc
1033 isUnboxedTupleType :: Type -> Bool
1034 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
1035 Just (tc, ty_args) -> isUnboxedTupleTyCon tc
1038 -- Should only be applied to *types*; hence the assert
1039 isAlgType :: Type -> Bool
1040 isAlgType ty = case splitTyConApp_maybe ty of
1041 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1045 -- Should only be applied to *types*; hence the assert
1046 isDataType :: Type -> Bool
1047 isDataType ty = case splitTyConApp_maybe ty of
1048 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1052 typePrimRep :: Type -> PrimRep
1053 typePrimRep ty = case splitTyConApp_maybe ty of
1054 Just (tc, ty_args) -> tyConPrimRep tc
1058 %************************************************************************
1060 \subsection{Equality on types}
1062 %************************************************************************
1064 For the moment at least, type comparisons don't work if
1065 there are embedded for-alls.
1068 instance Eq Type where
1069 ty1 == ty2 = case ty1 `cmpTy` ty2 of { EQ -> True; other -> False }
1071 instance Ord Type where
1072 compare ty1 ty2 = cmpTy ty1 ty2
1074 cmpTy :: Type -> Type -> Ordering
1076 = cmp emptyVarEnv ty1 ty2
1078 -- The "env" maps type variables in ty1 to type variables in ty2
1079 -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
1080 -- we in effect substitute tv2 for tv1 in t1 before continuing
1081 lookup env tv1 = case lookupVarEnv env tv1 of
1085 -- Get rid of NoteTy
1086 cmp env (NoteTy _ ty1) ty2 = cmp env ty1 ty2
1087 cmp env ty1 (NoteTy _ ty2) = cmp env ty1 ty2
1089 -- Deal with equal constructors
1090 cmp env (TyVarTy tv1) (TyVarTy tv2) = lookup env tv1 `compare` tv2
1091 cmp env (AppTy f1 a1) (AppTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
1092 cmp env (FunTy f1 a1) (FunTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
1093 cmp env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmps env tys1 tys2)
1094 cmp env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmp (extendVarEnv env tv1 tv2) t1 t2
1096 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
1097 cmp env (AppTy _ _) (TyVarTy _) = GT
1099 cmp env (FunTy _ _) (TyVarTy _) = GT
1100 cmp env (FunTy _ _) (AppTy _ _) = GT
1102 cmp env (TyConApp _ _) (TyVarTy _) = GT
1103 cmp env (TyConApp _ _) (AppTy _ _) = GT
1104 cmp env (TyConApp _ _) (FunTy _ _) = GT
1106 cmp env (ForAllTy _ _) other = GT
1111 cmps env (t:ts) [] = GT
1112 cmps env [] (t:ts) = LT
1113 cmps env (t1:t1s) (t2:t2s) = cmp env t1 t2 `thenCmp` cmps env t1s t2s