2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
4 \section[Type]{Type - public interface}
8 -- re-exports from TypeRep:
12 superKind, superBoxity, -- KX and BX respectively
13 boxedBoxity, unboxedBoxity, -- :: BX
15 typeCon, -- :: BX -> KX
16 boxedTypeKind, unboxedTypeKind, openTypeKind, -- :: KX
17 mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX
21 -- exports from this module:
22 hasMoreBoxityInfo, defaultKind,
24 mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
26 mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
28 mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, splitFunTysN,
29 funResultTy, funArgTy, zipFunTys,
31 mkTyConApp, mkTyConTy, splitTyConApp_maybe,
32 splitAlgTyConApp_maybe, splitAlgTyConApp,
34 -- Predicates and the like
35 mkDictTy, mkDictTys, mkPredTy, splitPredTy_maybe,
36 splitDictTy_maybe, isDictTy, predRepTy,
38 mkSynTy, isSynTy, deNoteType,
40 repType, splitRepFunTys, splitNewType_maybe, typePrimRep,
42 UsageAnn(..), mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg,
43 mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy,
45 mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
46 applyTy, applyTys, hoistForAllTys,
48 TauType, RhoType, SigmaType, PredType(..), ThetaType,
49 ClassPred, ClassContext, mkClassPred,
50 getClassTys_maybe, ipName_maybe, classesToPreds, classesOfPreds,
51 isTauTy, mkRhoTy, splitRhoTy,
52 mkSigmaTy, isSigmaTy, splitSigmaTy,
56 isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
59 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
60 namesOfType, typeKind, addFreeTyVars,
62 -- Tidying up for printing
64 tidyOpenType, tidyOpenTypes,
65 tidyTyVar, tidyTyVars,
73 #include "HsVersions.h"
75 -- We import the representation and primitive functions from TypeRep.
76 -- Many things are reexported, but not the representation!
82 import {-# SOURCE #-} DataCon( DataCon, dataConRepType )
83 import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
84 import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy )
87 import Var ( TyVar, Var, UVar,
88 tyVarKind, tyVarName, setTyVarName, isId, idType,
93 import Name ( Name, NamedThing(..), OccName, mkLocalName, tidyOccName )
95 import Class ( classTyCon, Class, ClassPred, ClassContext )
97 isUnboxedTupleTyCon, isUnLiftedTyCon,
98 isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep,
99 isAlgTyCon, isSynTyCon, tyConArity,
100 tyConKind, tyConDataCons, getSynTyConDefn,
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_maybe :: Type -> Maybe (Class, [Type])
693 splitDictTy_maybe ty = case splitPredTy_maybe ty of
694 Just p -> getClassTys_maybe p
697 getClassTys_maybe :: PredType -> Maybe ClassPred
698 getClassTys_maybe (Class clas tys) = Just (clas, tys)
699 getClassTys_maybe _ = Nothing
701 ipName_maybe :: PredType -> Maybe Name
702 ipName_maybe (IParam n _) = Just n
703 ipName_maybe _ = Nothing
705 classesToPreds :: ClassContext -> ThetaType
706 classesToPreds cts = map (uncurry Class) cts
708 classesOfPreds :: ThetaType -> ClassContext
709 classesOfPreds theta = [(clas,tys) | Class clas tys <- theta]
712 @isTauTy@ tests for nested for-alls.
715 isTauTy :: Type -> Bool
716 isTauTy (TyVarTy v) = True
717 isTauTy (TyConApp _ tys) = all isTauTy tys
718 isTauTy (AppTy a b) = isTauTy a && isTauTy b
719 isTauTy (FunTy a b) = isTauTy a && isTauTy b
720 isTauTy (PredTy p) = isTauTy (predRepTy p)
721 isTauTy (NoteTy _ ty) = isTauTy ty
722 isTauTy other = False
726 mkRhoTy :: [PredType] -> Type -> Type
727 mkRhoTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
729 splitRhoTy :: Type -> ([PredType], Type)
730 splitRhoTy ty = split ty ty []
732 split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of
733 Just p -> split res res (p:ts)
734 Nothing -> (reverse ts, orig_ty)
735 split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts
736 split orig_ty ty ts = (reverse ts, orig_ty)
740 isSigmaType returns true of any qualified type. It doesn't *necessarily* have
742 f :: (?x::Int) => Int -> Int
745 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
747 isSigmaTy :: Type -> Bool
748 isSigmaTy (ForAllTy tyvar ty) = True
749 isSigmaTy (FunTy a b) = isPredTy a
750 isSigmaTy (NoteTy _ ty) = isSigmaTy ty
753 splitSigmaTy :: Type -> ([TyVar], [PredType], Type)
757 (tyvars,rho) = splitForAllTys ty
758 (theta,tau) = splitRhoTy rho
762 getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
763 -- construct a dictionary function name
764 getDFunTyKey (TyVarTy tv) = getOccName tv
765 getDFunTyKey (TyConApp tc _) = getOccName tc
766 getDFunTyKey (AppTy fun _) = getDFunTyKey fun
767 getDFunTyKey (NoteTy _ t) = getDFunTyKey t
768 getDFunTyKey (FunTy arg _) = getOccName funTyCon
769 getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
770 -- PredTy shouldn't happen
774 %************************************************************************
776 \subsection{Kinds and free variables}
778 %************************************************************************
780 ---------------------------------------------------------------------
781 Finding the kind of a type
782 ~~~~~~~~~~~~~~~~~~~~~~~~~~
784 typeKind :: Type -> Kind
786 typeKind (TyVarTy tyvar) = tyVarKind tyvar
787 typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
788 typeKind (NoteTy _ ty) = typeKind ty
789 typeKind (PredTy _) = boxedTypeKind -- Predicates are always
790 -- represented by boxed types
791 typeKind (AppTy fun arg) = funResultTy (typeKind fun)
793 typeKind (FunTy arg res) = fix_up (typeKind res)
795 fix_up (TyConApp tycon _) | tycon == typeCon
796 || tycon == openKindCon = boxedTypeKind
797 fix_up (NoteTy _ kind) = fix_up kind
799 -- The basic story is
800 -- typeKind (FunTy arg res) = typeKind res
801 -- But a function is boxed regardless of its result type
802 -- Hence the strange fix-up.
803 -- Note that 'res', being the result of a FunTy, can't have
804 -- a strange kind like (*->*).
806 typeKind (ForAllTy tv ty) = typeKind ty
810 ---------------------------------------------------------------------
811 Free variables of a type
812 ~~~~~~~~~~~~~~~~~~~~~~~~
815 tyVarsOfType :: Type -> TyVarSet
816 tyVarsOfType (TyVarTy tv) = unitVarSet tv
817 tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
818 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
819 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
820 tyVarsOfType (NoteTy (UsgNote _) ty) = tyVarsOfType ty
821 tyVarsOfType (NoteTy (UsgForAll _) ty) = tyVarsOfType ty
822 tyVarsOfType (PredTy p) = tyVarsOfPred p
823 tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
824 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
825 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
827 tyVarsOfTypes :: [Type] -> TyVarSet
828 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
830 tyVarsOfPred :: PredType -> TyVarSet
831 tyVarsOfPred (Class clas tys) = tyVarsOfTypes tys
832 tyVarsOfPred (IParam n ty) = tyVarsOfType ty
834 tyVarsOfTheta :: ThetaType -> TyVarSet
835 tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
837 -- Add a Note with the free tyvars to the top of the type
838 -- (but under a usage if there is one)
839 addFreeTyVars :: Type -> Type
840 addFreeTyVars (NoteTy note@(UsgNote _) ty) = NoteTy note (addFreeTyVars ty)
841 addFreeTyVars (NoteTy note@(UsgForAll _) ty) = NoteTy note (addFreeTyVars ty)
842 addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
843 addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
845 -- Find the free names of a type, including the type constructors and classes it mentions
846 namesOfType :: Type -> NameSet
847 namesOfType (TyVarTy tv) = unitNameSet (getName tv)
848 namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets`
850 namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1
851 namesOfType (NoteTy other_note ty2) = namesOfType ty2
852 namesOfType (PredTy p) = namesOfType (predRepTy p)
853 namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
854 namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
855 namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
857 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
861 %************************************************************************
863 \subsection{TidyType}
865 %************************************************************************
867 tidyTy tidies up a type for printing in an error message, or in
870 It doesn't change the uniques at all, just the print names.
873 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
874 tidyTyVar env@(tidy_env, subst) tyvar
875 = case lookupVarEnv subst tyvar of
877 Just tyvar' -> -- Already substituted
880 Nothing -> -- Make a new nice name for it
882 case tidyOccName tidy_env (getOccName name) of
883 (tidy', occ') -> -- New occname reqd
884 ((tidy', subst'), tyvar')
886 subst' = extendVarEnv subst tyvar tyvar'
887 tyvar' = setTyVarName tyvar name'
888 name' = mkLocalName (getUnique name) occ' noSrcLoc
889 -- Note: make a *user* tyvar, so it printes nicely
890 -- Could extract src loc, but no need.
892 name = tyVarName tyvar
894 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
896 tidyType :: TidyEnv -> Type -> Type
897 tidyType env@(tidy_env, subst) ty
900 go (TyVarTy tv) = case lookupVarEnv subst tv of
901 Nothing -> TyVarTy tv
902 Just tv' -> TyVarTy tv'
903 go (TyConApp tycon tys) = let args = map go tys
904 in args `seqList` TyConApp tycon args
905 go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
906 go (PredTy p) = PredTy (go_pred p)
907 go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
908 go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
909 go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty)
911 (envp, tvp) = tidyTyVar env tv
913 go_note (SynNote ty) = SynNote SAPPLY (go ty)
914 go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
915 go_note note@(UsgNote _) = note -- Usage annotation is already tidy
916 go_note note@(UsgForAll _) = note -- Uvar binder is already tidy
918 go_pred (Class c tys) = Class c (tidyTypes env tys)
919 go_pred (IParam n ty) = IParam n (go ty)
921 tidyTypes env tys = map (tidyType env) tys
925 @tidyOpenType@ grabs the free type variables, tidies them
926 and then uses @tidyType@ to work over the type itself
929 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
931 = (env', tidyType env' ty)
933 env' = foldl go env (varSetElems (tyVarsOfType ty))
934 go env tyvar = fst (tidyTyVar env tyvar)
936 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
937 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
939 tidyTopType :: Type -> Type
940 tidyTopType ty = tidyType emptyTidyEnv ty
945 %************************************************************************
947 \subsection{Boxedness and liftedness}
949 %************************************************************************
952 isUnboxedType :: Type -> Bool
953 isUnboxedType ty = not (isFollowableRep (typePrimRep ty))
955 isUnLiftedType :: Type -> Bool
956 -- isUnLiftedType returns True for forall'd unlifted types:
957 -- x :: forall a. Int#
958 -- I found bindings like these were getting floated to the top level.
959 -- They are pretty bogus types, mind you. It would be better never to
962 isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
963 isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty
964 isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
965 isUnLiftedType other = False
967 isUnboxedTupleType :: Type -> Bool
968 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
969 Just (tc, ty_args) -> isUnboxedTupleTyCon tc
972 -- Should only be applied to *types*; hence the assert
973 isAlgType :: Type -> Bool
974 isAlgType ty = case splitTyConApp_maybe ty of
975 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
979 -- Should only be applied to *types*; hence the assert
980 isDataType :: Type -> Bool
981 isDataType ty = case splitTyConApp_maybe ty of
982 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
986 isNewType :: Type -> Bool
987 isNewType ty = case splitTyConApp_maybe ty of
988 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
994 %************************************************************************
996 \subsection{Sequencing on types
998 %************************************************************************
1001 seqType :: Type -> ()
1002 seqType (TyVarTy tv) = tv `seq` ()
1003 seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
1004 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
1005 seqType (NoteTy note t2) = seqNote note `seq` seqType t2
1006 seqType (PredTy p) = seqPred p
1007 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
1008 seqType (ForAllTy tv ty) = tv `seq` seqType ty
1010 seqTypes :: [Type] -> ()
1012 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
1014 seqNote :: TyNote -> ()
1015 seqNote (SynNote ty) = seqType ty
1016 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
1017 seqNote (UsgNote usg) = usg `seq` ()
1019 seqPred :: PredType -> ()
1020 seqPred (Class c tys) = c `seq` seqTypes tys
1021 seqPred (IParam n ty) = n `seq` seqType ty
1025 %************************************************************************
1027 \subsection{Equality on types}
1029 %************************************************************************
1032 For the moment at least, type comparisons don't work if
1033 there are embedded for-alls.
1036 instance Eq Type where
1037 ty1 == ty2 = case ty1 `compare` ty2 of { EQ -> True; other -> False }
1039 instance Ord Type where
1040 compare ty1 ty2 = cmpTy emptyVarEnv ty1 ty2
1042 cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
1043 -- The "env" maps type variables in ty1 to type variables in ty2
1044 -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
1045 -- we in effect substitute tv2 for tv1 in t1 before continuing
1047 -- Get rid of NoteTy
1048 cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
1049 cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
1051 -- Get rid of PredTy
1052 cmpTy env (PredTy p1) (PredTy p2) = cmpPred env p1 p2
1053 cmpTy env (PredTy p1) ty2 = cmpTy env (predRepTy p1) ty2
1054 cmpTy env ty1 (PredTy p2) = cmpTy env ty1 (predRepTy p2)
1056 -- Deal with equal constructors
1057 cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
1058 Just tv1a -> tv1a `compare` tv2
1059 Nothing -> tv1 `compare` tv2
1061 cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1062 cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1063 cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
1064 cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2
1066 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
1067 cmpTy env (AppTy _ _) (TyVarTy _) = GT
1069 cmpTy env (FunTy _ _) (TyVarTy _) = GT
1070 cmpTy env (FunTy _ _) (AppTy _ _) = GT
1072 cmpTy env (TyConApp _ _) (TyVarTy _) = GT
1073 cmpTy env (TyConApp _ _) (AppTy _ _) = GT
1074 cmpTy env (TyConApp _ _) (FunTy _ _) = GT
1076 cmpTy env (ForAllTy _ _) other = GT
1081 cmpTys env [] [] = EQ
1082 cmpTys env (t:ts) [] = GT
1083 cmpTys env [] (t:ts) = LT
1084 cmpTys env (t1:t1s) (t2:t2s) = cmpTy env t1 t2 `thenCmp` cmpTys env t1s t2s
1088 instance Eq PredType where
1089 p1 == p2 = case p1 `compare` p2 of { EQ -> True; other -> False }
1091 instance Ord PredType where
1092 compare p1 p2 = cmpPred emptyVarEnv p1 p2
1094 cmpPred :: TyVarEnv TyVar -> PredType -> PredType -> Ordering
1095 cmpPred env (IParam n1 t) (IParam n2 t2) = n1 `compare` n2
1096 -- Just compare the names!
1097 cmpPred env (Class c1 tys1) (Class c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
1098 cmpPred env (IParam _ _) (Class _ _) = LT
1099 cmpPred env (Class _ _) (IParam _ _) = GT