2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
4 \section[Type]{Type - public interface}
8 -- re-exports from TypeRep:
12 superKind, superBoxity, -- KX and BX respectively
13 boxedBoxity, unboxedBoxity, -- :: BX
15 typeCon, -- :: BX -> KX
16 boxedTypeKind, unboxedTypeKind, openTypeKind, -- :: KX
17 mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX
21 -- exports from this module:
22 hasMoreBoxityInfo, defaultKind,
24 mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
26 mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
28 mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, splitFunTysN,
29 funResultTy, funArgTy, zipFunTys,
31 mkTyConApp, mkTyConTy, splitTyConApp_maybe,
32 splitAlgTyConApp_maybe, splitAlgTyConApp,
34 -- Predicates and the like
35 mkDictTy, mkDictTys, mkPredTy, splitPredTy_maybe,
36 splitDictTy_maybe, isDictTy, predRepTy,
38 mkSynTy, isSynTy, deNoteType,
40 repType, splitRepFunTys, splitNewType_maybe, typePrimRep,
42 UsageAnn(..), mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg,
43 mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy,
45 mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
46 applyTy, applyTys, hoistForAllTys,
48 TauType, RhoType, SigmaType, PredType(..), ThetaType,
49 ClassPred, ClassContext, mkClassPred,
50 getClassTys_maybe, ipName_maybe, classesToPreds, classesOfPreds,
51 isTauTy, mkRhoTy, splitRhoTy,
52 mkSigmaTy, isSigmaTy, splitSigmaTy,
56 isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
59 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
60 namesOfType, typeKind, addFreeTyVars,
62 -- Tidying up for printing
64 tidyOpenType, tidyOpenTypes,
65 tidyTyVar, tidyTyVars,
73 #include "HsVersions.h"
75 -- We import the representation and primitive functions from TypeRep.
76 -- Many things are reexported, but not the representation!
82 import {-# SOURCE #-} DataCon( DataCon, dataConRepType )
83 import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
84 import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy )
87 import Var ( TyVar, Var, UVar,
88 tyVarKind, tyVarName, setTyVarName, isId, idType,
93 import Name ( Name, NamedThing(..), OccName, mkLocalName, tidyOccName )
95 import Class ( classTyCon, Class, ClassPred, ClassContext )
97 isUnboxedTupleTyCon, isUnLiftedTyCon,
98 isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep,
99 isAlgTyCon, isSynTyCon, tyConArity,
100 tyConKind, tyConDataCons, getSynTyConDefn,
101 tyConPrimRep, tyConClass_maybe
105 import SrcLoc ( noSrcLoc )
106 import Maybes ( maybeToBool )
107 import PrimRep ( PrimRep(..), isFollowableRep )
108 import Unique ( Uniquable(..) )
109 import Util ( mapAccumL, seqList, thenCmp )
111 import UniqSet ( sizeUniqSet ) -- Should come via VarSet
115 %************************************************************************
117 \subsection{Stuff to do with kinds.}
119 %************************************************************************
122 hasMoreBoxityInfo :: Kind -> Kind -> Bool
123 hasMoreBoxityInfo k1 k2
124 | k2 == openTypeKind = True
125 | otherwise = k1 == k2
127 defaultKind :: Kind -> Kind
128 -- Used when generalising: default kind '?' to '*'
129 defaultKind kind | kind == openTypeKind = boxedTypeKind
134 %************************************************************************
136 \subsection{Constructor-specific functions}
138 %************************************************************************
141 ---------------------------------------------------------------------
145 mkTyVarTy :: TyVar -> Type
148 mkTyVarTys :: [TyVar] -> [Type]
149 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
151 getTyVar :: String -> Type -> TyVar
152 getTyVar msg (TyVarTy tv) = tv
153 getTyVar msg (PredTy p) = getTyVar msg (predRepTy p)
154 getTyVar msg (NoteTy _ t) = getTyVar msg t
155 getTyVar msg other = panic ("getTyVar: " ++ msg)
157 getTyVar_maybe :: Type -> Maybe TyVar
158 getTyVar_maybe (TyVarTy tv) = Just tv
159 getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
160 getTyVar_maybe (PredTy p) = getTyVar_maybe (predRepTy p)
161 getTyVar_maybe other = Nothing
163 isTyVarTy :: Type -> Bool
164 isTyVarTy (TyVarTy tv) = True
165 isTyVarTy (NoteTy _ ty) = isTyVarTy ty
166 isTyVarTy (PredTy p) = isTyVarTy (predRepTy p)
167 isTyVarTy other = False
171 ---------------------------------------------------------------------
174 We need to be pretty careful with AppTy to make sure we obey the
175 invariant that a TyConApp is always visibly so. mkAppTy maintains the
179 mkAppTy orig_ty1 orig_ty2
180 = ASSERT2( isNotUsgTy orig_ty1 && isNotUsgTy orig_ty2, pprType orig_ty1 <+> text "to" <+> pprType orig_ty2 )
181 ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind *
184 mk_app (NoteTy _ ty1) = mk_app ty1
185 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
186 mk_app ty1 = AppTy orig_ty1 orig_ty2
188 mkAppTys :: Type -> [Type] -> Type
189 mkAppTys orig_ty1 [] = orig_ty1
190 -- This check for an empty list of type arguments
191 -- avoids the needless of a type synonym constructor.
192 -- For example: mkAppTys Rational []
193 -- returns to (Ratio Integer), which has needlessly lost
194 -- the Rational part.
195 mkAppTys orig_ty1 orig_tys2
196 = ASSERT2( isNotUsgTy orig_ty1, pprType orig_ty1 )
197 ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind *
200 mk_app (NoteTy _ ty1) = mk_app ty1
201 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
202 mk_app ty1 = ASSERT2( all isNotUsgTy orig_tys2, pprType orig_ty1 <+> text "to" <+> hsep (map pprType orig_tys2) )
203 foldl AppTy orig_ty1 orig_tys2
205 splitAppTy_maybe :: Type -> Maybe (Type, Type)
206 splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
207 splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
208 splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty
209 splitAppTy_maybe (PredTy p) = splitAppTy_maybe (predRepTy p)
210 splitAppTy_maybe (TyConApp tc []) = Nothing
211 splitAppTy_maybe (TyConApp tc tys) = split tys []
213 split [ty2] acc = Just (TyConApp tc (reverse acc), ty2)
214 split (ty:tys) acc = split tys (ty:acc)
216 splitAppTy_maybe other = Nothing
218 splitAppTy :: Type -> (Type, Type)
219 splitAppTy ty = case splitAppTy_maybe ty of
221 Nothing -> panic "splitAppTy"
223 splitAppTys :: Type -> (Type, [Type])
224 splitAppTys ty = split ty ty []
226 split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
227 split orig_ty (NoteTy _ ty) args = split orig_ty ty args
228 split orig_ty (PredTy p) args = split orig_ty (predRepTy p) args
229 split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
230 (TyConApp funTyCon [], [ty1,ty2])
231 split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
232 split orig_ty ty args = (orig_ty, args)
236 ---------------------------------------------------------------------
241 mkFunTy :: Type -> Type -> Type
242 mkFunTy arg res = FunTy arg res
244 mkFunTys :: [Type] -> Type -> Type
245 mkFunTys tys ty = foldr FunTy ty tys
247 splitFunTy :: Type -> (Type, Type)
248 splitFunTy (FunTy arg res) = (arg, res)
249 splitFunTy (NoteTy _ ty) = splitFunTy ty
250 splitFunTy (PredTy p) = splitFunTy (predRepTy p)
252 splitFunTy_maybe :: Type -> Maybe (Type, Type)
253 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
254 splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
255 splitFunTy_maybe (PredTy p) = splitFunTy_maybe (predRepTy p)
256 splitFunTy_maybe other = Nothing
258 splitFunTys :: Type -> ([Type], Type)
259 splitFunTys ty = split [] ty ty
261 split args orig_ty (FunTy arg res) = split (arg:args) res res
262 split args orig_ty (NoteTy _ ty) = split args orig_ty ty
263 split args orig_ty (PredTy p) = split args orig_ty (predRepTy p)
264 split args orig_ty ty = (reverse args, orig_ty)
266 splitFunTysN :: String -> Int -> Type -> ([Type], Type)
267 splitFunTysN msg orig_n orig_ty = split orig_n [] orig_ty orig_ty
269 split 0 args syn_ty ty = (reverse args, syn_ty)
270 split n args syn_ty (FunTy arg res) = split (n-1) (arg:args) res res
271 split n args syn_ty (NoteTy _ ty) = split n args syn_ty ty
272 split n args syn_ty (PredTy p) = split n args syn_ty (predRepTy p)
273 split n args syn_ty ty = pprPanic ("splitFunTysN: " ++ msg) (int orig_n <+> pprType orig_ty)
275 zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
276 zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
278 split acc [] nty ty = (reverse acc, nty)
279 split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
280 split acc xs nty (NoteTy _ ty) = split acc xs nty ty
281 split acc xs nty (PredTy p) = split acc xs nty (predRepTy p)
282 split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty)
284 funResultTy :: Type -> Type
285 funResultTy (FunTy arg res) = res
286 funResultTy (NoteTy _ ty) = funResultTy ty
287 funResultTy (PredTy p) = funResultTy (predRepTy p)
288 funResultTy ty = pprPanic "funResultTy" (pprType ty)
290 funArgTy :: Type -> Type
291 funArgTy (FunTy arg res) = arg
292 funArgTy (NoteTy _ ty) = funArgTy ty
293 funArgTy (PredTy p) = funArgTy (predRepTy p)
294 funArgTy ty = pprPanic "funArgTy" (pprType ty)
298 ---------------------------------------------------------------------
303 mkTyConApp :: TyCon -> [Type] -> Type
305 | isFunTyCon tycon && length tys == 2
307 (ty1:ty2:_) -> FunTy ty1 ty2
310 = ASSERT(not (isSynTyCon tycon))
313 mkTyConTy :: TyCon -> Type
314 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
317 -- splitTyConApp "looks through" synonyms, because they don't
318 -- mean a distinct type, but all other type-constructor applications
319 -- including functions are returned as Just ..
321 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
322 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
323 splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
324 splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
325 splitTyConApp_maybe (PredTy p) = splitTyConApp_maybe (predRepTy p)
326 splitTyConApp_maybe other = Nothing
328 -- splitAlgTyConApp_maybe looks for
329 -- *saturated* applications of *algebraic* data types
330 -- "Algebraic" => newtype, data type, or dictionary (not function types)
331 -- We return the constructors too, so there had better be some.
333 splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon])
334 splitAlgTyConApp_maybe (TyConApp tc tys)
336 tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
337 splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
338 splitAlgTyConApp_maybe (PredTy p) = splitAlgTyConApp_maybe (predRepTy p)
339 splitAlgTyConApp_maybe other = Nothing
341 splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon])
342 -- Here the "algebraic" property is an *assertion*
343 splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
344 (tc, tys, tyConDataCons tc)
345 splitAlgTyConApp (NoteTy _ ty) = splitAlgTyConApp ty
346 splitAlgTyConApp (PredTy p) = splitAlgTyConApp (predRepTy p)
348 splitAlgTyConApp ty = pprPanic "splitAlgTyConApp" (pprType ty)
353 ---------------------------------------------------------------------
358 mkSynTy syn_tycon tys
359 = ASSERT( isSynTyCon syn_tycon )
360 ASSERT( isNotUsgTy body )
361 ASSERT( length tyvars == length tys )
362 NoteTy (SynNote (TyConApp syn_tycon tys))
363 (substTy (mkTyVarSubst tyvars tys) body)
365 (tyvars, body) = getSynTyConDefn syn_tycon
367 isSynTy (NoteTy (SynNote _) _) = True
368 isSynTy other = False
370 deNoteType :: Type -> Type
371 -- Remove synonyms, but not Preds
372 deNoteType ty@(TyVarTy tyvar) = ty
373 deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
374 deNoteType (PredTy p) = PredTy p
375 deNoteType (NoteTy _ ty) = deNoteType ty
376 deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg)
377 deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg)
378 deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty)
381 Notes on type synonyms
382 ~~~~~~~~~~~~~~~~~~~~~~
383 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
384 to return type synonyms whereever possible. Thus
389 splitFunTys (a -> Foo a) = ([a], Foo a)
392 The reason is that we then get better (shorter) type signatures in
393 interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
399 repType looks through
404 It's useful in the back end where we're not
405 interested in newtypes anymore.
408 repType :: Type -> Type
409 repType (ForAllTy _ ty) = repType ty
410 repType (NoteTy _ ty) = repType ty
411 repType (PredTy p) = repType (predRepTy p)
412 repType ty = case splitNewType_maybe ty of
413 Just ty' -> repType ty' -- Still re-apply repType in case of for-all
416 splitRepFunTys :: Type -> ([Type], Type)
417 -- Like splitFunTys, but looks through newtypes and for-alls
418 splitRepFunTys ty = split [] (repType ty)
420 split args (FunTy arg res) = split (arg:args) (repType res)
421 split args ty = (reverse args, ty)
423 typePrimRep :: Type -> PrimRep
424 typePrimRep ty = case repType ty of
425 TyConApp tc _ -> tyConPrimRep tc
427 AppTy _ _ -> PtrRep -- ??
430 splitNewType_maybe :: Type -> Maybe Type
431 -- Find the representation of a newtype, if it is one
432 -- Looks through multiple levels of newtype, but does not look through for-alls
433 splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty
434 splitNewType_maybe (PredTy p) = splitNewType_maybe (predRepTy p)
435 splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of
436 Just rep_ty -> ASSERT( length tys == tyConArity tc )
437 -- The assert should hold because repType should
438 -- only be applied to *types* (of kind *)
439 Just (applyTys rep_ty tys)
441 splitNewType_maybe other = Nothing
446 ---------------------------------------------------------------------
450 NB: Invariant: if present, usage note is at the very top of the type.
451 This should be carefully preserved.
453 In some parts of the compiler, comments use the _Once Upon a
454 Polymorphic Type_ (POPL'99) usage of "rho = generalised
455 usage-annotated type; sigma = usage-annotated type; tau =
456 usage-annotated type except on top"; unfortunately this conflicts with
457 the rho/tau/theta/sigma usage in the rest of the compiler. (KSW
461 mkUsgTy :: UsageAnn -> Type -> Type
463 mkUsgTy UsMany ty = ASSERT2( isNotUsgTy ty, pprType ty )
466 mkUsgTy usg ty = ASSERT2( isNotUsgTy ty, pprType ty )
467 NoteTy (UsgNote usg) ty
469 -- The isUsgTy function is utterly useless if UsManys are omitted.
470 -- Be warned! KSW 1999-04.
471 isUsgTy :: Type -> Bool
475 isUsgTy (NoteTy (UsgForAll _) ty) = isUsgTy ty
476 isUsgTy (NoteTy (UsgNote _) _ ) = True
477 isUsgTy other = False
480 -- The isNotUsgTy function may return a false True if UsManys are omitted;
481 -- in other words, A SSERT( isNotUsgTy ty ) may be useful but
482 -- A SSERT( not (isNotUsg ty) ) is asking for trouble. KSW 1999-04.
483 isNotUsgTy :: Type -> Bool
484 isNotUsgTy (NoteTy (UsgForAll _) _) = False
485 isNotUsgTy (NoteTy (UsgNote _) _) = False
486 isNotUsgTy other = True
488 -- splitUsgTy_maybe is not exported, since it is meaningless if
489 -- UsManys are omitted. It is used in several places in this module,
490 -- however. KSW 1999-04.
491 splitUsgTy_maybe :: Type -> Maybe (UsageAnn,Type)
492 splitUsgTy_maybe (NoteTy (UsgNote usg) ty2) = ASSERT( isNotUsgTy ty2 )
494 splitUsgTy_maybe ty@(NoteTy (UsgForAll _) _) = pprPanic "splitUsgTy_maybe:" $ pprType ty
495 splitUsgTy_maybe ty = Nothing
497 splitUsgTy :: Type -> (UsageAnn,Type)
498 splitUsgTy ty = case splitUsgTy_maybe ty of
504 pprPanic "splitUsgTy: no usage annot:" $ pprType ty
507 tyUsg :: Type -> UsageAnn
508 tyUsg = fst . splitUsgTy
510 unUsgTy :: Type -> Type
511 -- strip outer usage annotation if present
512 unUsgTy ty = case splitUsgTy_maybe ty of
513 Just (_,ty1) -> ASSERT2( isNotUsgTy ty1, pprType ty )
517 mkUsForAllTy :: UVar -> Type -> Type
518 mkUsForAllTy uv ty = NoteTy (UsgForAll uv) ty
520 mkUsForAllTys :: [UVar] -> Type -> Type
521 mkUsForAllTys uvs ty = foldr (NoteTy . UsgForAll) ty uvs
523 splitUsForAllTys :: Type -> ([UVar],Type)
524 splitUsForAllTys ty = split ty []
525 where split (NoteTy (UsgForAll u) ty) uvs = split ty (u:uvs)
526 split other_ty uvs = (reverse uvs, other_ty)
528 substUsTy :: VarEnv UsageAnn -> Type -> Type
529 -- assumes range is fresh uvars, so no conflicts
530 substUsTy ve (NoteTy note@(UsgNote (UsVar u))
531 ty ) = NoteTy (case lookupVarEnv ve u of
532 Just ua -> UsgNote ua
535 substUsTy ve (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote (substUsTy ve ty1)) (substUsTy ve ty2)
536 substUsTy ve (NoteTy note ty) = NoteTy note (substUsTy ve ty)
538 substUsTy ve (PredTy (Class c tys)) = PredTy (Class c (map (substUsTy ve) tys))
539 substUsTy ve (PredTy (IParam n ty)) = PredTy (IParam n (substUsTy ve ty))
540 substUsTy ve (TyVarTy tv) = TyVarTy tv
541 substUsTy ve (AppTy ty1 ty2) = AppTy (substUsTy ve ty1) (substUsTy ve ty2)
542 substUsTy ve (FunTy ty1 ty2) = FunTy (substUsTy ve ty1) (substUsTy ve ty2)
543 substUsTy ve (TyConApp tyc tys) = TyConApp tyc (map (substUsTy ve) tys)
544 substUsTy ve (ForAllTy yv ty ) = ForAllTy yv (substUsTy ve ty)
548 ---------------------------------------------------------------------
552 We need to be clever here with usage annotations; they need to be
553 lifted or lowered through the forall as appropriate.
556 mkForAllTy :: TyVar -> Type -> Type
557 mkForAllTy tyvar ty = case splitUsgTy_maybe ty of
558 Just (usg,ty') -> NoteTy (UsgNote usg)
560 Nothing -> ForAllTy tyvar ty
562 mkForAllTys :: [TyVar] -> Type -> Type
563 mkForAllTys tyvars ty = case splitUsgTy_maybe ty of
564 Just (usg,ty') -> NoteTy (UsgNote usg)
565 (foldr ForAllTy ty' tyvars)
566 Nothing -> foldr ForAllTy ty tyvars
568 splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
569 splitForAllTy_maybe ty = case splitUsgTy_maybe ty of
570 Just (usg,ty') -> do (tyvar,ty'') <- splitFAT_m ty'
571 return (tyvar, NoteTy (UsgNote usg) ty'')
572 Nothing -> splitFAT_m ty
574 splitFAT_m (NoteTy _ ty) = splitFAT_m ty
575 splitFAT_m (PredTy p) = splitFAT_m (predRepTy p)
576 splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
577 splitFAT_m _ = Nothing
579 splitForAllTys :: Type -> ([TyVar], Type)
580 splitForAllTys ty = case splitUsgTy_maybe ty of
581 Just (usg,ty') -> let (tvs,ty'') = split ty' ty' []
582 in (tvs, NoteTy (UsgNote usg) ty'')
583 Nothing -> split ty ty []
585 split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
586 split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
587 split orig_ty (PredTy p) tvs = split orig_ty (predRepTy p) tvs
588 split orig_ty t tvs = (reverse tvs, orig_ty)
591 -- (mkPiType now in CoreUtils)
593 Applying a for-all to its arguments
596 applyTy :: Type -> Type -> Type
597 applyTy (NoteTy note@(UsgNote _) fun) arg = NoteTy note (applyTy fun arg)
598 applyTy (NoteTy note@(UsgForAll _) fun) arg = NoteTy note (applyTy fun arg)
599 applyTy (PredTy p) arg = applyTy (predRepTy p) arg
600 applyTy (NoteTy _ fun) arg = applyTy fun arg
601 applyTy (ForAllTy tv ty) arg = ASSERT( isNotUsgTy arg )
602 substTy (mkTyVarSubst [tv] [arg]) ty
603 applyTy other arg = panic "applyTy"
605 applyTys :: Type -> [Type] -> Type
606 applyTys fun_ty arg_tys
607 = substTy (mkTyVarSubst tvs arg_tys) ty
609 (tvs, ty) = split fun_ty arg_tys
611 split fun_ty [] = ([], fun_ty)
612 split (NoteTy note@(UsgNote _) fun_ty)
613 args = case split fun_ty args of
614 (tvs, ty) -> (tvs, NoteTy note ty)
615 split (NoteTy note@(UsgForAll _) fun_ty)
616 args = case split fun_ty args of
617 (tvs, ty) -> (tvs, NoteTy note ty)
618 split (NoteTy _ fun_ty) args = split fun_ty args
619 split (PredTy p) args = split (predRepTy p) args
620 split (ForAllTy tv fun_ty) (arg:args) = ASSERT2( isNotUsgTy arg, vcat (map pprType arg_tys) $$
621 text "in application of" <+> pprType fun_ty)
622 case split fun_ty args of
623 (tvs, ty) -> (tv:tvs, ty)
624 split other_ty args = panic "applyTys"
627 Note that we allow applications to be of usage-annotated- types, as an
628 extension: we handle them by lifting the annotation outside. The
629 argument, however, must still be unannotated.
632 hoistForAllTys :: Type -> Type
633 -- Move all the foralls to the top
634 -- e.g. T -> forall a. a ==> forall a. T -> a
636 = case hoist ty of { (tvs, body) -> mkForAllTys tvs body }
638 hoist :: Type -> ([TyVar], Type)
639 hoist ty = case splitFunTys ty of { (args, res) ->
640 case splitForAllTys res of {
641 ([], body) -> ([], ty) ;
642 (tvs1, body1) -> case hoist body1 of { (tvs2,body2) ->
643 (tvs1 ++ tvs2, mkFunTys args body2)
648 %************************************************************************
650 \subsection{Stuff to do with the source-language types}
652 PredType and ThetaType are used in types for expressions and bindings.
653 ClassPred and ClassContext are used in class and instance declarations.
655 %************************************************************************
657 "Dictionary" types are just ordinary data types, but you can
658 tell from the type constructor whether it's a dictionary or not.
661 mkClassPred clas tys = Class clas tys
663 mkDictTy :: Class -> [Type] -> Type
664 mkDictTy clas tys = mkPredTy (Class clas tys)
666 mkDictTys :: ClassContext -> [Type]
667 mkDictTys cxt = [mkDictTy cls tys | (cls,tys) <- cxt]
669 mkPredTy :: PredType -> Type
670 mkPredTy pred = PredTy pred
672 predRepTy :: PredType -> Type
673 -- Convert a predicate to its "representation type";
674 -- the type of evidence for that predicate, which is actually passed at runtime
675 predRepTy (Class clas tys) = TyConApp (classTyCon clas) tys
676 predRepTy (IParam n ty) = ty
678 isPredTy :: Type -> Bool
679 isPredTy (NoteTy _ ty) = isPredTy ty
680 isPredTy (PredTy _) = True
683 isDictTy :: Type -> Bool
684 isDictTy (NoteTy _ ty) = isDictTy ty
685 isDictTy (PredTy (Class _ _)) = True
686 isDictTy other = False
688 splitPredTy_maybe :: Type -> Maybe PredType
689 splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty
690 splitPredTy_maybe (PredTy p) = Just p
691 splitPredTy_maybe other = Nothing
693 splitDictTy_maybe :: Type -> Maybe (Class, [Type])
694 splitDictTy_maybe ty = case splitPredTy_maybe ty of
695 Just p -> getClassTys_maybe p
698 getClassTys_maybe :: PredType -> Maybe ClassPred
699 getClassTys_maybe (Class clas tys) = Just (clas, tys)
700 getClassTys_maybe _ = Nothing
702 ipName_maybe :: PredType -> Maybe Name
703 ipName_maybe (IParam n _) = Just n
704 ipName_maybe _ = Nothing
706 classesToPreds :: ClassContext -> ThetaType
707 classesToPreds cts = map (uncurry Class) cts
709 classesOfPreds :: ThetaType -> ClassContext
710 classesOfPreds theta = [(clas,tys) | Class clas tys <- theta]
713 @isTauTy@ tests for nested for-alls.
716 isTauTy :: Type -> Bool
717 isTauTy (TyVarTy v) = True
718 isTauTy (TyConApp _ tys) = all isTauTy tys
719 isTauTy (AppTy a b) = isTauTy a && isTauTy b
720 isTauTy (FunTy a b) = isTauTy a && isTauTy b
721 isTauTy (PredTy p) = isTauTy (predRepTy p)
722 isTauTy (NoteTy _ ty) = isTauTy ty
723 isTauTy other = False
727 mkRhoTy :: [PredType] -> Type -> Type
728 mkRhoTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
730 splitRhoTy :: Type -> ([PredType], Type)
731 splitRhoTy ty = split ty ty []
733 split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of
734 Just p -> split res res (p:ts)
735 Nothing -> (reverse ts, orig_ty)
736 split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts
737 split orig_ty ty ts = (reverse ts, orig_ty)
740 isSigmaType returns true of any qualified type. It doesn't *necessarily* have
742 f :: (?x::Int) => Int -> Int
745 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
747 isSigmaTy :: Type -> Bool
748 isSigmaTy (ForAllTy tyvar ty) = True
749 isSigmaTy (FunTy a b) = isPredTy a
750 isSigmaTy (NoteTy _ ty) = isSigmaTy ty
753 splitSigmaTy :: Type -> ([TyVar], [PredType], Type)
757 (tyvars,rho) = splitForAllTys ty
758 (theta,tau) = splitRhoTy rho
762 getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
763 -- construct a dictionary function name
764 getDFunTyKey (TyVarTy tv) = getOccName tv
765 getDFunTyKey (TyConApp tc _) = getOccName tc
766 getDFunTyKey (AppTy fun _) = getDFunTyKey fun
767 getDFunTyKey (NoteTy _ t) = getDFunTyKey t
768 getDFunTyKey (FunTy arg _) = getOccName funTyCon
769 getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
770 -- PredTy shouldn't happen
774 %************************************************************************
776 \subsection{Kinds and free variables}
778 %************************************************************************
780 ---------------------------------------------------------------------
781 Finding the kind of a type
782 ~~~~~~~~~~~~~~~~~~~~~~~~~~
784 typeKind :: Type -> Kind
786 typeKind (TyVarTy tyvar) = tyVarKind tyvar
787 typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
788 typeKind (NoteTy _ ty) = typeKind ty
789 typeKind (PredTy _) = boxedTypeKind -- Predicates are always
790 -- represented by boxed types
791 typeKind (AppTy fun arg) = funResultTy (typeKind fun)
793 typeKind (FunTy arg res) = fix_up (typeKind res)
795 fix_up (TyConApp tycon _) | tycon == typeCon
796 || tycon == openKindCon = boxedTypeKind
797 fix_up (NoteTy _ kind) = fix_up kind
799 -- The basic story is
800 -- typeKind (FunTy arg res) = typeKind res
801 -- But a function is boxed regardless of its result type
802 -- Hence the strange fix-up.
803 -- Note that 'res', being the result of a FunTy, can't have
804 -- a strange kind like (*->*).
806 typeKind (ForAllTy tv ty) = typeKind ty
810 ---------------------------------------------------------------------
811 Free variables of a type
812 ~~~~~~~~~~~~~~~~~~~~~~~~
814 tyVarsOfType :: Type -> TyVarSet
816 tyVarsOfType (TyVarTy tv) = unitVarSet tv
817 tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
818 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
819 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
820 tyVarsOfType (NoteTy (UsgNote _) ty) = tyVarsOfType ty
821 tyVarsOfType (NoteTy (UsgForAll _) ty) = tyVarsOfType ty
822 tyVarsOfType (PredTy p) = tyVarsOfPred p
823 tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
824 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
825 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
827 tyVarsOfTypes :: [Type] -> TyVarSet
828 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
830 tyVarsOfPred :: PredType -> TyVarSet
831 tyVarsOfPred (Class clas tys) = tyVarsOfTypes tys
832 tyVarsOfPred (IParam n ty) = tyVarsOfType ty
834 tyVarsOfTheta :: ThetaType -> TyVarSet
835 tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
837 -- Add a Note with the free tyvars to the top of the type
838 -- (but under a usage if there is one)
839 addFreeTyVars :: Type -> Type
840 addFreeTyVars (NoteTy note@(UsgNote _) ty) = NoteTy note (addFreeTyVars ty)
841 addFreeTyVars (NoteTy note@(UsgForAll _) ty) = NoteTy note (addFreeTyVars ty)
842 addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
843 addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
845 -- Find the free names of a type, including the type constructors and classes it mentions
846 namesOfType :: Type -> NameSet
847 namesOfType (TyVarTy tv) = unitNameSet (getName tv)
848 namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets`
850 namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1
851 namesOfType (NoteTy other_note ty2) = namesOfType ty2
852 namesOfType (PredTy p) = namesOfType (predRepTy p)
853 namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
854 namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
855 namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
857 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
861 %************************************************************************
863 \subsection{TidyType}
865 %************************************************************************
867 tidyTy tidies up a type for printing in an error message, or in
870 It doesn't change the uniques at all, just the print names.
873 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
874 tidyTyVar env@(tidy_env, subst) tyvar
875 = case lookupVarEnv subst tyvar of
877 Just tyvar' -> -- Already substituted
880 Nothing -> -- Make a new nice name for it
882 case tidyOccName tidy_env (getOccName name) of
883 (tidy', occ') -> -- New occname reqd
884 ((tidy', subst'), tyvar')
886 subst' = extendVarEnv subst tyvar tyvar'
887 tyvar' = setTyVarName tyvar name'
888 name' = mkLocalName (getUnique name) occ' noSrcLoc
889 -- Note: make a *user* tyvar, so it printes nicely
890 -- Could extract src loc, but no need.
892 name = tyVarName tyvar
894 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
896 tidyType :: TidyEnv -> Type -> Type
897 tidyType env@(tidy_env, subst) ty
900 go (TyVarTy tv) = case lookupVarEnv subst tv of
901 Nothing -> TyVarTy tv
902 Just tv' -> TyVarTy tv'
903 go (TyConApp tycon tys) = let args = map go tys
904 in args `seqList` TyConApp tycon args
905 go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
906 go (PredTy p) = PredTy (go_pred p)
907 go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
908 go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
909 go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty)
911 (envp, tvp) = tidyTyVar env tv
913 go_note (SynNote ty) = SynNote SAPPLY (go ty)
914 go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
915 go_note note@(UsgNote _) = note -- Usage annotation is already tidy
916 go_note note@(UsgForAll _) = note -- Uvar binder is already tidy
918 go_pred (Class c tys) = Class c (tidyTypes env tys)
919 go_pred (IParam n ty) = IParam n (go ty)
921 tidyTypes env tys = map (tidyType env) tys
925 @tidyOpenType@ grabs the free type variables, tidies them
926 and then uses @tidyType@ to work over the type itself
929 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
931 = (env', tidyType env' ty)
933 env' = foldl go env (varSetElems (tyVarsOfType ty))
934 go env tyvar = fst (tidyTyVar env tyvar)
936 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
937 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
939 tidyTopType :: Type -> Type
940 tidyTopType ty = tidyType emptyTidyEnv ty
945 %************************************************************************
947 \subsection{Boxedness and liftedness}
949 %************************************************************************
952 isUnboxedType :: Type -> Bool
953 isUnboxedType ty = not (isFollowableRep (typePrimRep ty))
955 isUnLiftedType :: Type -> Bool
956 -- isUnLiftedType returns True for forall'd unlifted types:
957 -- x :: forall a. Int#
958 -- I found bindings like these were getting floated to the top level.
959 -- They are pretty bogus types, mind you. It would be better never to
962 isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
963 isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty
964 isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
965 isUnLiftedType other = False
967 isUnboxedTupleType :: Type -> Bool
968 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
969 Just (tc, ty_args) -> isUnboxedTupleTyCon tc
972 -- Should only be applied to *types*; hence the assert
973 isAlgType :: Type -> Bool
974 isAlgType ty = case splitTyConApp_maybe ty of
975 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
979 -- Should only be applied to *types*; hence the assert
980 isDataType :: Type -> Bool
981 isDataType ty = case splitTyConApp_maybe ty of
982 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
986 isNewType :: Type -> Bool
987 isNewType ty = case splitTyConApp_maybe ty of
988 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
994 %************************************************************************
996 \subsection{Sequencing on types
998 %************************************************************************
1001 seqType :: Type -> ()
1002 seqType (TyVarTy tv) = tv `seq` ()
1003 seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
1004 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
1005 seqType (NoteTy note t2) = seqNote note `seq` seqType t2
1006 seqType (PredTy p) = seqPred p
1007 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
1008 seqType (ForAllTy tv ty) = tv `seq` seqType ty
1010 seqTypes :: [Type] -> ()
1012 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
1014 seqNote :: TyNote -> ()
1015 seqNote (SynNote ty) = seqType ty
1016 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
1017 seqNote (UsgNote usg) = usg `seq` ()
1019 seqPred :: PredType -> ()
1020 seqPred (Class c tys) = c `seq` seqTypes tys
1021 seqPred (IParam n ty) = n `seq` seqType ty
1025 %************************************************************************
1027 \subsection{Equality on types}
1029 %************************************************************************
1032 For the moment at least, type comparisons don't work if
1033 there are embedded for-alls.
1036 instance Eq Type where
1037 ty1 == ty2 = case ty1 `compare` ty2 of { EQ -> True; other -> False }
1039 instance Ord Type where
1040 compare ty1 ty2 = cmpTy emptyVarEnv ty1 ty2
1042 cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
1043 -- The "env" maps type variables in ty1 to type variables in ty2
1044 -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
1045 -- we in effect substitute tv2 for tv1 in t1 before continuing
1047 -- Get rid of NoteTy
1048 cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
1049 cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
1051 -- Get rid of PredTy
1052 cmpTy env (PredTy p1) (PredTy p2) = cmpPred env p1 p2
1053 cmpTy env (PredTy p1) ty2 = cmpTy env (predRepTy p1) ty2
1054 cmpTy env ty1 (PredTy p2) = cmpTy env ty1 (predRepTy p2)
1056 -- Deal with equal constructors
1057 cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
1058 Just tv1a -> tv1a `compare` tv2
1059 Nothing -> tv1 `compare` tv2
1061 cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1062 cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1063 cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
1064 cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2
1066 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
1067 cmpTy env (AppTy _ _) (TyVarTy _) = GT
1069 cmpTy env (FunTy _ _) (TyVarTy _) = GT
1070 cmpTy env (FunTy _ _) (AppTy _ _) = GT
1072 cmpTy env (TyConApp _ _) (TyVarTy _) = GT
1073 cmpTy env (TyConApp _ _) (AppTy _ _) = GT
1074 cmpTy env (TyConApp _ _) (FunTy _ _) = GT
1076 cmpTy env (ForAllTy _ _) other = GT
1081 cmpTys env [] [] = EQ
1082 cmpTys env (t:ts) [] = GT
1083 cmpTys env [] (t:ts) = LT
1084 cmpTys env (t1:t1s) (t2:t2s) = cmpTy env t1 t2 `thenCmp` cmpTys env t1s t2s
1088 instance Eq PredType where
1089 p1 == p2 = case p1 `compare` p2 of { EQ -> True; other -> False }
1091 instance Ord PredType where
1092 compare p1 p2 = cmpPred emptyVarEnv p1 p2
1094 cmpPred :: TyVarEnv TyVar -> PredType -> PredType -> Ordering
1095 cmpPred env (IParam n1 t) (IParam n2 t2) = n1 `compare` n2
1096 -- Just compare the names!
1097 cmpPred env (Class c1 tys1) (Class c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
1098 cmpPred env (IParam _ _) (Class _ _) = LT
1099 cmpPred env (Class _ _) (IParam _ _) = GT