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 usageKindCon, -- :: KX
22 usageTypeKind, -- :: KX
23 usOnceTyCon, usManyTyCon, -- :: $
24 usOnce, usMany, -- :: $
26 -- exports from this module:
27 hasMoreBoxityInfo, defaultKind,
29 mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
31 mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
33 mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, splitFunTysN,
34 funResultTy, funArgTy, zipFunTys,
36 mkTyConApp, mkTyConTy,
37 tyConAppTyCon, tyConAppArgs,
38 splitTyConApp_maybe, splitTyConApp,
39 splitAlgTyConApp_maybe, splitAlgTyConApp,
41 mkUTy, splitUTy, splitUTy_maybe,
42 isUTy, uaUTy, unUTy, liftUTy, mkUTyM,
43 isUsageKind, isUsage, isUTyVar,
45 -- Predicates and the like
46 mkDictTy, mkDictTys, mkPredTy, splitPredTy_maybe,
47 splitDictTy, splitDictTy_maybe, isDictTy, predRepTy, splitDFunTy,
51 repType, splitRepFunTys, splitNewType_maybe, typePrimRep,
53 mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
54 applyTy, applyTys, hoistForAllTys, isForAllTy,
56 TauType, RhoType, SigmaType, PredType(..), ThetaType,
57 ClassPred, ClassContext, mkClassPred,
58 getClassTys_maybe, ipName_maybe, classesOfPreds,
59 isTauTy, mkRhoTy, splitRhoTy,
60 mkSigmaTy, isSigmaTy, splitSigmaTy,
64 isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
67 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
68 namesOfType, usageAnnOfType, typeKind, addFreeTyVars,
70 -- Tidying up for printing
72 tidyOpenType, tidyOpenTypes,
73 tidyTyVar, tidyTyVars,
81 #include "HsVersions.h"
83 -- We import the representation and primitive functions from TypeRep.
84 -- Many things are reexported, but not the representation!
90 import {-# SOURCE #-} DataCon( DataCon )
91 import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
92 import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy )
95 import Var ( Var, TyVar, tyVarKind, tyVarName, setTyVarName )
99 import Name ( Name, NamedThing(..), OccName, mkLocalName, tidyOccName )
101 import Class ( classTyCon, Class, ClassPred, ClassContext )
102 import TyCon ( TyCon,
103 isUnboxedTupleTyCon, isUnLiftedTyCon,
104 isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep,
105 isAlgTyCon, isSynTyCon, tyConArity,
106 tyConKind, tyConDataCons, getSynTyConDefn,
111 import Maybes ( maybeToBool )
112 import SrcLoc ( noSrcLoc )
113 import PrimRep ( PrimRep(..), isFollowableRep )
114 import Unique ( Uniquable(..) )
115 import Util ( mapAccumL, seqList, thenCmp )
117 import UniqSet ( sizeUniqSet ) -- Should come via VarSet
121 %************************************************************************
123 \subsection{Stuff to do with kinds.}
125 %************************************************************************
128 hasMoreBoxityInfo :: Kind -> Kind -> Bool
129 hasMoreBoxityInfo k1 k2
130 | k2 == openTypeKind = True
131 | otherwise = k1 == k2
133 defaultKind :: Kind -> Kind
134 -- Used when generalising: default kind '?' to '*'
135 defaultKind kind | kind == openTypeKind = boxedTypeKind
140 %************************************************************************
142 \subsection{Constructor-specific functions}
144 %************************************************************************
147 ---------------------------------------------------------------------
151 mkTyVarTy :: TyVar -> Type
154 mkTyVarTys :: [TyVar] -> [Type]
155 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
157 getTyVar :: String -> Type -> TyVar
158 getTyVar msg (TyVarTy tv) = tv
159 getTyVar msg (PredTy p) = getTyVar msg (predRepTy p)
160 getTyVar msg (NoteTy _ t) = getTyVar msg t
161 getTyVar msg ty@(UsageTy _ _) = pprPanic "getTyVar: UTy:" (text msg $$ pprType ty)
162 getTyVar msg other = panic ("getTyVar: " ++ msg)
164 getTyVar_maybe :: Type -> Maybe TyVar
165 getTyVar_maybe (TyVarTy tv) = Just tv
166 getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
167 getTyVar_maybe (PredTy p) = getTyVar_maybe (predRepTy p)
168 getTyVar_maybe ty@(UsageTy _ _) = pprPanic "getTyVar_maybe: UTy:" (pprType ty)
169 getTyVar_maybe other = Nothing
171 isTyVarTy :: Type -> Bool
172 isTyVarTy (TyVarTy tv) = True
173 isTyVarTy (NoteTy _ ty) = isTyVarTy ty
174 isTyVarTy (PredTy p) = isTyVarTy (predRepTy p)
175 isTyVarTy ty@(UsageTy _ _) = pprPanic "isTyVarTy: UTy:" (pprType ty)
176 isTyVarTy other = False
180 ---------------------------------------------------------------------
183 We need to be pretty careful with AppTy to make sure we obey the
184 invariant that a TyConApp is always visibly so. mkAppTy maintains the
188 mkAppTy orig_ty1 orig_ty2
189 = ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind *
190 UASSERT2( not (isUTy orig_ty2), pprType orig_ty1 <+> pprType orig_ty2 )
191 -- argument must be unannotated
194 mk_app (NoteTy _ ty1) = mk_app ty1
195 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
196 mk_app ty@(UsageTy _ _) = pprPanic "mkAppTy: UTy:" (pprType ty)
197 mk_app ty1 = AppTy orig_ty1 orig_ty2
199 mkAppTys :: Type -> [Type] -> Type
200 mkAppTys orig_ty1 [] = orig_ty1
201 -- This check for an empty list of type arguments
202 -- avoids the needless loss of a type synonym constructor.
203 -- For example: mkAppTys Rational []
204 -- returns to (Ratio Integer), which has needlessly lost
205 -- the Rational part.
206 mkAppTys orig_ty1 orig_tys2
207 = ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind *
208 UASSERT2( not (any isUTy orig_tys2), pprType orig_ty1 <+> fsep (map pprType orig_tys2) )
209 -- arguments must be unannotated
212 mk_app (NoteTy _ ty1) = mk_app ty1
213 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
214 mk_app ty@(UsageTy _ _) = pprPanic "mkAppTys: UTy:" (pprType ty)
215 mk_app ty1 = foldl AppTy orig_ty1 orig_tys2
217 splitAppTy_maybe :: Type -> Maybe (Type, Type)
218 splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [unUTy ty1], unUTy ty2)
219 splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
220 splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty
221 splitAppTy_maybe (PredTy p) = splitAppTy_maybe (predRepTy p)
222 splitAppTy_maybe (TyConApp tc []) = Nothing
223 splitAppTy_maybe (TyConApp tc tys) = split tys []
225 split [ty2] acc = Just (TyConApp tc (reverse acc), ty2)
226 split (ty:tys) acc = split tys (ty:acc)
228 splitAppTy_maybe ty@(UsageTy _ _) = pprPanic "splitAppTy_maybe: UTy:" (pprType ty)
229 splitAppTy_maybe other = Nothing
231 splitAppTy :: Type -> (Type, Type)
232 splitAppTy ty = case splitAppTy_maybe ty of
234 Nothing -> panic "splitAppTy"
236 splitAppTys :: Type -> (Type, [Type])
237 splitAppTys ty = split ty ty []
239 split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
240 split orig_ty (NoteTy _ ty) args = split orig_ty ty args
241 split orig_ty (PredTy p) args = split orig_ty (predRepTy p) args
242 split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
243 (TyConApp funTyCon [], [unUTy ty1,unUTy ty2])
244 split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
245 split orig_ty (UsageTy _ _) args = pprPanic "splitAppTys: UTy:" (pprType orig_ty)
246 split orig_ty ty args = (orig_ty, args)
250 ---------------------------------------------------------------------
255 mkFunTy :: Type -> Type -> Type
256 mkFunTy arg res = UASSERT2( isUTy arg && isUTy res, pprType arg <+> pprType res )
259 mkFunTys :: [Type] -> Type -> Type
260 mkFunTys tys ty = UASSERT2( all isUTy (ty:tys), fsep (map pprType (tys++[ty])) )
263 splitFunTy :: Type -> (Type, Type)
264 splitFunTy (FunTy arg res) = (arg, res)
265 splitFunTy (NoteTy _ ty) = splitFunTy ty
266 splitFunTy (PredTy p) = splitFunTy (predRepTy p)
267 splitFunTy ty@(UsageTy _ _) = pprPanic "splitFunTy: UTy:" (pprType ty)
269 splitFunTy_maybe :: Type -> Maybe (Type, Type)
270 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
271 splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
272 splitFunTy_maybe (PredTy p) = splitFunTy_maybe (predRepTy p)
273 splitFunTy_maybe ty@(UsageTy _ _) = pprPanic "splitFunTy_maybe: UTy:" (pprType ty)
274 splitFunTy_maybe other = Nothing
276 splitFunTys :: Type -> ([Type], Type)
277 splitFunTys ty = split [] ty ty
279 split args orig_ty (FunTy arg res) = split (arg:args) res res
280 split args orig_ty (NoteTy _ ty) = split args orig_ty ty
281 split args orig_ty (PredTy p) = split args orig_ty (predRepTy p)
282 split args orig_ty (UsageTy _ _) = pprPanic "splitFunTys: UTy:" (pprType orig_ty)
283 split args orig_ty ty = (reverse args, orig_ty)
285 splitFunTysN :: String -> Int -> Type -> ([Type], Type)
286 splitFunTysN msg orig_n orig_ty = split orig_n [] orig_ty orig_ty
288 split 0 args syn_ty ty = (reverse args, syn_ty)
289 split n args syn_ty (FunTy arg res) = split (n-1) (arg:args) res res
290 split n args syn_ty (NoteTy _ ty) = split n args syn_ty ty
291 split n args syn_ty (PredTy p) = split n args syn_ty (predRepTy p)
292 split n args syn_ty (UsageTy _ _) = pprPanic "splitFunTysN: UTy:" (pprType orig_ty)
293 split n args syn_ty ty = pprPanic ("splitFunTysN: " ++ msg) (int orig_n <+> pprType orig_ty)
295 zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
296 zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
298 split acc [] nty ty = (reverse acc, nty)
299 split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
300 split acc xs nty (NoteTy _ ty) = split acc xs nty ty
301 split acc xs nty (PredTy p) = split acc xs nty (predRepTy p)
302 split acc xs nty (UsageTy _ _) = pprPanic "zipFunTys: UTy:" (ppr orig_xs <+> pprType orig_ty)
303 split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty)
305 funResultTy :: Type -> Type
306 funResultTy (FunTy arg res) = res
307 funResultTy (NoteTy _ ty) = funResultTy ty
308 funResultTy (PredTy p) = funResultTy (predRepTy p)
309 funResultTy (UsageTy _ ty) = funResultTy ty
310 funResultTy ty = pprPanic "funResultTy" (pprType ty)
312 funArgTy :: Type -> Type
313 funArgTy (FunTy arg res) = arg
314 funArgTy (NoteTy _ ty) = funArgTy ty
315 funArgTy (PredTy p) = funArgTy (predRepTy p)
316 funArgTy (UsageTy _ ty) = funArgTy ty
317 funArgTy ty = pprPanic "funArgTy" (pprType ty)
321 ---------------------------------------------------------------------
326 mkTyConApp :: TyCon -> [Type] -> Type
328 | isFunTyCon tycon && length tys == 2
330 (ty1:ty2:_) -> FunTy (mkUTyM ty1) (mkUTyM ty2)
333 = ASSERT(not (isSynTyCon tycon))
334 UASSERT2( not (any isUTy tys), ppr tycon <+> fsep (map pprType tys) )
337 mkTyConTy :: TyCon -> Type
338 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
341 -- splitTyConApp "looks through" synonyms, because they don't
342 -- mean a distinct type, but all other type-constructor applications
343 -- including functions are returned as Just ..
345 tyConAppTyCon :: Type -> TyCon
346 tyConAppTyCon ty = case splitTyConApp_maybe ty of
348 Nothing -> pprPanic "tyConAppTyCon" (pprType ty)
350 tyConAppArgs :: Type -> [Type]
351 tyConAppArgs ty = case splitTyConApp_maybe ty of
352 Just (_,args) -> args
353 Nothing -> pprPanic "tyConAppArgs" (pprType ty)
355 splitTyConApp :: Type -> (TyCon, [Type])
356 splitTyConApp ty = case splitTyConApp_maybe ty of
358 Nothing -> pprPanic "splitTyConApp" (pprType ty)
360 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
361 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
362 splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [unUTy arg,unUTy res])
363 splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
364 splitTyConApp_maybe (PredTy p) = splitTyConApp_maybe (predRepTy p)
365 splitTyConApp_maybe (UsageTy _ ty) = splitTyConApp_maybe ty
366 splitTyConApp_maybe other = Nothing
368 -- splitAlgTyConApp_maybe looks for
369 -- *saturated* applications of *algebraic* data types
370 -- "Algebraic" => newtype, data type, or dictionary (not function types)
371 -- We return the constructors too, so there had better be some.
373 splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon])
374 splitAlgTyConApp_maybe (TyConApp tc tys)
376 tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
377 splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
378 splitAlgTyConApp_maybe (PredTy p) = splitAlgTyConApp_maybe (predRepTy p)
379 splitAlgTyConApp_maybe (UsageTy _ ty)= splitAlgTyConApp_maybe ty
380 splitAlgTyConApp_maybe other = Nothing
382 splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon])
383 -- Here the "algebraic" property is an *assertion*
384 splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
385 (tc, tys, tyConDataCons tc)
386 splitAlgTyConApp (NoteTy _ ty) = splitAlgTyConApp ty
387 splitAlgTyConApp (PredTy p) = splitAlgTyConApp (predRepTy p)
388 splitAlgTyConApp (UsageTy _ ty) = splitAlgTyConApp ty
390 splitAlgTyConApp ty = pprPanic "splitAlgTyConApp" (pprType ty)
395 ---------------------------------------------------------------------
400 mkSynTy syn_tycon tys
401 = ASSERT( isSynTyCon syn_tycon )
402 ASSERT( length tyvars == length tys )
403 NoteTy (SynNote (TyConApp syn_tycon tys))
404 (substTy (mkTyVarSubst tyvars tys) body)
406 (tyvars, body) = getSynTyConDefn syn_tycon
408 deNoteType :: Type -> Type
409 -- Remove synonyms, but not Preds
410 deNoteType ty@(TyVarTy tyvar) = ty
411 deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
412 deNoteType (PredTy p) = PredTy (deNotePred p)
413 deNoteType (NoteTy _ ty) = deNoteType ty
414 deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg)
415 deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg)
416 deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty)
417 deNoteType (UsageTy u ty) = UsageTy u (deNoteType ty)
419 deNotePred :: PredType -> PredType
420 deNotePred (Class c tys) = Class c (map deNoteType tys)
421 deNotePred (IParam n ty) = IParam n (deNoteType ty)
424 Notes on type synonyms
425 ~~~~~~~~~~~~~~~~~~~~~~
426 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
427 to return type synonyms whereever possible. Thus
432 splitFunTys (a -> Foo a) = ([a], Foo a)
435 The reason is that we then get better (shorter) type signatures in
436 interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
442 repType looks through
447 (e) usage annotations
448 It's useful in the back end where we're not
449 interested in newtypes anymore.
452 repType :: Type -> Type
453 repType (ForAllTy _ ty) = repType ty
454 repType (NoteTy _ ty) = repType ty
455 repType (PredTy p) = repType (predRepTy p)
456 repType (UsageTy _ ty) = repType ty
457 repType ty = case splitNewType_maybe ty of
458 Just ty' -> repType ty' -- Still re-apply repType in case of for-all
461 splitRepFunTys :: Type -> ([Type], Type)
462 -- Like splitFunTys, but looks through newtypes and for-alls
463 splitRepFunTys ty = split [] (repType ty)
465 split args (FunTy arg res) = split (arg:args) (repType res)
466 split args ty = (reverse args, ty)
468 typePrimRep :: Type -> PrimRep
469 typePrimRep ty = case repType ty of
470 TyConApp tc _ -> tyConPrimRep tc
472 AppTy _ _ -> PtrRep -- ??
475 splitNewType_maybe :: Type -> Maybe Type
476 -- Find the representation of a newtype, if it is one
477 -- Looks through multiple levels of newtype, but does not look through for-alls
478 splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty
479 splitNewType_maybe (PredTy p) = splitNewType_maybe (predRepTy p)
480 splitNewType_maybe (UsageTy _ ty) = splitNewType_maybe ty
481 splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of
482 Just rep_ty -> ASSERT( length tys == tyConArity tc )
483 -- The assert should hold because repType should
484 -- only be applied to *types* (of kind *)
485 Just (applyTys rep_ty tys)
487 splitNewType_maybe other = Nothing
492 ---------------------------------------------------------------------
497 mkForAllTy :: TyVar -> Type -> Type
499 = mkForAllTys [tyvar] ty
501 mkForAllTys :: [TyVar] -> Type -> Type
502 mkForAllTys tyvars ty
503 = case splitUTy_maybe ty of
504 Just (u,ty1) -> UASSERT2( not (mkVarSet tyvars `intersectsVarSet` tyVarsOfType u),
505 ptext SLIT("mkForAllTys: usage scope")
506 <+> ppr tyvars <+> pprType ty )
507 mkUTy u (foldr ForAllTy ty1 tyvars) -- we lift usage annotations over foralls
508 Nothing -> foldr ForAllTy ty tyvars
510 isForAllTy :: Type -> Bool
511 isForAllTy (NoteTy _ ty) = isForAllTy ty
512 isForAllTy (ForAllTy _ _) = True
513 isForAllTy (UsageTy _ ty) = isForAllTy ty
514 isForAllTy other_ty = False
516 splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
517 splitForAllTy_maybe ty = splitFAT_m ty
519 splitFAT_m (NoteTy _ ty) = splitFAT_m ty
520 splitFAT_m (PredTy p) = splitFAT_m (predRepTy p)
521 splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
522 splitFAT_m (UsageTy _ ty) = splitFAT_m ty
523 splitFAT_m _ = Nothing
525 splitForAllTys :: Type -> ([TyVar], Type)
526 splitForAllTys ty = split ty ty []
528 split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
529 split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
530 split orig_ty (PredTy p) tvs = split orig_ty (predRepTy p) tvs
531 split orig_ty (UsageTy _ ty) tvs = split orig_ty ty tvs
532 split orig_ty t tvs = (reverse tvs, orig_ty)
535 -- (mkPiType now in CoreUtils)
537 Applying a for-all to its arguments. Lift usage annotation as required.
540 applyTy :: Type -> Type -> Type
541 applyTy (PredTy p) arg = applyTy (predRepTy p) arg
542 applyTy (NoteTy _ fun) arg = applyTy fun arg
543 applyTy (ForAllTy tv ty) arg = UASSERT2( not (isUTy arg),
544 ptext SLIT("applyTy")
545 <+> pprType ty <+> pprType arg )
546 substTy (mkTyVarSubst [tv] [arg]) ty
547 applyTy (UsageTy u ty) arg = UsageTy u (applyTy ty arg)
548 applyTy other arg = panic "applyTy"
550 applyTys :: Type -> [Type] -> Type
551 applyTys fun_ty arg_tys
552 = UASSERT2( not (any isUTy arg_tys), ptext SLIT("applyTys") <+> pprType fun_ty )
556 substTy (mkTyVarSubst tvs arg_tys) ty
558 (mu, tvs, ty) = split fun_ty arg_tys
560 split fun_ty [] = (Nothing, [], fun_ty)
561 split (NoteTy _ fun_ty) args = split fun_ty args
562 split (PredTy p) args = split (predRepTy p) args
563 split (ForAllTy tv fun_ty) (arg:args) = case split fun_ty args of
564 (mu, tvs, ty) -> (mu, tv:tvs, ty)
565 split (UsageTy u ty) args = case split ty args of
566 (Nothing, tvs, ty) -> (Just u, tvs, ty)
567 (Just _ , _ , _ ) -> pprPanic "applyTys:"
569 split other_ty args = panic "applyTys"
573 hoistForAllTys :: Type -> Type
574 -- Move all the foralls to the top
575 -- e.g. T -> forall a. a ==> forall a. T -> a
576 -- Careful: LOSES USAGE ANNOTATIONS!
578 = case hoist ty of { (tvs, body) -> mkForAllTys tvs body }
580 hoist :: Type -> ([TyVar], Type)
581 hoist ty = case splitFunTys ty of { (args, res) ->
582 case splitForAllTys res of {
583 ([], body) -> ([], ty) ;
584 (tvs1, body1) -> case hoist body1 of { (tvs2,body2) ->
585 (tvs1 ++ tvs2, mkFunTys args body2)
590 ---------------------------------------------------------------------
594 Constructing and taking apart usage types.
597 mkUTy :: Type -> Type -> Type
599 = ASSERT2( typeKind u == usageTypeKind, ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
600 UASSERT2( not (isUTy ty), ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty )
601 -- if u == usMany then ty else : ToDo? KSW 2000-10
608 splitUTy :: Type -> (Type {- :: $ -}, Type)
610 = case splitUTy_maybe orig_ty of
611 Just (u,ty) -> (u,ty)
613 Nothing -> pprPanic "splitUTy:" (pprType orig_ty)
615 Nothing -> (usMany,orig_ty) -- default annotation ToDo KSW 2000-10
618 splitUTy_maybe :: Type -> Maybe (Type {- :: $ -}, Type)
619 splitUTy_maybe (UsageTy u ty) = Just (u,ty)
620 splitUTy_maybe (NoteTy _ ty) = splitUTy_maybe ty
621 splitUTy_maybe other_ty = Nothing
623 isUTy :: Type -> Bool
624 -- has usage annotation
625 isUTy = maybeToBool . splitUTy_maybe
627 uaUTy :: Type -> Type
628 -- extract annotation
629 uaUTy = fst . splitUTy
631 unUTy :: Type -> Type
632 -- extract unannotated type
633 unUTy = snd . splitUTy
637 liftUTy :: (Type -> Type) -> Type -> Type
638 -- lift outer usage annot over operation on unannotated types
641 (u,ty') = splitUTy ty
647 mkUTyM :: Type -> Type
648 -- put TOP (no info) annotation on unannotated type
649 mkUTyM ty = mkUTy usMany ty
653 isUsageKind :: Kind -> Bool
655 = ASSERT( typeKind k == superKind )
658 isUsage :: Type -> Bool
660 = isUsageKind (typeKind ty)
662 isUTyVar :: Var -> Bool
664 = isUsageKind (tyVarKind v)
668 %************************************************************************
670 \subsection{Stuff to do with the source-language types}
672 PredType and ThetaType are used in types for expressions and bindings.
673 ClassPred and ClassContext are used in class and instance declarations.
675 %************************************************************************
677 "Dictionary" types are just ordinary data types, but you can
678 tell from the type constructor whether it's a dictionary or not.
681 mkClassPred clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) )
684 mkDictTy :: Class -> [Type] -> Type
685 mkDictTy clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) )
686 mkPredTy (Class clas tys)
688 mkDictTys :: ClassContext -> [Type]
689 mkDictTys cxt = [mkDictTy cls tys | (cls,tys) <- cxt]
691 mkPredTy :: PredType -> Type
692 mkPredTy pred = PredTy pred
694 predRepTy :: PredType -> Type
695 -- Convert a predicate to its "representation type";
696 -- the type of evidence for that predicate, which is actually passed at runtime
697 predRepTy (Class clas tys) = TyConApp (classTyCon clas) tys
698 predRepTy (IParam n ty) = ty
700 isPredTy :: Type -> Bool
701 isPredTy (NoteTy _ ty) = isPredTy ty
702 isPredTy (PredTy _) = True
703 isPredTy (UsageTy _ ty)= isPredTy ty
706 isDictTy :: Type -> Bool
707 isDictTy (NoteTy _ ty) = isDictTy ty
708 isDictTy (PredTy (Class _ _)) = True
709 isDictTy (UsageTy _ ty) = isDictTy ty
710 isDictTy other = False
712 splitPredTy_maybe :: Type -> Maybe PredType
713 splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty
714 splitPredTy_maybe (PredTy p) = Just p
715 splitPredTy_maybe (UsageTy _ ty)= splitPredTy_maybe ty
716 splitPredTy_maybe other = Nothing
718 splitDictTy :: Type -> (Class, [Type])
719 splitDictTy (NoteTy _ ty) = splitDictTy ty
720 splitDictTy (PredTy (Class clas tys)) = (clas, tys)
722 splitDictTy_maybe :: Type -> Maybe (Class, [Type])
723 splitDictTy_maybe (NoteTy _ ty) = Just (splitDictTy ty)
724 splitDictTy_maybe (PredTy (Class clas tys)) = Just (clas, tys)
725 splitDictTy_maybe other = Nothing
727 splitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
728 -- Split the type of a dictionary function
730 = case splitSigmaTy ty of { (tvs, theta, tau) ->
731 case splitDictTy tau of { (clas, tys) ->
732 (tvs, theta, clas, tys) }}
734 getClassTys_maybe :: PredType -> Maybe ClassPred
735 getClassTys_maybe (Class clas tys) = Just (clas, tys)
736 getClassTys_maybe _ = Nothing
738 ipName_maybe :: PredType -> Maybe Name
739 ipName_maybe (IParam n _) = Just n
740 ipName_maybe _ = Nothing
742 classesOfPreds :: ThetaType -> ClassContext
743 classesOfPreds theta = [(clas,tys) | Class clas tys <- theta]
746 @isTauTy@ tests for nested for-alls.
749 isTauTy :: Type -> Bool
750 isTauTy (TyVarTy v) = True
751 isTauTy (TyConApp _ tys) = all isTauTy tys
752 isTauTy (AppTy a b) = isTauTy a && isTauTy b
753 isTauTy (FunTy a b) = isTauTy a && isTauTy b
754 isTauTy (PredTy p) = isTauTy (predRepTy p)
755 isTauTy (NoteTy _ ty) = isTauTy ty
756 isTauTy (UsageTy _ ty) = isTauTy ty
757 isTauTy other = False
761 mkRhoTy :: [PredType] -> Type -> Type
762 mkRhoTy theta ty = UASSERT2( not (isUTy ty), pprType ty )
763 foldr (\p r -> FunTy (mkUTyM (mkPredTy p)) (mkUTyM r)) ty theta
765 splitRhoTy :: Type -> ([PredType], Type)
766 splitRhoTy ty = split ty ty []
768 split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of
769 Just p -> split res res (p:ts)
770 Nothing -> (reverse ts, orig_ty)
771 split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts
772 split orig_ty (UsageTy _ ty) ts = split orig_ty ty ts
773 split orig_ty ty ts = (reverse ts, orig_ty)
777 isSigmaType returns true of any qualified type. It doesn't *necessarily* have
779 f :: (?x::Int) => Int -> Int
782 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
784 isSigmaTy :: Type -> Bool
785 isSigmaTy (ForAllTy tyvar ty) = True
786 isSigmaTy (FunTy a b) = isPredTy a
787 isSigmaTy (NoteTy _ ty) = isSigmaTy ty
788 isSigmaTy (UsageTy _ ty) = isSigmaTy ty
791 splitSigmaTy :: Type -> ([TyVar], [PredType], Type)
795 (tyvars,rho) = splitForAllTys ty
796 (theta,tau) = splitRhoTy rho
800 getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
801 -- construct a dictionary function name
802 getDFunTyKey (TyVarTy tv) = getOccName tv
803 getDFunTyKey (TyConApp tc _) = getOccName tc
804 getDFunTyKey (AppTy fun _) = getDFunTyKey fun
805 getDFunTyKey (NoteTy _ t) = getDFunTyKey t
806 getDFunTyKey (FunTy arg _) = getOccName funTyCon
807 getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
808 getDFunTyKey (UsageTy _ t) = getDFunTyKey t
809 -- PredTy shouldn't happen
813 %************************************************************************
815 \subsection{Kinds and free variables}
817 %************************************************************************
819 ---------------------------------------------------------------------
820 Finding the kind of a type
821 ~~~~~~~~~~~~~~~~~~~~~~~~~~
823 typeKind :: Type -> Kind
825 typeKind (TyVarTy tyvar) = tyVarKind tyvar
826 typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
827 typeKind (NoteTy _ ty) = typeKind ty
828 typeKind (PredTy _) = boxedTypeKind -- Predicates are always
829 -- represented by boxed types
830 typeKind (AppTy fun arg) = funResultTy (typeKind fun)
832 typeKind (FunTy arg res) = fix_up (typeKind res)
834 fix_up (TyConApp tycon _) | tycon == typeCon
835 || tycon == openKindCon = boxedTypeKind
836 fix_up (NoteTy _ kind) = fix_up kind
838 -- The basic story is
839 -- typeKind (FunTy arg res) = typeKind res
840 -- But a function is boxed regardless of its result type
841 -- Hence the strange fix-up.
842 -- Note that 'res', being the result of a FunTy, can't have
843 -- a strange kind like (*->*).
845 typeKind (ForAllTy tv ty) = typeKind ty
846 typeKind (UsageTy _ ty) = typeKind ty -- we don't have separate kinds for ann/unann
850 ---------------------------------------------------------------------
851 Free variables of a type
852 ~~~~~~~~~~~~~~~~~~~~~~~~
855 tyVarsOfType :: Type -> TyVarSet
856 tyVarsOfType (TyVarTy tv) = unitVarSet tv
857 tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
858 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
859 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
860 tyVarsOfType (PredTy p) = tyVarsOfPred p
861 tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
862 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
863 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
864 tyVarsOfType (UsageTy u ty) = tyVarsOfType u `unionVarSet` tyVarsOfType ty
866 tyVarsOfTypes :: [Type] -> TyVarSet
867 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
869 tyVarsOfPred :: PredType -> TyVarSet
870 tyVarsOfPred (Class clas tys) = tyVarsOfTypes tys
871 tyVarsOfPred (IParam n ty) = tyVarsOfType ty
873 tyVarsOfTheta :: ThetaType -> TyVarSet
874 tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
876 -- Add a Note with the free tyvars to the top of the type
877 addFreeTyVars :: Type -> Type
878 addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
879 addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
881 -- Find the free names of a type, including the type constructors and classes it mentions
882 namesOfType :: Type -> NameSet
883 namesOfType (TyVarTy tv) = unitNameSet (getName tv)
884 namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets`
886 namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1
887 namesOfType (NoteTy other_note ty2) = namesOfType ty2
888 namesOfType (PredTy p) = namesOfType (predRepTy p)
889 namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
890 namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
891 namesOfType (ForAllTy tyvar ty) = namesOfType ty `delFromNameSet` getName tyvar
892 namesOfType (UsageTy u ty) = namesOfType u `unionNameSets` namesOfType ty
894 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
897 Usage annotations of a type
898 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
900 Get a list of usage annotations of a type, *in left-to-right pre-order*.
903 usageAnnOfType :: Type -> [Type]
908 goT (AppTy ty1 ty2) = goT ty1 ++ goT ty2
909 goT (TyConApp tc tys) = concatMap goT tys
910 goT (FunTy sty1 sty2) = goS sty1 ++ goS sty2
911 goT (ForAllTy mv ty) = goT ty
912 goT (PredTy p) = goT (predRepTy p)
913 goT ty@(UsageTy _ _) = pprPanic "usageAnnOfType: unexpected usage:" (pprType ty)
914 goT (NoteTy note ty) = goT ty
916 goS sty = case splitUTy sty of
917 (u,tty) -> u : goT tty
921 %************************************************************************
923 \subsection{TidyType}
925 %************************************************************************
927 tidyTy tidies up a type for printing in an error message, or in
930 It doesn't change the uniques at all, just the print names.
933 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
934 tidyTyVar env@(tidy_env, subst) tyvar
935 = case lookupVarEnv subst tyvar of
937 Just tyvar' -> -- Already substituted
940 Nothing -> -- Make a new nice name for it
942 case tidyOccName tidy_env (getOccName name) of
943 (tidy', occ') -> -- New occname reqd
944 ((tidy', subst'), tyvar')
946 subst' = extendVarEnv subst tyvar tyvar'
947 tyvar' = setTyVarName tyvar name'
948 name' = mkLocalName (getUnique name) occ' noSrcLoc
949 -- Note: make a *user* tyvar, so it printes nicely
950 -- Could extract src loc, but no need.
952 name = tyVarName tyvar
954 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
956 tidyType :: TidyEnv -> Type -> Type
957 tidyType env@(tidy_env, subst) ty
960 go (TyVarTy tv) = case lookupVarEnv subst tv of
961 Nothing -> TyVarTy tv
962 Just tv' -> TyVarTy tv'
963 go (TyConApp tycon tys) = let args = map go tys
964 in args `seqList` TyConApp tycon args
965 go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
966 go (PredTy p) = PredTy (go_pred p)
967 go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
968 go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
969 go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty)
971 (envp, tvp) = tidyTyVar env tv
972 go (UsageTy u ty) = (UsageTy SAPPLY (go u)) SAPPLY (go ty)
974 go_note (SynNote ty) = SynNote SAPPLY (go ty)
975 go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
977 go_pred (Class c tys) = Class c (tidyTypes env tys)
978 go_pred (IParam n ty) = IParam n (go ty)
980 tidyTypes env tys = map (tidyType env) tys
984 @tidyOpenType@ grabs the free type variables, tidies them
985 and then uses @tidyType@ to work over the type itself
988 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
990 = (env', tidyType env' ty)
992 env' = foldl go env (varSetElems (tyVarsOfType ty))
993 go env tyvar = fst (tidyTyVar env tyvar)
995 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
996 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
998 tidyTopType :: Type -> Type
999 tidyTopType ty = tidyType emptyTidyEnv ty
1004 %************************************************************************
1006 \subsection{Boxedness and liftedness}
1008 %************************************************************************
1011 isUnboxedType :: Type -> Bool
1012 isUnboxedType ty = not (isFollowableRep (typePrimRep ty))
1014 isUnLiftedType :: Type -> Bool
1015 -- isUnLiftedType returns True for forall'd unlifted types:
1016 -- x :: forall a. Int#
1017 -- I found bindings like these were getting floated to the top level.
1018 -- They are pretty bogus types, mind you. It would be better never to
1021 isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
1022 isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty
1023 isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
1024 isUnLiftedType (UsageTy _ ty) = isUnLiftedType ty
1025 isUnLiftedType other = False
1027 isUnboxedTupleType :: Type -> Bool
1028 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
1029 Just (tc, ty_args) -> isUnboxedTupleTyCon tc
1032 -- Should only be applied to *types*; hence the assert
1033 isAlgType :: Type -> Bool
1034 isAlgType ty = case splitTyConApp_maybe ty of
1035 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1039 -- Should only be applied to *types*; hence the assert
1040 isDataType :: Type -> Bool
1041 isDataType ty = case splitTyConApp_maybe ty of
1042 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1046 isNewType :: Type -> Bool
1047 isNewType ty = case splitTyConApp_maybe ty of
1048 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1054 %************************************************************************
1056 \subsection{Sequencing on types
1058 %************************************************************************
1061 seqType :: Type -> ()
1062 seqType (TyVarTy tv) = tv `seq` ()
1063 seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
1064 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
1065 seqType (NoteTy note t2) = seqNote note `seq` seqType t2
1066 seqType (PredTy p) = seqPred p
1067 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
1068 seqType (ForAllTy tv ty) = tv `seq` seqType ty
1069 seqType (UsageTy u ty) = seqType u `seq` seqType ty
1071 seqTypes :: [Type] -> ()
1073 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
1075 seqNote :: TyNote -> ()
1076 seqNote (SynNote ty) = seqType ty
1077 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
1079 seqPred :: PredType -> ()
1080 seqPred (Class c tys) = c `seq` seqTypes tys
1081 seqPred (IParam n ty) = n `seq` seqType ty
1085 %************************************************************************
1087 \subsection{Equality on types}
1089 %************************************************************************
1093 instance Eq Type where
1094 ty1 == ty2 = case ty1 `compare` ty2 of { EQ -> True; other -> False }
1096 instance Ord Type where
1097 compare ty1 ty2 = cmpTy emptyVarEnv ty1 ty2
1099 cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
1100 -- The "env" maps type variables in ty1 to type variables in ty2
1101 -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
1102 -- we in effect substitute tv2 for tv1 in t1 before continuing
1104 -- Get rid of NoteTy
1105 cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
1106 cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
1108 -- Get rid of PredTy
1109 cmpTy env (PredTy p1) (PredTy p2) = cmpPred env p1 p2
1110 cmpTy env (PredTy p1) ty2 = cmpTy env (predRepTy p1) ty2
1111 cmpTy env ty1 (PredTy p2) = cmpTy env ty1 (predRepTy p2)
1113 -- Deal with equal constructors
1114 cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
1115 Just tv1a -> tv1a `compare` tv2
1116 Nothing -> tv1 `compare` tv2
1118 cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1119 cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1120 cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
1121 cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2
1122 cmpTy env (UsageTy u1 t1) (UsageTy u2 t2) = cmpTy env u1 u2 `thenCmp` cmpTy env t1 t2
1124 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < UsageTy
1125 cmpTy env (AppTy _ _) (TyVarTy _) = GT
1127 cmpTy env (FunTy _ _) (TyVarTy _) = GT
1128 cmpTy env (FunTy _ _) (AppTy _ _) = GT
1130 cmpTy env (TyConApp _ _) (TyVarTy _) = GT
1131 cmpTy env (TyConApp _ _) (AppTy _ _) = GT
1132 cmpTy env (TyConApp _ _) (FunTy _ _) = GT
1134 cmpTy env (ForAllTy _ _) (TyVarTy _) = GT
1135 cmpTy env (ForAllTy _ _) (AppTy _ _) = GT
1136 cmpTy env (ForAllTy _ _) (FunTy _ _) = GT
1137 cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT
1139 cmpTy env (UsageTy _ _) other = GT
1144 cmpTys env [] [] = EQ
1145 cmpTys env (t:ts) [] = GT
1146 cmpTys env [] (t:ts) = LT
1147 cmpTys env (t1:t1s) (t2:t2s) = cmpTy env t1 t2 `thenCmp` cmpTys env t1s t2s
1151 instance Eq PredType where
1152 p1 == p2 = case p1 `compare` p2 of { EQ -> True; other -> False }
1154 instance Ord PredType where
1155 compare p1 p2 = cmpPred emptyVarEnv p1 p2
1157 cmpPred :: TyVarEnv TyVar -> PredType -> PredType -> Ordering
1158 cmpPred env (IParam n1 t) (IParam n2 t2) = n1 `compare` n2
1159 -- Just compare the names!
1160 cmpPred env (Class c1 tys1) (Class c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
1161 cmpPred env (IParam _ _) (Class _ _) = LT
1162 cmpPred env (Class _ _) (IParam _ _) = GT