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, 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,
105 import SrcLoc ( noSrcLoc )
106 import PrimRep ( PrimRep(..), isFollowableRep )
107 import Unique ( Uniquable(..) )
108 import Util ( mapAccumL, seqList, thenCmp )
110 import UniqSet ( sizeUniqSet ) -- Should come via VarSet
114 %************************************************************************
116 \subsection{Stuff to do with kinds.}
118 %************************************************************************
121 hasMoreBoxityInfo :: Kind -> Kind -> Bool
122 hasMoreBoxityInfo k1 k2
123 | k2 == openTypeKind = True
124 | otherwise = k1 == k2
126 defaultKind :: Kind -> Kind
127 -- Used when generalising: default kind '?' to '*'
128 defaultKind kind | kind == openTypeKind = boxedTypeKind
133 %************************************************************************
135 \subsection{Constructor-specific functions}
137 %************************************************************************
140 ---------------------------------------------------------------------
144 mkTyVarTy :: TyVar -> Type
147 mkTyVarTys :: [TyVar] -> [Type]
148 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
150 getTyVar :: String -> Type -> TyVar
151 getTyVar msg (TyVarTy tv) = tv
152 getTyVar msg (PredTy p) = getTyVar msg (predRepTy p)
153 getTyVar msg (NoteTy _ t) = getTyVar msg t
154 getTyVar msg other = panic ("getTyVar: " ++ msg)
156 getTyVar_maybe :: Type -> Maybe TyVar
157 getTyVar_maybe (TyVarTy tv) = Just tv
158 getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
159 getTyVar_maybe (PredTy p) = getTyVar_maybe (predRepTy p)
160 getTyVar_maybe other = Nothing
162 isTyVarTy :: Type -> Bool
163 isTyVarTy (TyVarTy tv) = True
164 isTyVarTy (NoteTy _ ty) = isTyVarTy ty
165 isTyVarTy (PredTy p) = isTyVarTy (predRepTy p)
166 isTyVarTy other = False
170 ---------------------------------------------------------------------
173 We need to be pretty careful with AppTy to make sure we obey the
174 invariant that a TyConApp is always visibly so. mkAppTy maintains the
178 mkAppTy orig_ty1 orig_ty2
179 = ASSERT2( isNotUsgTy orig_ty1 && isNotUsgTy orig_ty2, pprType orig_ty1 <+> text "to" <+> pprType orig_ty2 )
180 ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind *
183 mk_app (NoteTy _ ty1) = mk_app ty1
184 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
185 mk_app ty1 = AppTy orig_ty1 orig_ty2
187 mkAppTys :: Type -> [Type] -> Type
188 mkAppTys orig_ty1 [] = orig_ty1
189 -- This check for an empty list of type arguments
190 -- avoids the needless of a type synonym constructor.
191 -- For example: mkAppTys Rational []
192 -- returns to (Ratio Integer), which has needlessly lost
193 -- the Rational part.
194 mkAppTys orig_ty1 orig_tys2
195 = ASSERT2( isNotUsgTy orig_ty1, pprType orig_ty1 )
196 ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind *
199 mk_app (NoteTy _ ty1) = mk_app ty1
200 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
201 mk_app ty1 = ASSERT2( all isNotUsgTy orig_tys2, pprType orig_ty1 <+> text "to" <+> hsep (map pprType orig_tys2) )
202 foldl AppTy orig_ty1 orig_tys2
204 splitAppTy_maybe :: Type -> Maybe (Type, Type)
205 splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
206 splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
207 splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty
208 splitAppTy_maybe (PredTy p) = splitAppTy_maybe (predRepTy p)
209 splitAppTy_maybe (TyConApp tc []) = Nothing
210 splitAppTy_maybe (TyConApp tc tys) = split tys []
212 split [ty2] acc = Just (TyConApp tc (reverse acc), ty2)
213 split (ty:tys) acc = split tys (ty:acc)
215 splitAppTy_maybe other = Nothing
217 splitAppTy :: Type -> (Type, Type)
218 splitAppTy ty = case splitAppTy_maybe ty of
220 Nothing -> panic "splitAppTy"
222 splitAppTys :: Type -> (Type, [Type])
223 splitAppTys ty = split ty ty []
225 split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
226 split orig_ty (NoteTy _ ty) args = split orig_ty ty args
227 split orig_ty (PredTy p) args = split orig_ty (predRepTy p) args
228 split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
229 (TyConApp funTyCon [], [ty1,ty2])
230 split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
231 split orig_ty ty args = (orig_ty, args)
235 ---------------------------------------------------------------------
240 mkFunTy :: Type -> Type -> Type
241 mkFunTy arg res = FunTy arg res
243 mkFunTys :: [Type] -> Type -> Type
244 mkFunTys tys ty = foldr FunTy ty tys
246 splitFunTy :: Type -> (Type, Type)
247 splitFunTy (FunTy arg res) = (arg, res)
248 splitFunTy (NoteTy _ ty) = splitFunTy ty
249 splitFunTy (PredTy p) = splitFunTy (predRepTy p)
251 splitFunTy_maybe :: Type -> Maybe (Type, Type)
252 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
253 splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
254 splitFunTy_maybe (PredTy p) = splitFunTy_maybe (predRepTy p)
255 splitFunTy_maybe other = Nothing
257 splitFunTys :: Type -> ([Type], Type)
258 splitFunTys ty = split [] ty ty
260 split args orig_ty (FunTy arg res) = split (arg:args) res res
261 split args orig_ty (NoteTy _ ty) = split args orig_ty ty
262 split args orig_ty (PredTy p) = split args orig_ty (predRepTy p)
263 split args orig_ty ty = (reverse args, orig_ty)
265 splitFunTysN :: String -> Int -> Type -> ([Type], Type)
266 splitFunTysN msg orig_n orig_ty = split orig_n [] orig_ty orig_ty
268 split 0 args syn_ty ty = (reverse args, syn_ty)
269 split n args syn_ty (FunTy arg res) = split (n-1) (arg:args) res res
270 split n args syn_ty (NoteTy _ ty) = split n args syn_ty ty
271 split n args syn_ty (PredTy p) = split n args syn_ty (predRepTy p)
272 split n args syn_ty ty = pprPanic ("splitFunTysN: " ++ msg) (int orig_n <+> pprType orig_ty)
274 zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
275 zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
277 split acc [] nty ty = (reverse acc, nty)
278 split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
279 split acc xs nty (NoteTy _ ty) = split acc xs nty ty
280 split acc xs nty (PredTy p) = split acc xs nty (predRepTy p)
281 split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty)
283 funResultTy :: Type -> Type
284 funResultTy (FunTy arg res) = res
285 funResultTy (NoteTy _ ty) = funResultTy ty
286 funResultTy (PredTy p) = funResultTy (predRepTy p)
287 funResultTy ty = pprPanic "funResultTy" (pprType ty)
289 funArgTy :: Type -> Type
290 funArgTy (FunTy arg res) = arg
291 funArgTy (NoteTy _ ty) = funArgTy ty
292 funArgTy (PredTy p) = funArgTy (predRepTy p)
293 funArgTy ty = pprPanic "funArgTy" (pprType ty)
297 ---------------------------------------------------------------------
302 mkTyConApp :: TyCon -> [Type] -> Type
304 | isFunTyCon tycon && length tys == 2
306 (ty1:ty2:_) -> FunTy ty1 ty2
309 = ASSERT(not (isSynTyCon tycon))
312 mkTyConTy :: TyCon -> Type
313 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
316 -- splitTyConApp "looks through" synonyms, because they don't
317 -- mean a distinct type, but all other type-constructor applications
318 -- including functions are returned as Just ..
320 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
321 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
322 splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
323 splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
324 splitTyConApp_maybe (PredTy p) = splitTyConApp_maybe (predRepTy p)
325 splitTyConApp_maybe other = Nothing
327 -- splitAlgTyConApp_maybe looks for
328 -- *saturated* applications of *algebraic* data types
329 -- "Algebraic" => newtype, data type, or dictionary (not function types)
330 -- We return the constructors too, so there had better be some.
332 splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon])
333 splitAlgTyConApp_maybe (TyConApp tc tys)
335 tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
336 splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
337 splitAlgTyConApp_maybe (PredTy p) = splitAlgTyConApp_maybe (predRepTy p)
338 splitAlgTyConApp_maybe other = Nothing
340 splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon])
341 -- Here the "algebraic" property is an *assertion*
342 splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
343 (tc, tys, tyConDataCons tc)
344 splitAlgTyConApp (NoteTy _ ty) = splitAlgTyConApp ty
345 splitAlgTyConApp (PredTy p) = splitAlgTyConApp (predRepTy p)
347 splitAlgTyConApp ty = pprPanic "splitAlgTyConApp" (pprType ty)
352 ---------------------------------------------------------------------
357 mkSynTy syn_tycon tys
358 = ASSERT( isSynTyCon syn_tycon )
359 ASSERT( isNotUsgTy body )
360 ASSERT( length tyvars == length tys )
361 NoteTy (SynNote (TyConApp syn_tycon tys))
362 (substTy (mkTyVarSubst tyvars tys) body)
364 (tyvars, body) = getSynTyConDefn syn_tycon
366 isSynTy (NoteTy (SynNote _) _) = True
367 isSynTy other = False
369 deNoteType :: Type -> Type
370 -- Remove synonyms, but not Preds
371 deNoteType ty@(TyVarTy tyvar) = ty
372 deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
373 deNoteType (PredTy p) = PredTy p
374 deNoteType (NoteTy _ ty) = deNoteType ty
375 deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg)
376 deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg)
377 deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty)
380 Notes on type synonyms
381 ~~~~~~~~~~~~~~~~~~~~~~
382 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
383 to return type synonyms whereever possible. Thus
388 splitFunTys (a -> Foo a) = ([a], Foo a)
391 The reason is that we then get better (shorter) type signatures in
392 interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
398 repType looks through
403 It's useful in the back end where we're not
404 interested in newtypes anymore.
407 repType :: Type -> Type
408 repType (ForAllTy _ ty) = repType ty
409 repType (NoteTy _ ty) = repType ty
410 repType (PredTy p) = repType (predRepTy p)
411 repType ty = case splitNewType_maybe ty of
412 Just ty' -> repType ty' -- Still re-apply repType in case of for-all
415 splitRepFunTys :: Type -> ([Type], Type)
416 -- Like splitFunTys, but looks through newtypes and for-alls
417 splitRepFunTys ty = split [] (repType ty)
419 split args (FunTy arg res) = split (arg:args) (repType res)
420 split args ty = (reverse args, ty)
422 typePrimRep :: Type -> PrimRep
423 typePrimRep ty = case repType ty of
424 TyConApp tc _ -> tyConPrimRep tc
426 AppTy _ _ -> PtrRep -- ??
429 splitNewType_maybe :: Type -> Maybe Type
430 -- Find the representation of a newtype, if it is one
431 -- Looks through multiple levels of newtype, but does not look through for-alls
432 splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty
433 splitNewType_maybe (PredTy p) = splitNewType_maybe (predRepTy p)
434 splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of
435 Just rep_ty -> ASSERT( length tys == tyConArity tc )
436 -- The assert should hold because repType should
437 -- only be applied to *types* (of kind *)
438 Just (applyTys rep_ty tys)
440 splitNewType_maybe other = Nothing
445 ---------------------------------------------------------------------
449 NB: Invariant: if present, usage note is at the very top of the type.
450 This should be carefully preserved.
452 In some parts of the compiler, comments use the _Once Upon a
453 Polymorphic Type_ (POPL'99) usage of "rho = generalised
454 usage-annotated type; sigma = usage-annotated type; tau =
455 usage-annotated type except on top"; unfortunately this conflicts with
456 the rho/tau/theta/sigma usage in the rest of the compiler. (KSW
460 mkUsgTy :: UsageAnn -> Type -> Type
462 mkUsgTy UsMany ty = ASSERT2( isNotUsgTy ty, pprType ty )
465 mkUsgTy usg ty = ASSERT2( isNotUsgTy ty, pprType ty )
466 NoteTy (UsgNote usg) ty
468 -- The isUsgTy function is utterly useless if UsManys are omitted.
469 -- Be warned! KSW 1999-04.
470 isUsgTy :: Type -> Bool
474 isUsgTy (NoteTy (UsgForAll _) ty) = isUsgTy ty
475 isUsgTy (NoteTy (UsgNote _) _ ) = True
476 isUsgTy other = False
479 -- The isNotUsgTy function may return a false True if UsManys are omitted;
480 -- in other words, A SSERT( isNotUsgTy ty ) may be useful but
481 -- A SSERT( not (isNotUsg ty) ) is asking for trouble. KSW 1999-04.
482 isNotUsgTy :: Type -> Bool
483 isNotUsgTy (NoteTy (UsgForAll _) _) = False
484 isNotUsgTy (NoteTy (UsgNote _) _) = False
485 isNotUsgTy other = True
487 -- splitUsgTy_maybe is not exported, since it is meaningless if
488 -- UsManys are omitted. It is used in several places in this module,
489 -- however. KSW 1999-04.
490 splitUsgTy_maybe :: Type -> Maybe (UsageAnn,Type)
491 splitUsgTy_maybe (NoteTy (UsgNote usg) ty2) = ASSERT( isNotUsgTy ty2 )
493 splitUsgTy_maybe ty@(NoteTy (UsgForAll _) _) = pprPanic "splitUsgTy_maybe:" $ pprType ty
494 splitUsgTy_maybe ty = Nothing
496 splitUsgTy :: Type -> (UsageAnn,Type)
497 splitUsgTy ty = case splitUsgTy_maybe ty of
503 pprPanic "splitUsgTy: no usage annot:" $ pprType ty
506 tyUsg :: Type -> UsageAnn
507 tyUsg = fst . splitUsgTy
509 unUsgTy :: Type -> Type
510 -- strip outer usage annotation if present
511 unUsgTy ty = case splitUsgTy_maybe ty of
512 Just (_,ty1) -> ASSERT2( isNotUsgTy ty1, pprType ty )
516 mkUsForAllTy :: UVar -> Type -> Type
517 mkUsForAllTy uv ty = NoteTy (UsgForAll uv) ty
519 mkUsForAllTys :: [UVar] -> Type -> Type
520 mkUsForAllTys uvs ty = foldr (NoteTy . UsgForAll) ty uvs
522 splitUsForAllTys :: Type -> ([UVar],Type)
523 splitUsForAllTys ty = split ty []
524 where split (NoteTy (UsgForAll u) ty) uvs = split ty (u:uvs)
525 split other_ty uvs = (reverse uvs, other_ty)
527 substUsTy :: VarEnv UsageAnn -> Type -> Type
528 -- assumes range is fresh uvars, so no conflicts
529 substUsTy ve (NoteTy note@(UsgNote (UsVar u))
530 ty ) = NoteTy (case lookupVarEnv ve u of
531 Just ua -> UsgNote ua
534 substUsTy ve (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote (substUsTy ve ty1)) (substUsTy ve ty2)
535 substUsTy ve (NoteTy note ty) = NoteTy note (substUsTy ve ty)
537 substUsTy ve (PredTy (Class c tys)) = PredTy (Class c (map (substUsTy ve) tys))
538 substUsTy ve (PredTy (IParam n ty)) = PredTy (IParam n (substUsTy ve ty))
539 substUsTy ve (TyVarTy tv) = TyVarTy tv
540 substUsTy ve (AppTy ty1 ty2) = AppTy (substUsTy ve ty1) (substUsTy ve ty2)
541 substUsTy ve (FunTy ty1 ty2) = FunTy (substUsTy ve ty1) (substUsTy ve ty2)
542 substUsTy ve (TyConApp tyc tys) = TyConApp tyc (map (substUsTy ve) tys)
543 substUsTy ve (ForAllTy yv ty ) = ForAllTy yv (substUsTy ve ty)
547 ---------------------------------------------------------------------
551 We need to be clever here with usage annotations; they need to be
552 lifted or lowered through the forall as appropriate.
555 mkForAllTy :: TyVar -> Type -> Type
556 mkForAllTy tyvar ty = case splitUsgTy_maybe ty of
557 Just (usg,ty') -> NoteTy (UsgNote usg)
559 Nothing -> ForAllTy tyvar ty
561 mkForAllTys :: [TyVar] -> Type -> Type
562 mkForAllTys tyvars ty = case splitUsgTy_maybe ty of
563 Just (usg,ty') -> NoteTy (UsgNote usg)
564 (foldr ForAllTy ty' tyvars)
565 Nothing -> foldr ForAllTy ty tyvars
567 splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
568 splitForAllTy_maybe ty = case splitUsgTy_maybe ty of
569 Just (usg,ty') -> do (tyvar,ty'') <- splitFAT_m ty'
570 return (tyvar, NoteTy (UsgNote usg) ty'')
571 Nothing -> splitFAT_m ty
573 splitFAT_m (NoteTy _ ty) = splitFAT_m ty
574 splitFAT_m (PredTy p) = splitFAT_m (predRepTy p)
575 splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
576 splitFAT_m _ = Nothing
578 splitForAllTys :: Type -> ([TyVar], Type)
579 splitForAllTys ty = case splitUsgTy_maybe ty of
580 Just (usg,ty') -> let (tvs,ty'') = split ty' ty' []
581 in (tvs, NoteTy (UsgNote usg) ty'')
582 Nothing -> split ty ty []
584 split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
585 split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
586 split orig_ty (PredTy p) tvs = split orig_ty (predRepTy p) tvs
587 split orig_ty t tvs = (reverse tvs, orig_ty)
590 -- (mkPiType now in CoreUtils)
592 Applying a for-all to its arguments
595 applyTy :: Type -> Type -> Type
596 applyTy (NoteTy note@(UsgNote _) fun) arg = NoteTy note (applyTy fun arg)
597 applyTy (NoteTy note@(UsgForAll _) fun) arg = NoteTy note (applyTy fun arg)
598 applyTy (PredTy p) arg = applyTy (predRepTy p) arg
599 applyTy (NoteTy _ fun) arg = applyTy fun arg
600 applyTy (ForAllTy tv ty) arg = ASSERT( isNotUsgTy arg )
601 substTy (mkTyVarSubst [tv] [arg]) ty
602 applyTy other arg = panic "applyTy"
604 applyTys :: Type -> [Type] -> Type
605 applyTys fun_ty arg_tys
606 = substTy (mkTyVarSubst tvs arg_tys) ty
608 (tvs, ty) = split fun_ty arg_tys
610 split fun_ty [] = ([], fun_ty)
611 split (NoteTy note@(UsgNote _) fun_ty)
612 args = case split fun_ty args of
613 (tvs, ty) -> (tvs, NoteTy note ty)
614 split (NoteTy note@(UsgForAll _) fun_ty)
615 args = case split fun_ty args of
616 (tvs, ty) -> (tvs, NoteTy note ty)
617 split (NoteTy _ fun_ty) args = split fun_ty args
618 split (PredTy p) args = split (predRepTy p) args
619 split (ForAllTy tv fun_ty) (arg:args) = ASSERT2( isNotUsgTy arg, vcat (map pprType arg_tys) $$
620 text "in application of" <+> pprType fun_ty)
621 case split fun_ty args of
622 (tvs, ty) -> (tv:tvs, ty)
623 split other_ty args = panic "applyTys"
626 Note that we allow applications to be of usage-annotated- types, as an
627 extension: we handle them by lifting the annotation outside. The
628 argument, however, must still be unannotated.
631 hoistForAllTys :: Type -> Type
632 -- Move all the foralls to the top
633 -- e.g. T -> forall a. a ==> forall a. T -> a
635 = case hoist ty of { (tvs, body) -> mkForAllTys tvs body }
637 hoist :: Type -> ([TyVar], Type)
638 hoist ty = case splitFunTys ty of { (args, res) ->
639 case splitForAllTys res of {
640 ([], body) -> ([], ty) ;
641 (tvs1, body1) -> case hoist body1 of { (tvs2,body2) ->
642 (tvs1 ++ tvs2, mkFunTys args body2)
647 %************************************************************************
649 \subsection{Stuff to do with the source-language types}
651 PredType and ThetaType are used in types for expressions and bindings.
652 ClassPred and ClassContext are used in class and instance declarations.
654 %************************************************************************
656 "Dictionary" types are just ordinary data types, but you can
657 tell from the type constructor whether it's a dictionary or not.
660 mkClassPred clas tys = Class clas tys
662 mkDictTy :: Class -> [Type] -> Type
663 mkDictTy clas tys = mkPredTy (Class clas tys)
665 mkDictTys :: ClassContext -> [Type]
666 mkDictTys cxt = [mkDictTy cls tys | (cls,tys) <- cxt]
668 mkPredTy :: PredType -> Type
669 mkPredTy pred = PredTy pred
671 predRepTy :: PredType -> Type
672 -- Convert a predicate to its "representation type";
673 -- the type of evidence for that predicate, which is actually passed at runtime
674 predRepTy (Class clas tys) = TyConApp (classTyCon clas) tys
675 predRepTy (IParam n ty) = ty
677 isPredTy :: Type -> Bool
678 isPredTy (NoteTy _ ty) = isPredTy ty
679 isPredTy (PredTy _) = True
682 isDictTy :: Type -> Bool
683 isDictTy (NoteTy _ ty) = isDictTy ty
684 isDictTy (PredTy (Class _ _)) = True
685 isDictTy other = False
687 splitPredTy_maybe :: Type -> Maybe PredType
688 splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty
689 splitPredTy_maybe (PredTy p) = Just p
690 splitPredTy_maybe other = Nothing
692 splitDictTy :: Type -> (Class, [Type])
693 splitDictTy (NoteTy _ ty) = splitDictTy ty
694 splitDictTy (PredTy (Class clas tys)) = (clas, tys)
696 splitDictTy_maybe :: Type -> Maybe (Class, [Type])
697 splitDictTy_maybe (NoteTy _ ty) = splitDictTy ty
698 splitDictTy_maybe (PredTy (Class clas tys)) = Just (clas, tys)
699 splitDictTy_maybe other = Nothing
701 getClassTys_maybe :: PredType -> Maybe ClassPred
702 getClassTys_maybe (Class clas tys) = Just (clas, tys)
703 getClassTys_maybe _ = Nothing
705 ipName_maybe :: PredType -> Maybe Name
706 ipName_maybe (IParam n _) = Just n
707 ipName_maybe _ = Nothing
709 classesToPreds :: ClassContext -> ThetaType
710 classesToPreds cts = map (uncurry Class) cts
712 classesOfPreds :: ThetaType -> ClassContext
713 classesOfPreds theta = [(clas,tys) | Class clas tys <- theta]
716 @isTauTy@ tests for nested for-alls.
719 isTauTy :: Type -> Bool
720 isTauTy (TyVarTy v) = True
721 isTauTy (TyConApp _ tys) = all isTauTy tys
722 isTauTy (AppTy a b) = isTauTy a && isTauTy b
723 isTauTy (FunTy a b) = isTauTy a && isTauTy b
724 isTauTy (PredTy p) = isTauTy (predRepTy p)
725 isTauTy (NoteTy _ ty) = isTauTy ty
726 isTauTy other = False
730 mkRhoTy :: [PredType] -> Type -> Type
731 mkRhoTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
733 splitRhoTy :: Type -> ([PredType], Type)
734 splitRhoTy ty = split ty ty []
736 split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of
737 Just p -> split res res (p:ts)
738 Nothing -> (reverse ts, orig_ty)
739 split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts
740 split orig_ty ty ts = (reverse ts, orig_ty)
744 isSigmaType returns true of any qualified type. It doesn't *necessarily* have
746 f :: (?x::Int) => Int -> Int
749 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
751 isSigmaTy :: Type -> Bool
752 isSigmaTy (ForAllTy tyvar ty) = True
753 isSigmaTy (FunTy a b) = isPredTy a
754 isSigmaTy (NoteTy _ ty) = isSigmaTy ty
757 splitSigmaTy :: Type -> ([TyVar], [PredType], Type)
761 (tyvars,rho) = splitForAllTys ty
762 (theta,tau) = splitRhoTy rho
766 getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
767 -- construct a dictionary function name
768 getDFunTyKey (TyVarTy tv) = getOccName tv
769 getDFunTyKey (TyConApp tc _) = getOccName tc
770 getDFunTyKey (AppTy fun _) = getDFunTyKey fun
771 getDFunTyKey (NoteTy _ t) = getDFunTyKey t
772 getDFunTyKey (FunTy arg _) = getOccName funTyCon
773 getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
774 -- PredTy shouldn't happen
778 %************************************************************************
780 \subsection{Kinds and free variables}
782 %************************************************************************
784 ---------------------------------------------------------------------
785 Finding the kind of a type
786 ~~~~~~~~~~~~~~~~~~~~~~~~~~
788 typeKind :: Type -> Kind
790 typeKind (TyVarTy tyvar) = tyVarKind tyvar
791 typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
792 typeKind (NoteTy _ ty) = typeKind ty
793 typeKind (PredTy _) = boxedTypeKind -- Predicates are always
794 -- represented by boxed types
795 typeKind (AppTy fun arg) = funResultTy (typeKind fun)
797 typeKind (FunTy arg res) = fix_up (typeKind res)
799 fix_up (TyConApp tycon _) | tycon == typeCon
800 || tycon == openKindCon = boxedTypeKind
801 fix_up (NoteTy _ kind) = fix_up kind
803 -- The basic story is
804 -- typeKind (FunTy arg res) = typeKind res
805 -- But a function is boxed regardless of its result type
806 -- Hence the strange fix-up.
807 -- Note that 'res', being the result of a FunTy, can't have
808 -- a strange kind like (*->*).
810 typeKind (ForAllTy tv ty) = typeKind ty
814 ---------------------------------------------------------------------
815 Free variables of a type
816 ~~~~~~~~~~~~~~~~~~~~~~~~
819 tyVarsOfType :: Type -> TyVarSet
820 tyVarsOfType (TyVarTy tv) = unitVarSet tv
821 tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
822 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
823 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
824 tyVarsOfType (NoteTy (UsgNote _) ty) = tyVarsOfType ty
825 tyVarsOfType (NoteTy (UsgForAll _) ty) = tyVarsOfType ty
826 tyVarsOfType (PredTy p) = tyVarsOfPred p
827 tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
828 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
829 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
831 tyVarsOfTypes :: [Type] -> TyVarSet
832 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
834 tyVarsOfPred :: PredType -> TyVarSet
835 tyVarsOfPred (Class clas tys) = tyVarsOfTypes tys
836 tyVarsOfPred (IParam n ty) = tyVarsOfType ty
838 tyVarsOfTheta :: ThetaType -> TyVarSet
839 tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
841 -- Add a Note with the free tyvars to the top of the type
842 -- (but under a usage if there is one)
843 addFreeTyVars :: Type -> Type
844 addFreeTyVars (NoteTy note@(UsgNote _) ty) = NoteTy note (addFreeTyVars ty)
845 addFreeTyVars (NoteTy note@(UsgForAll _) ty) = NoteTy note (addFreeTyVars ty)
846 addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
847 addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
849 -- Find the free names of a type, including the type constructors and classes it mentions
850 namesOfType :: Type -> NameSet
851 namesOfType (TyVarTy tv) = unitNameSet (getName tv)
852 namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets`
854 namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1
855 namesOfType (NoteTy other_note ty2) = namesOfType ty2
856 namesOfType (PredTy p) = namesOfType (predRepTy p)
857 namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
858 namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
859 namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
861 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
865 %************************************************************************
867 \subsection{TidyType}
869 %************************************************************************
871 tidyTy tidies up a type for printing in an error message, or in
874 It doesn't change the uniques at all, just the print names.
877 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
878 tidyTyVar env@(tidy_env, subst) tyvar
879 = case lookupVarEnv subst tyvar of
881 Just tyvar' -> -- Already substituted
884 Nothing -> -- Make a new nice name for it
886 case tidyOccName tidy_env (getOccName name) of
887 (tidy', occ') -> -- New occname reqd
888 ((tidy', subst'), tyvar')
890 subst' = extendVarEnv subst tyvar tyvar'
891 tyvar' = setTyVarName tyvar name'
892 name' = mkLocalName (getUnique name) occ' noSrcLoc
893 -- Note: make a *user* tyvar, so it printes nicely
894 -- Could extract src loc, but no need.
896 name = tyVarName tyvar
898 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
900 tidyType :: TidyEnv -> Type -> Type
901 tidyType env@(tidy_env, subst) ty
904 go (TyVarTy tv) = case lookupVarEnv subst tv of
905 Nothing -> TyVarTy tv
906 Just tv' -> TyVarTy tv'
907 go (TyConApp tycon tys) = let args = map go tys
908 in args `seqList` TyConApp tycon args
909 go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
910 go (PredTy p) = PredTy (go_pred p)
911 go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
912 go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
913 go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty)
915 (envp, tvp) = tidyTyVar env tv
917 go_note (SynNote ty) = SynNote SAPPLY (go ty)
918 go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
919 go_note note@(UsgNote _) = note -- Usage annotation is already tidy
920 go_note note@(UsgForAll _) = note -- Uvar binder is already tidy
922 go_pred (Class c tys) = Class c (tidyTypes env tys)
923 go_pred (IParam n ty) = IParam n (go ty)
925 tidyTypes env tys = map (tidyType env) tys
929 @tidyOpenType@ grabs the free type variables, tidies them
930 and then uses @tidyType@ to work over the type itself
933 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
935 = (env', tidyType env' ty)
937 env' = foldl go env (varSetElems (tyVarsOfType ty))
938 go env tyvar = fst (tidyTyVar env tyvar)
940 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
941 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
943 tidyTopType :: Type -> Type
944 tidyTopType ty = tidyType emptyTidyEnv ty
949 %************************************************************************
951 \subsection{Boxedness and liftedness}
953 %************************************************************************
956 isUnboxedType :: Type -> Bool
957 isUnboxedType ty = not (isFollowableRep (typePrimRep ty))
959 isUnLiftedType :: Type -> Bool
960 -- isUnLiftedType returns True for forall'd unlifted types:
961 -- x :: forall a. Int#
962 -- I found bindings like these were getting floated to the top level.
963 -- They are pretty bogus types, mind you. It would be better never to
966 isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
967 isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty
968 isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
969 isUnLiftedType other = False
971 isUnboxedTupleType :: Type -> Bool
972 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
973 Just (tc, ty_args) -> isUnboxedTupleTyCon tc
976 -- Should only be applied to *types*; hence the assert
977 isAlgType :: Type -> Bool
978 isAlgType ty = case splitTyConApp_maybe ty of
979 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
983 -- Should only be applied to *types*; hence the assert
984 isDataType :: Type -> Bool
985 isDataType ty = case splitTyConApp_maybe ty of
986 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
990 isNewType :: Type -> Bool
991 isNewType ty = case splitTyConApp_maybe ty of
992 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
998 %************************************************************************
1000 \subsection{Sequencing on types
1002 %************************************************************************
1005 seqType :: Type -> ()
1006 seqType (TyVarTy tv) = tv `seq` ()
1007 seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
1008 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
1009 seqType (NoteTy note t2) = seqNote note `seq` seqType t2
1010 seqType (PredTy p) = seqPred p
1011 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
1012 seqType (ForAllTy tv ty) = tv `seq` seqType ty
1014 seqTypes :: [Type] -> ()
1016 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
1018 seqNote :: TyNote -> ()
1019 seqNote (SynNote ty) = seqType ty
1020 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
1021 seqNote (UsgNote usg) = usg `seq` ()
1023 seqPred :: PredType -> ()
1024 seqPred (Class c tys) = c `seq` seqTypes tys
1025 seqPred (IParam n ty) = n `seq` seqType ty
1029 %************************************************************************
1031 \subsection{Equality on types}
1033 %************************************************************************
1036 For the moment at least, type comparisons don't work if
1037 there are embedded for-alls.
1040 instance Eq Type where
1041 ty1 == ty2 = case ty1 `compare` ty2 of { EQ -> True; other -> False }
1043 instance Ord Type where
1044 compare ty1 ty2 = cmpTy emptyVarEnv ty1 ty2
1046 cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
1047 -- The "env" maps type variables in ty1 to type variables in ty2
1048 -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
1049 -- we in effect substitute tv2 for tv1 in t1 before continuing
1051 -- Get rid of NoteTy
1052 cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
1053 cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
1055 -- Get rid of PredTy
1056 cmpTy env (PredTy p1) (PredTy p2) = cmpPred env p1 p2
1057 cmpTy env (PredTy p1) ty2 = cmpTy env (predRepTy p1) ty2
1058 cmpTy env ty1 (PredTy p2) = cmpTy env ty1 (predRepTy p2)
1060 -- Deal with equal constructors
1061 cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
1062 Just tv1a -> tv1a `compare` tv2
1063 Nothing -> tv1 `compare` tv2
1065 cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1066 cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1067 cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
1068 cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2
1070 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
1071 cmpTy env (AppTy _ _) (TyVarTy _) = GT
1073 cmpTy env (FunTy _ _) (TyVarTy _) = GT
1074 cmpTy env (FunTy _ _) (AppTy _ _) = GT
1076 cmpTy env (TyConApp _ _) (TyVarTy _) = GT
1077 cmpTy env (TyConApp _ _) (AppTy _ _) = GT
1078 cmpTy env (TyConApp _ _) (FunTy _ _) = GT
1080 cmpTy env (ForAllTy _ _) other = GT
1085 cmpTys env [] [] = EQ
1086 cmpTys env (t:ts) [] = GT
1087 cmpTys env [] (t:ts) = LT
1088 cmpTys env (t1:t1s) (t2:t2s) = cmpTy env t1 t2 `thenCmp` cmpTys env t1s t2s
1092 instance Eq PredType where
1093 p1 == p2 = case p1 `compare` p2 of { EQ -> True; other -> False }
1095 instance Ord PredType where
1096 compare p1 p2 = cmpPred emptyVarEnv p1 p2
1098 cmpPred :: TyVarEnv TyVar -> PredType -> PredType -> Ordering
1099 cmpPred env (IParam n1 t) (IParam n2 t2) = n1 `compare` n2
1100 -- Just compare the names!
1101 cmpPred env (Class c1 tys1) (Class c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
1102 cmpPred env (IParam _ _) (Class _ _) = LT
1103 cmpPred env (Class _ _) (IParam _ _) = GT