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, splitDFunTy,
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, 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 )
83 import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
84 import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy )
87 import Var ( TyVar, UVar,
88 tyVarKind, tyVarName, setTyVarName,
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) = Just (splitDictTy ty)
698 splitDictTy_maybe (PredTy (Class clas tys)) = Just (clas, tys)
699 splitDictTy_maybe other = Nothing
701 splitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
702 -- Split the type of a dictionary function
704 = case splitSigmaTy ty of { (tvs, theta, tau) ->
705 case splitDictTy tau of { (clas, tys) ->
706 (tvs, theta, clas, tys) }}
708 getClassTys_maybe :: PredType -> Maybe ClassPred
709 getClassTys_maybe (Class clas tys) = Just (clas, tys)
710 getClassTys_maybe _ = Nothing
712 ipName_maybe :: PredType -> Maybe Name
713 ipName_maybe (IParam n _) = Just n
714 ipName_maybe _ = Nothing
716 classesOfPreds :: ThetaType -> ClassContext
717 classesOfPreds theta = [(clas,tys) | Class clas tys <- theta]
720 @isTauTy@ tests for nested for-alls.
723 isTauTy :: Type -> Bool
724 isTauTy (TyVarTy v) = True
725 isTauTy (TyConApp _ tys) = all isTauTy tys
726 isTauTy (AppTy a b) = isTauTy a && isTauTy b
727 isTauTy (FunTy a b) = isTauTy a && isTauTy b
728 isTauTy (PredTy p) = isTauTy (predRepTy p)
729 isTauTy (NoteTy _ ty) = isTauTy ty
730 isTauTy other = False
734 mkRhoTy :: [PredType] -> Type -> Type
735 mkRhoTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
737 splitRhoTy :: Type -> ([PredType], Type)
738 splitRhoTy ty = split ty ty []
740 split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of
741 Just p -> split res res (p:ts)
742 Nothing -> (reverse ts, orig_ty)
743 split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts
744 split orig_ty ty ts = (reverse ts, orig_ty)
748 isSigmaType returns true of any qualified type. It doesn't *necessarily* have
750 f :: (?x::Int) => Int -> Int
753 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
755 isSigmaTy :: Type -> Bool
756 isSigmaTy (ForAllTy tyvar ty) = True
757 isSigmaTy (FunTy a b) = isPredTy a
758 isSigmaTy (NoteTy _ ty) = isSigmaTy ty
761 splitSigmaTy :: Type -> ([TyVar], [PredType], Type)
765 (tyvars,rho) = splitForAllTys ty
766 (theta,tau) = splitRhoTy rho
770 getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
771 -- construct a dictionary function name
772 getDFunTyKey (TyVarTy tv) = getOccName tv
773 getDFunTyKey (TyConApp tc _) = getOccName tc
774 getDFunTyKey (AppTy fun _) = getDFunTyKey fun
775 getDFunTyKey (NoteTy _ t) = getDFunTyKey t
776 getDFunTyKey (FunTy arg _) = getOccName funTyCon
777 getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
778 -- PredTy shouldn't happen
782 %************************************************************************
784 \subsection{Kinds and free variables}
786 %************************************************************************
788 ---------------------------------------------------------------------
789 Finding the kind of a type
790 ~~~~~~~~~~~~~~~~~~~~~~~~~~
792 typeKind :: Type -> Kind
794 typeKind (TyVarTy tyvar) = tyVarKind tyvar
795 typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
796 typeKind (NoteTy _ ty) = typeKind ty
797 typeKind (PredTy _) = boxedTypeKind -- Predicates are always
798 -- represented by boxed types
799 typeKind (AppTy fun arg) = funResultTy (typeKind fun)
801 typeKind (FunTy arg res) = fix_up (typeKind res)
803 fix_up (TyConApp tycon _) | tycon == typeCon
804 || tycon == openKindCon = boxedTypeKind
805 fix_up (NoteTy _ kind) = fix_up kind
807 -- The basic story is
808 -- typeKind (FunTy arg res) = typeKind res
809 -- But a function is boxed regardless of its result type
810 -- Hence the strange fix-up.
811 -- Note that 'res', being the result of a FunTy, can't have
812 -- a strange kind like (*->*).
814 typeKind (ForAllTy tv ty) = typeKind ty
818 ---------------------------------------------------------------------
819 Free variables of a type
820 ~~~~~~~~~~~~~~~~~~~~~~~~
823 tyVarsOfType :: Type -> TyVarSet
824 tyVarsOfType (TyVarTy tv) = unitVarSet tv
825 tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
826 tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
827 tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
828 tyVarsOfType (NoteTy (UsgNote _) ty) = tyVarsOfType ty
829 tyVarsOfType (NoteTy (UsgForAll _) ty) = tyVarsOfType ty
830 tyVarsOfType (PredTy p) = tyVarsOfPred p
831 tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
832 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
833 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
835 tyVarsOfTypes :: [Type] -> TyVarSet
836 tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
838 tyVarsOfPred :: PredType -> TyVarSet
839 tyVarsOfPred (Class clas tys) = tyVarsOfTypes tys
840 tyVarsOfPred (IParam n ty) = tyVarsOfType ty
842 tyVarsOfTheta :: ThetaType -> TyVarSet
843 tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
845 -- Add a Note with the free tyvars to the top of the type
846 -- (but under a usage if there is one)
847 addFreeTyVars :: Type -> Type
848 addFreeTyVars (NoteTy note@(UsgNote _) ty) = NoteTy note (addFreeTyVars ty)
849 addFreeTyVars (NoteTy note@(UsgForAll _) ty) = NoteTy note (addFreeTyVars ty)
850 addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
851 addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
853 -- Find the free names of a type, including the type constructors and classes it mentions
854 namesOfType :: Type -> NameSet
855 namesOfType (TyVarTy tv) = unitNameSet (getName tv)
856 namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets`
858 namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1
859 namesOfType (NoteTy other_note ty2) = namesOfType ty2
860 namesOfType (PredTy p) = namesOfType (predRepTy p)
861 namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
862 namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
863 namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
865 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
869 %************************************************************************
871 \subsection{TidyType}
873 %************************************************************************
875 tidyTy tidies up a type for printing in an error message, or in
878 It doesn't change the uniques at all, just the print names.
881 tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
882 tidyTyVar env@(tidy_env, subst) tyvar
883 = case lookupVarEnv subst tyvar of
885 Just tyvar' -> -- Already substituted
888 Nothing -> -- Make a new nice name for it
890 case tidyOccName tidy_env (getOccName name) of
891 (tidy', occ') -> -- New occname reqd
892 ((tidy', subst'), tyvar')
894 subst' = extendVarEnv subst tyvar tyvar'
895 tyvar' = setTyVarName tyvar name'
896 name' = mkLocalName (getUnique name) occ' noSrcLoc
897 -- Note: make a *user* tyvar, so it printes nicely
898 -- Could extract src loc, but no need.
900 name = tyVarName tyvar
902 tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
904 tidyType :: TidyEnv -> Type -> Type
905 tidyType env@(tidy_env, subst) ty
908 go (TyVarTy tv) = case lookupVarEnv subst tv of
909 Nothing -> TyVarTy tv
910 Just tv' -> TyVarTy tv'
911 go (TyConApp tycon tys) = let args = map go tys
912 in args `seqList` TyConApp tycon args
913 go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
914 go (PredTy p) = PredTy (go_pred p)
915 go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
916 go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
917 go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty)
919 (envp, tvp) = tidyTyVar env tv
921 go_note (SynNote ty) = SynNote SAPPLY (go ty)
922 go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
923 go_note note@(UsgNote _) = note -- Usage annotation is already tidy
924 go_note note@(UsgForAll _) = note -- Uvar binder is already tidy
926 go_pred (Class c tys) = Class c (tidyTypes env tys)
927 go_pred (IParam n ty) = IParam n (go ty)
929 tidyTypes env tys = map (tidyType env) tys
933 @tidyOpenType@ grabs the free type variables, tidies them
934 and then uses @tidyType@ to work over the type itself
937 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
939 = (env', tidyType env' ty)
941 env' = foldl go env (varSetElems (tyVarsOfType ty))
942 go env tyvar = fst (tidyTyVar env tyvar)
944 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
945 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
947 tidyTopType :: Type -> Type
948 tidyTopType ty = tidyType emptyTidyEnv ty
953 %************************************************************************
955 \subsection{Boxedness and liftedness}
957 %************************************************************************
960 isUnboxedType :: Type -> Bool
961 isUnboxedType ty = not (isFollowableRep (typePrimRep ty))
963 isUnLiftedType :: Type -> Bool
964 -- isUnLiftedType returns True for forall'd unlifted types:
965 -- x :: forall a. Int#
966 -- I found bindings like these were getting floated to the top level.
967 -- They are pretty bogus types, mind you. It would be better never to
970 isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
971 isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty
972 isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
973 isUnLiftedType other = False
975 isUnboxedTupleType :: Type -> Bool
976 isUnboxedTupleType ty = case splitTyConApp_maybe ty of
977 Just (tc, ty_args) -> isUnboxedTupleTyCon tc
980 -- Should only be applied to *types*; hence the assert
981 isAlgType :: Type -> Bool
982 isAlgType ty = case splitTyConApp_maybe ty of
983 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
987 -- Should only be applied to *types*; hence the assert
988 isDataType :: Type -> Bool
989 isDataType ty = case splitTyConApp_maybe ty of
990 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
994 isNewType :: Type -> Bool
995 isNewType ty = case splitTyConApp_maybe ty of
996 Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
1002 %************************************************************************
1004 \subsection{Sequencing on types
1006 %************************************************************************
1009 seqType :: Type -> ()
1010 seqType (TyVarTy tv) = tv `seq` ()
1011 seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
1012 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
1013 seqType (NoteTy note t2) = seqNote note `seq` seqType t2
1014 seqType (PredTy p) = seqPred p
1015 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
1016 seqType (ForAllTy tv ty) = tv `seq` seqType ty
1018 seqTypes :: [Type] -> ()
1020 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
1022 seqNote :: TyNote -> ()
1023 seqNote (SynNote ty) = seqType ty
1024 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
1025 seqNote (UsgNote usg) = usg `seq` ()
1027 seqPred :: PredType -> ()
1028 seqPred (Class c tys) = c `seq` seqTypes tys
1029 seqPred (IParam n ty) = n `seq` seqType ty
1033 %************************************************************************
1035 \subsection{Equality on types}
1037 %************************************************************************
1040 For the moment at least, type comparisons don't work if
1041 there are embedded for-alls.
1044 instance Eq Type where
1045 ty1 == ty2 = case ty1 `compare` ty2 of { EQ -> True; other -> False }
1047 instance Ord Type where
1048 compare ty1 ty2 = cmpTy emptyVarEnv ty1 ty2
1050 cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
1051 -- The "env" maps type variables in ty1 to type variables in ty2
1052 -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
1053 -- we in effect substitute tv2 for tv1 in t1 before continuing
1055 -- Get rid of NoteTy
1056 cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
1057 cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
1059 -- Get rid of PredTy
1060 cmpTy env (PredTy p1) (PredTy p2) = cmpPred env p1 p2
1061 cmpTy env (PredTy p1) ty2 = cmpTy env (predRepTy p1) ty2
1062 cmpTy env ty1 (PredTy p2) = cmpTy env ty1 (predRepTy p2)
1064 -- Deal with equal constructors
1065 cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
1066 Just tv1a -> tv1a `compare` tv2
1067 Nothing -> tv1 `compare` tv2
1069 cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1070 cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
1071 cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
1072 cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2
1074 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
1075 cmpTy env (AppTy _ _) (TyVarTy _) = GT
1077 cmpTy env (FunTy _ _) (TyVarTy _) = GT
1078 cmpTy env (FunTy _ _) (AppTy _ _) = GT
1080 cmpTy env (TyConApp _ _) (TyVarTy _) = GT
1081 cmpTy env (TyConApp _ _) (AppTy _ _) = GT
1082 cmpTy env (TyConApp _ _) (FunTy _ _) = GT
1084 cmpTy env (ForAllTy _ _) other = GT
1089 cmpTys env [] [] = EQ
1090 cmpTys env (t:ts) [] = GT
1091 cmpTys env [] (t:ts) = LT
1092 cmpTys env (t1:t1s) (t2:t2s) = cmpTy env t1 t2 `thenCmp` cmpTys env t1s t2s
1096 instance Eq PredType where
1097 p1 == p2 = case p1 `compare` p2 of { EQ -> True; other -> False }
1099 instance Ord PredType where
1100 compare p1 p2 = cmpPred emptyVarEnv p1 p2
1102 cmpPred :: TyVarEnv TyVar -> PredType -> PredType -> Ordering
1103 cmpPred env (IParam n1 t) (IParam n2 t2) = n1 `compare` n2
1104 -- Just compare the names!
1105 cmpPred env (Class c1 tys1) (Class c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
1106 cmpPred env (IParam _ _) (Class _ _) = LT
1107 cmpPred env (Class _ _) (IParam _ _) = GT