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 liftedBoxity, unliftedBoxity, -- :: BX
15 typeCon, -- :: BX -> KX
16 liftedTypeKind, unliftedTypeKind, 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, splitMethodTy,
60 mkSigmaTy, isSigmaTy, splitSigmaTy,
64 isUnLiftedType, 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(..) )
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 = liftedTypeKind
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)
776 The type of a method for class C is always of the form:
777 Forall a1..an. C a1..an => sig_ty
778 where sig_ty is the type given by the method's signature, and thus in general
779 is a ForallTy. At the point that splitMethodTy is called, it is expected
780 that the outer Forall has already been stripped off. splitMethodTy then
781 returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes or
785 splitMethodTy :: Type -> (PredType, Type)
786 splitMethodTy ty = split ty
788 split (FunTy arg res) = case splitPredTy_maybe arg of
790 Nothing -> panic "splitMethodTy"
791 split (NoteTy _ ty) = split ty
792 split (UsageTy _ ty) = split ty
793 split _ = panic "splitMethodTy"
797 isSigmaType returns true of any qualified type. It doesn't *necessarily* have
799 f :: (?x::Int) => Int -> Int
802 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
804 isSigmaTy :: Type -> Bool
805 isSigmaTy (ForAllTy tyvar ty) = True
806 isSigmaTy (FunTy a b) = isPredTy a
807 isSigmaTy (NoteTy _ ty) = isSigmaTy ty
808 isSigmaTy (UsageTy _ ty) = isSigmaTy ty
811 splitSigmaTy :: Type -> ([TyVar], [PredType], Type)
815 (tyvars,rho) = splitForAllTys ty
816 (theta,tau) = splitRhoTy rho
820 getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
821 -- construct a dictionary function name
822 getDFunTyKey (TyVarTy tv) = getOccName tv
823 getDFunTyKey (TyConApp tc _) = getOccName tc
824 getDFunTyKey (AppTy fun _) = getDFunTyKey fun
825 getDFunTyKey (NoteTy _ t) = getDFunTyKey t
826 getDFunTyKey (FunTy arg _) = getOccName funTyCon
827 getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
828 getDFunTyKey (UsageTy _ t) = getDFunTyKey t
829 -- PredTy shouldn't happen
833 %************************************************************************
835 \subsection{Kinds and free variables}
837 %************************************************************************
839 ---------------------------------------------------------------------
840 Finding the kind of a type
841 ~~~~~~~~~~~~~~~~~~~~~~~~~~
843 typeKind :: Type -> Kind
845 typeKind (TyVarTy tyvar) = tyVarKind tyvar
846 typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
847 typeKind (NoteTy _ ty) = typeKind ty
848 typeKind (PredTy _) = liftedTypeKind -- Predicates are always
849 -- represented by lifted types
850 typeKind (AppTy fun arg) = funResultTy (typeKind fun)
852 typeKind (FunTy arg res) = fix_up (typeKind res)
854 fix_up (TyConApp tycon _) | tycon == typeCon
855 || tycon == openKindCon = liftedTypeKind
856 fix_up (NoteTy _ kind) = fix_up kind
858 -- The basic story is
859 -- typeKind (FunTy arg res) = typeKind res
860 -- But a function is lifted regardless of its result type
861 -- Hence the strange fix-up.
862 -- Note that 'res', being the result of a FunTy, can't have
863 -- a strange kind like (*->*).
865 typeKind (ForAllTy tv ty) = typeKind ty
866 typeKind (UsageTy _ ty) = typeKind ty -- we don't have separate kinds for ann/unann
870 ---------------------------------------------------------------------
871 Free variables of a type
872 ~~~~~~~~~~~~~~~~~~~~~~~~
875 tyVarsOfType :: Type -> TyVarSet
876 tyVarsOfType (TyVarTy tv) = unitVarSet tv
877 tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
878 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
879 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
880 tyVarsOfType (PredTy p) = tyVarsOfPred p
881 tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
882 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
883 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
884 tyVarsOfType (UsageTy u ty) = tyVarsOfType u `unionVarSet` tyVarsOfType ty
886 tyVarsOfTypes :: [Type] -> TyVarSet
887 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
889 tyVarsOfPred :: PredType -> TyVarSet
890 tyVarsOfPred (Class clas tys) = tyVarsOfTypes tys
891 tyVarsOfPred (IParam n ty) = tyVarsOfType ty
893 tyVarsOfTheta :: ThetaType -> TyVarSet
894 tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
896 -- Add a Note with the free tyvars to the top of the type
897 addFreeTyVars :: Type -> Type
898 addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
899 addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
901 -- Find the free names of a type, including the type constructors and classes it mentions
902 namesOfType :: Type -> NameSet
903 namesOfType (TyVarTy tv) = unitNameSet (getName tv)
904 namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets`
906 namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1
907 namesOfType (NoteTy other_note ty2) = namesOfType ty2
908 namesOfType (PredTy p) = namesOfType (predRepTy p)
909 namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
910 namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
911 namesOfType (ForAllTy tyvar ty) = namesOfType ty `delFromNameSet` getName tyvar
912 namesOfType (UsageTy u ty) = namesOfType u `unionNameSets` namesOfType ty
914 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
917 Usage annotations of a type
918 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
920 Get a list of usage annotations of a type, *in left-to-right pre-order*.
923 usageAnnOfType :: Type -> [Type]
928 goT (AppTy ty1 ty2) = goT ty1 ++ goT ty2
929 goT (TyConApp tc tys) = concatMap goT tys
930 goT (FunTy sty1 sty2) = goS sty1 ++ goS sty2
931 goT (ForAllTy mv ty) = goT ty
932 goT (PredTy p) = goT (predRepTy p)
933 goT ty@(UsageTy _ _) = pprPanic "usageAnnOfType: unexpected usage:" (pprType ty)
934 goT (NoteTy note ty) = goT ty
936 goS sty = case splitUTy sty of
937 (u,tty) -> u : goT tty
941 %************************************************************************
943 \subsection{TidyType}
945 %************************************************************************
947 tidyTy tidies up a type for printing in an error message, or in
950 It doesn't change the uniques at all, just the print names.
953 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
954 tidyTyVar env@(tidy_env, subst) tyvar
955 = case lookupVarEnv subst tyvar of
957 Just tyvar' -> -- Already substituted
960 Nothing -> -- Make a new nice name for it
962 case tidyOccName tidy_env (getOccName name) of
963 (tidy', occ') -> -- New occname reqd
964 ((tidy', subst'), tyvar')
966 subst' = extendVarEnv subst tyvar tyvar'
967 tyvar' = setTyVarName tyvar name'
968 name' = mkLocalName (getUnique name) occ' noSrcLoc
969 -- Note: make a *user* tyvar, so it printes nicely
970 -- Could extract src loc, but no need.
972 name = tyVarName tyvar
974 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
976 tidyType :: TidyEnv -> Type -> Type
977 tidyType env@(tidy_env, subst) ty
980 go (TyVarTy tv) = case lookupVarEnv subst tv of
981 Nothing -> TyVarTy tv
982 Just tv' -> TyVarTy tv'
983 go (TyConApp tycon tys) = let args = map go tys
984 in args `seqList` TyConApp tycon args
985 go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
986 go (PredTy p) = PredTy (go_pred p)
987 go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
988 go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
989 go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty)
991 (envp, tvp) = tidyTyVar env tv
992 go (UsageTy u ty) = (UsageTy SAPPLY (go u)) SAPPLY (go ty)
994 go_note (SynNote ty) = SynNote SAPPLY (go ty)
995 go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
997 go_pred (Class c tys) = Class c (tidyTypes env tys)
998 go_pred (IParam n ty) = IParam n (go ty)
1000 tidyTypes env tys = map (tidyType env) tys
1004 @tidyOpenType@ grabs the free type variables, tidies them
1005 and then uses @tidyType@ to work over the type itself
1008 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
1010 = (env', tidyType env' ty)
1012 env' = foldl go env (varSetElems (tyVarsOfType ty))
1013 go env tyvar = fst (tidyTyVar env tyvar)
1015 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
1016 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
1018 tidyTopType :: Type -> Type
1019 tidyTopType ty = tidyType emptyTidyEnv ty
1024 %************************************************************************
1026 \subsection{Liftedness}
1028 %************************************************************************
1031 isUnLiftedType :: Type -> Bool
1032 -- isUnLiftedType returns True for forall'd unlifted types:
1033 -- x :: forall a. Int#
1034 -- I found bindings like these were getting floated to the top level.
1035 -- They are pretty bogus types, mind you. It would be better never to
1038 isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
1039 isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty
1040 isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
1041 isUnLiftedType (UsageTy _ ty) = isUnLiftedType ty
1042 isUnLiftedType other = False
1044 isUnboxedTupleType :: Type -> Bool
1045 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
1046 Just (tc, ty_args) -> isUnboxedTupleTyCon tc
1049 -- Should only be applied to *types*; hence the assert
1050 isAlgType :: Type -> Bool
1051 isAlgType ty = case splitTyConApp_maybe ty of
1052 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1056 -- Should only be applied to *types*; hence the assert
1057 isDataType :: Type -> Bool
1058 isDataType ty = case splitTyConApp_maybe ty of
1059 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1063 isNewType :: Type -> Bool
1064 isNewType ty = case splitTyConApp_maybe ty of
1065 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1071 %************************************************************************
1073 \subsection{Sequencing on types
1075 %************************************************************************
1078 seqType :: Type -> ()
1079 seqType (TyVarTy tv) = tv `seq` ()
1080 seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
1081 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
1082 seqType (NoteTy note t2) = seqNote note `seq` seqType t2
1083 seqType (PredTy p) = seqPred p
1084 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
1085 seqType (ForAllTy tv ty) = tv `seq` seqType ty
1086 seqType (UsageTy u ty) = seqType u `seq` seqType ty
1088 seqTypes :: [Type] -> ()
1090 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
1092 seqNote :: TyNote -> ()
1093 seqNote (SynNote ty) = seqType ty
1094 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
1096 seqPred :: PredType -> ()
1097 seqPred (Class c tys) = c `seq` seqTypes tys
1098 seqPred (IParam n ty) = n `seq` seqType ty
1102 %************************************************************************
1104 \subsection{Equality on types}
1106 %************************************************************************
1110 instance Eq Type where
1111 ty1 == ty2 = case ty1 `compare` ty2 of { EQ -> True; other -> False }
1113 instance Ord Type where
1114 compare ty1 ty2 = cmpTy emptyVarEnv ty1 ty2
1116 cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
1117 -- The "env" maps type variables in ty1 to type variables in ty2
1118 -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
1119 -- we in effect substitute tv2 for tv1 in t1 before continuing
1121 -- Get rid of NoteTy
1122 cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
1123 cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
1125 -- Get rid of PredTy
1126 cmpTy env (PredTy p1) (PredTy p2) = cmpPred env p1 p2
1127 cmpTy env (PredTy p1) ty2 = cmpTy env (predRepTy p1) ty2
1128 cmpTy env ty1 (PredTy p2) = cmpTy env ty1 (predRepTy p2)
1130 -- Deal with equal constructors
1131 cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
1132 Just tv1a -> tv1a `compare` tv2
1133 Nothing -> tv1 `compare` tv2
1135 cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1136 cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1137 cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
1138 cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2
1139 cmpTy env (UsageTy u1 t1) (UsageTy u2 t2) = cmpTy env u1 u2 `thenCmp` cmpTy env t1 t2
1141 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < UsageTy
1142 cmpTy env (AppTy _ _) (TyVarTy _) = GT
1144 cmpTy env (FunTy _ _) (TyVarTy _) = GT
1145 cmpTy env (FunTy _ _) (AppTy _ _) = GT
1147 cmpTy env (TyConApp _ _) (TyVarTy _) = GT
1148 cmpTy env (TyConApp _ _) (AppTy _ _) = GT
1149 cmpTy env (TyConApp _ _) (FunTy _ _) = GT
1151 cmpTy env (ForAllTy _ _) (TyVarTy _) = GT
1152 cmpTy env (ForAllTy _ _) (AppTy _ _) = GT
1153 cmpTy env (ForAllTy _ _) (FunTy _ _) = GT
1154 cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT
1156 cmpTy env (UsageTy _ _) other = GT
1161 cmpTys env [] [] = EQ
1162 cmpTys env (t:ts) [] = GT
1163 cmpTys env [] (t:ts) = LT
1164 cmpTys env (t1:t1s) (t2:t2s) = cmpTy env t1 t2 `thenCmp` cmpTys env t1s t2s
1168 instance Eq PredType where
1169 p1 == p2 = case p1 `compare` p2 of { EQ -> True; other -> False }
1171 instance Ord PredType where
1172 compare p1 p2 = cmpPred emptyVarEnv p1 p2
1174 cmpPred :: TyVarEnv TyVar -> PredType -> PredType -> Ordering
1175 cmpPred env (IParam n1 t) (IParam n2 t2) = n1 `compare` n2
1176 -- Just compare the names!
1177 cmpPred env (Class c1 tys1) (Class c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
1178 cmpPred env (IParam _ _) (Class _ _) = LT
1179 cmpPred env (Class _ _) (IParam _ _) = GT