2 #include "HsVersions.h"
5 GenType(..), SYN_IE(Type), SYN_IE(TauType),
7 getTyVar, getTyVar_maybe, isTyVarTy,
8 mkAppTy, mkAppTys, splitAppTy, splitAppTys,
10 splitFunTy, splitFunTyExpandingDicts, splitFunTyExpandingDictsAndPeeking,
11 getFunTy_maybe, getFunTyExpandingDicts_maybe,
12 mkTyConTy, getTyCon_maybe, applyTyCon,
14 mkForAllTy, mkForAllTys, getForAllTy_maybe, getForAllTyExpandingDicts_maybe, splitForAllTy, splitForAllTyExpandingDicts,
15 mkForAllUsageTy, getForAllUsageTy,
18 expandTy, -- only let out for debugging (ToDo: rm?)
20 isPrimType, isUnboxedType, typePrimRep,
22 SYN_IE(RhoType), SYN_IE(SigmaType), SYN_IE(ThetaType),
24 mkRhoTy, splitRhoTy, mkTheta, isDictTy,
25 mkSigmaTy, splitSigmaTy,
27 maybeAppTyCon, getAppTyCon,
28 maybeAppDataTyCon, getAppDataTyCon, getAppSpecDataTyCon,
29 maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts,
30 getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts,
33 matchTy, matchTys, eqTy, eqSimpleTy, eqSimpleTheta,
35 instantiateTy, instantiateTauTy, instantiateUsage,
40 tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind,
45 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
46 IMPORT_DELOOPER(IdLoop) -- for paranoia checking
47 IMPORT_DELOOPER(TyLoop)
48 --IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
50 import {-# SOURCE #-} Id ( Id, dataConArgTys )
51 import {-# SOURCE #-} TysPrim ( voidTy )
52 import {-# SOURCE #-} TysWiredIn ( tupleTyCon )
56 import Class ( classSig, classOpLocalType, GenClass{-instances-}, SYN_IE(Class) )
57 import Kind ( mkBoxedTypeKind, resultKind, notArrowKind, Kind )
58 import TyCon ( mkFunTyCon, isFunTyCon, isEnumerationTyCon, isTupleTyCon, maybeTyConSingleCon,
59 isPrimTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, maybeNewTyCon, isNewTyCon,
60 tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
61 import TyVar ( tyVarKind, GenTyVar{-instances-}, SYN_IE(GenTyVarSet),
62 emptyTyVarSet, unionTyVarSets, minusTyVarSet,
63 unitTyVarSet, nullTyVarEnv, lookupTyVarEnv, delFromTyVarEnv,
64 addOneToTyVarEnv, SYN_IE(TyVarEnv), SYN_IE(TyVar) )
65 import Usage ( usageOmega, GenUsage, SYN_IE(Usage), SYN_IE(UVar), SYN_IE(UVarEnv),
66 nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar,
69 import Name ( NamedThing(..),
70 NameSet(..), unionNameSets, emptyNameSet, unitNameSet, minusNameSet
74 import Maybes ( maybeToBool, assocMaybe )
75 import PrimRep ( PrimRep(..) )
76 import Unique -- quite a few *Keys
77 import Util ( thenCmp, zipEqual, assoc,
78 panic, panic#, assertPanic, pprPanic,
87 -- PprType --(pprType )
95 type Type = GenType TyVar UVar -- Used after typechecker
97 data GenType tyvar uvar -- Parameterised over type and usage variables
104 | TyConTy -- Constants of a specified kind
105 TyCon -- Must *not* be a SynTyCon
106 (GenUsage uvar) -- Usage gives uvar of the full application,
107 -- iff the full application is of kind Type
108 -- c.f. the Usage field in TyVars
110 | SynTy -- Synonyms must be saturated, and contain their expansion
111 TyCon -- Must be a SynTyCon
113 (GenType tyvar uvar) -- Expansion!
117 (GenType tyvar uvar) -- TypeKind
120 uvar -- Quantify over this
121 [uvar] -- Bounds; the quantified var must be
122 -- less than or equal to all these
125 -- Two special cases that save a *lot* of administrative
128 | FunTy -- BoxedTypeKind
129 (GenType tyvar uvar) -- Both args are of TypeKind
135 (GenType tyvar uvar) -- Arg has kind TypeKind
142 type ThetaType = [(Class, Type)]
143 type SigmaType = Type
147 Notes on type synonyms
148 ~~~~~~~~~~~~~~~~~~~~~~
149 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
150 to return type synonyms whereever possible. Thus
155 splitFunTys (a -> Foo a) = ([a], Foo a)
158 The reason is that we then get better (shorter) type signatures in
159 interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
164 Removes just the top level of any abbreviations.
167 expandTy :: Type -> Type -- Restricted to Type due to Dict expansion
169 expandTy (FunTy t1 t2 u) = AppTy (AppTy (TyConTy mkFunTyCon u) t1) t2
170 expandTy (SynTy _ _ t) = expandTy t
171 expandTy (DictTy clas ty u)
172 = case all_arg_tys of
174 [] -> voidTy -- Empty dictionary represented by Void
176 [arg_ty] -> expandTy arg_ty -- just the <whatever> itself
178 -- The extra expandTy is to make sure that
179 -- the result isn't still a dict, which it might be
180 -- if the original guy was a dict with one superdict and
183 other -> ASSERT(not (null all_arg_tys))
184 foldl AppTy (TyConTy (tupleTyCon (length all_arg_tys)) u) all_arg_tys
187 -- Note: length of all_arg_tys can be 0 if the class is
188 -- CCallable, CReturnable (and anything else
189 -- *really weird* that the user writes).
191 (tyvar, super_classes, ops) = classSig clas
192 super_dict_tys = map mk_super_ty super_classes
193 class_op_tys = map mk_op_ty ops
194 all_arg_tys = super_dict_tys ++ class_op_tys
195 mk_super_ty sc = DictTy sc ty usageOmega
196 mk_op_ty op = instantiateTy [(tyvar,ty)] (classOpLocalType op)
201 Simple construction and analysis functions
202 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
204 mkTyVarTy :: t -> GenType t u
205 mkTyVarTys :: [t] -> [GenType t y]
207 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
209 getTyVar :: String -> GenType t u -> t
210 getTyVar msg (TyVarTy tv) = tv
211 getTyVar msg (SynTy _ _ t) = getTyVar msg t
212 getTyVar msg other = panic ("getTyVar: " ++ msg)
214 getTyVar_maybe :: GenType t u -> Maybe t
215 getTyVar_maybe (TyVarTy tv) = Just tv
216 getTyVar_maybe (SynTy _ _ t) = getTyVar_maybe t
217 getTyVar_maybe other = Nothing
219 isTyVarTy :: GenType t u -> Bool
220 isTyVarTy (TyVarTy tv) = True
221 isTyVarTy (SynTy _ _ t) = isTyVarTy t
222 isTyVarTy other = False
228 mkAppTys :: GenType t u -> [GenType t u] -> GenType t u
229 mkAppTys t ts = foldl AppTy t ts
231 splitAppTy :: GenType t u -> (GenType t u, GenType t u)
232 splitAppTy (AppTy t arg) = (t,arg)
233 splitAppTy (SynTy _ _ t) = splitAppTy t
234 splitAppTy other = panic "splitAppTy"
236 splitAppTys :: GenType t u -> (GenType t u, [GenType t u])
237 splitAppTys t = go t []
239 go (AppTy t arg) ts = go t (arg:ts)
240 go (FunTy fun arg u) ts = (TyConTy mkFunTyCon u, fun:arg:ts)
241 go (SynTy _ _ t) ts = go t ts
246 -- NB mkFunTy, mkFunTys puts in Omega usages, for now at least
247 mkFunTy arg res = FunTy arg res usageOmega
249 mkFunTys :: [GenType t u] -> GenType t u -> GenType t u
250 mkFunTys ts t = foldr (\ f a -> FunTy f a usageOmega) t ts
252 -- getFunTy_maybe and splitFunTy *must* have the general type given, which
253 -- means they *can't* do the DictTy jiggery-pokery that
254 -- *is* sometimes required. Hence we also have the ExpandingDicts variants
255 -- The relationship between these
256 -- two functions is like that between eqTy and eqSimpleTy.
257 -- ToDo: NUKE when we do dicts via newtype
259 getFunTy_maybe :: GenType t u -> Maybe (GenType t u, GenType t u)
263 -- See notes on type synonyms above
264 go syn_t (FunTy arg result _) = Just (arg,result)
265 go syn_t (AppTy (AppTy (TyConTy tycon _) arg) res)
266 | isFunTyCon tycon = Just (arg, res)
267 go syn_t (SynTy _ _ t) = go syn_t t
268 go syn_t other = Nothing
270 getFunTyExpandingDicts_maybe :: Bool -- True <=> peek inside newtype applicatons
272 -> Maybe (Type, Type)
274 getFunTyExpandingDicts_maybe peek (FunTy arg result _) = Just (arg,result)
275 getFunTyExpandingDicts_maybe peek
276 (AppTy (AppTy (TyConTy tycon _) arg) res) | isFunTyCon tycon = Just (arg, res)
277 getFunTyExpandingDicts_maybe peek (SynTy _ _ t) = getFunTyExpandingDicts_maybe peek t
278 getFunTyExpandingDicts_maybe peek ty@(DictTy _ _ _) = getFunTyExpandingDicts_maybe peek (expandTy ty)
280 getFunTyExpandingDicts_maybe True (ForAllTy _ ty) = getFunTyExpandingDicts_maybe True ty
281 -- Ignore for-alls when peeking. See note with defn of getFunTyExpandingDictsAndPeeking
284 {- This is a truly disgusting bit of code.
285 It's used by the code generator to look at the rep of a newtype.
286 The code gen will have thrown away coercions involving that newtype, so
287 this is the other side of the coin.
288 Gruesome in the extreme.
291 getFunTyExpandingDicts_maybe peek other
292 | not peek = Nothing -- that was easy
294 = case (maybeAppTyCon other) of
296 | isNewTyCon tc && not (null data_cons)
297 -> getFunTyExpandingDicts_maybe peek inside_ty
299 data_cons = tyConDataCons tc
300 [the_con] = data_cons
301 [inside_ty] = dataConArgTys the_con arg_tys
306 splitFunTy :: GenType t u -> ([GenType t u], GenType t u)
307 splitFunTyExpandingDicts :: Type -> ([Type], Type)
308 splitFunTyExpandingDictsAndPeeking :: Type -> ([Type], Type)
310 splitFunTy t = split_fun_ty getFunTy_maybe t
311 splitFunTyExpandingDicts t = split_fun_ty (getFunTyExpandingDicts_maybe False) t
312 splitFunTyExpandingDictsAndPeeking t = split_fun_ty (getFunTyExpandingDicts_maybe True) t
313 -- This "peeking" stuff is used only by the code generator.
314 -- It's interested in the representation type of things, ignoring:
315 -- newtype Why??? Nuked SLPJ May 97. We may not know the
316 -- rep of an abstractly imported newtype
318 -- expanding dictionary reps
319 -- synonyms, of course
321 split_fun_ty get t = go t []
323 go t ts = case (get t) of
324 Just (arg,res) -> go res (arg:ts)
325 Nothing -> (reverse ts, t)
329 -- NB applyTyCon puts in usageOmega, for now at least
331 = ASSERT(not (isSynTyCon tycon))
332 TyConTy tycon usageOmega
334 applyTyCon :: TyCon -> [GenType t u] -> GenType t u
336 = ASSERT (not (isSynTyCon tycon))
337 --(if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $
338 foldl AppTy (TyConTy tycon usageOmega) tys
340 getTyCon_maybe :: GenType t u -> Maybe TyCon
341 --getTyConExpandingDicts_maybe :: Type -> Maybe TyCon
343 getTyCon_maybe (TyConTy tycon _) = Just tycon
344 getTyCon_maybe (SynTy _ _ t) = getTyCon_maybe t
345 getTyCon_maybe other_ty = Nothing
347 --getTyConExpandingDicts_maybe (TyConTy tycon _) = Just tycon
348 --getTyConExpandingDicts_maybe (SynTy _ _ t) = getTyConExpandingDicts_maybe t
349 --getTyConExpandingDicts_maybe ty@(DictTy _ _ _) = getTyConExpandingDicts_maybe (expandTy ty)
350 --getTyConExpandingDicts_maybe other_ty = Nothing
354 mkSynTy syn_tycon tys
355 = ASSERT(isSynTyCon syn_tycon)
356 SynTy syn_tycon tys (instantiateTauTy (zipEqual "mkSynTy" tyvars tys) body)
358 (tyvars, body) = getSynTyConDefn syn_tycon
364 isTauTy :: GenType t u -> Bool
365 isTauTy (TyVarTy v) = True
366 isTauTy (TyConTy _ _) = True
367 isTauTy (AppTy a b) = isTauTy a && isTauTy b
368 isTauTy (FunTy a b _) = isTauTy a && isTauTy b
369 isTauTy (SynTy _ _ ty) = isTauTy ty
370 isTauTy other = False
375 NB mkRhoTy and mkDictTy put in usageOmega, for now at least
378 mkDictTy :: Class -> GenType t u -> GenType t u
379 mkDictTy clas ty = DictTy clas ty usageOmega
381 mkRhoTy :: [(Class, GenType t u)] -> GenType t u -> GenType t u
383 foldr (\(c,t) r -> FunTy (DictTy c t usageOmega) r usageOmega) ty theta
385 splitRhoTy :: GenType t u -> ([(Class,GenType t u)], GenType t u)
389 -- See notes on type synonyms above
390 go syn_t (FunTy (DictTy c t _) r _) ts = go r r ((c,t):ts)
391 go syn_t (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts
394 go syn_t (SynTy _ _ t) ts = go syn_t t ts
395 go syn_t t ts = (reverse ts, syn_t)
398 mkTheta :: [Type] -> ThetaType
399 -- recover a ThetaType from the types of some dictionaries
403 cvt (DictTy clas ty _) = (clas, ty)
404 cvt other = panic "Type.mkTheta" -- pprPanic "mkTheta:" (pprType PprDebug other)
406 isDictTy (DictTy _ _ _) = True
407 isDictTy (SynTy _ _ t) = isDictTy t
415 mkForAllTy = ForAllTy
417 mkForAllTys :: [t] -> GenType t u -> GenType t u
418 mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
420 getForAllTy_maybe :: GenType t u -> Maybe (t,GenType t u)
421 getForAllTy_maybe (SynTy _ _ t) = getForAllTy_maybe t
422 getForAllTy_maybe (ForAllTy tyvar t) = Just(tyvar,t)
423 getForAllTy_maybe _ = Nothing
425 getForAllTyExpandingDicts_maybe :: Type -> Maybe (TyVar, Type)
426 getForAllTyExpandingDicts_maybe (SynTy _ _ t) = getForAllTyExpandingDicts_maybe t
427 getForAllTyExpandingDicts_maybe (ForAllTy tyvar t) = Just(tyvar,t)
428 getForAllTyExpandingDicts_maybe ty@(DictTy _ _ _) = getForAllTyExpandingDicts_maybe (expandTy ty)
429 getForAllTyExpandingDicts_maybe _ = Nothing
431 splitForAllTy :: GenType t u -> ([t], GenType t u)
432 splitForAllTy t = go t t []
434 -- See notes on type synonyms above
435 go syn_t (ForAllTy tv t) tvs = go t t (tv:tvs)
436 go syn_t (SynTy _ _ t) tvs = go syn_t t tvs
437 go syn_t t tvs = (reverse tvs, syn_t)
439 splitForAllTyExpandingDicts :: Type -> ([TyVar], Type)
440 splitForAllTyExpandingDicts ty
443 go tvs ty = case getForAllTyExpandingDicts_maybe ty of
444 Just (tv, ty') -> go (tv:tvs) ty'
445 Nothing -> (reverse tvs, ty)
449 mkForAllUsageTy :: u -> [u] -> GenType t u -> GenType t u
450 mkForAllUsageTy = ForAllUsageTy
452 getForAllUsageTy :: GenType t u -> Maybe (u,[u],GenType t u)
453 getForAllUsageTy (ForAllUsageTy uvar bounds t) = Just(uvar,bounds,t)
454 getForAllUsageTy (SynTy _ _ t) = getForAllUsageTy t
455 getForAllUsageTy _ = Nothing
458 Applied tycons (includes FunTyCons)
459 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
462 :: GenType tyvar uvar
463 -> Maybe (TyCon, -- the type constructor
464 [GenType tyvar uvar]) -- types to which it is applied
467 = case (getTyCon_maybe app_ty) of
469 Just tycon -> Just (tycon, arg_tys)
471 (app_ty, arg_tys) = splitAppTys ty
475 :: GenType tyvar uvar
476 -> (TyCon, -- the type constructor
477 [GenType tyvar uvar]) -- types to which it is applied
480 = case maybeAppTyCon ty of
483 Nothing -> panic "Type.getAppTyCon" -- (ppr PprShowAll ty)
487 Applied data tycons (give back constrs)
488 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
489 Nota Bene: all these functions suceed for @newtype@ applications too!
493 :: GenType (GenTyVar any) uvar
494 -> Maybe (TyCon, -- the type constructor
495 [GenType (GenTyVar any) uvar], -- types to which it is applied
496 [Id]) -- its family of data-constructors
497 maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts
498 :: Type -> Maybe (TyCon, [Type], [Id])
500 maybeAppDataTyCon ty = maybe_app_data_tycon (\x->x) ty
501 maybeAppDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty
502 maybeAppSpecDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty
505 maybe_app_data_tycon expand ty
507 expanded_ty = expand ty
508 (app_ty, arg_tys) = splitAppTys expanded_ty
510 case (getTyCon_maybe app_ty) of
511 Just tycon | isAlgTyCon tycon && -- NB "Alg"; succeeds for newtype too
512 notArrowKind (typeKind expanded_ty)
513 -- Must be saturated for ty to be a data type
514 -> Just (tycon, arg_tys, tyConDataCons tycon)
518 getAppDataTyCon, getAppSpecDataTyCon
519 :: GenType (GenTyVar any) uvar
520 -> (TyCon, -- the type constructor
521 [GenType (GenTyVar any) uvar], -- types to which it is applied
522 [Id]) -- its family of data-constructors
523 getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts
524 :: Type -> (TyCon, [Type], [Id])
526 getAppDataTyCon ty = get_app_data_tycon maybeAppDataTyCon ty
527 getAppDataTyConExpandingDicts ty = --pprTrace "getAppDataTyConEx...:" (pprType PprDebug ty) $
528 get_app_data_tycon maybeAppDataTyConExpandingDicts ty
530 -- these should work like the UniTyFuns.getUniDataSpecTyCon* things of old (ToDo)
531 getAppSpecDataTyCon = getAppDataTyCon
532 getAppSpecDataTyConExpandingDicts = getAppDataTyConExpandingDicts
534 get_app_data_tycon maybe ty
538 Nothing -> panic "Type.getAppDataTyCon"-- (pprGenType PprShowAll ty)
542 maybeBoxedPrimType :: Type -> Maybe (Id, Type)
544 maybeBoxedPrimType ty
545 = case (maybeAppDataTyCon ty) of -- Data type,
546 Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon -- with exactly one constructor
547 -> case (dataConArgTys data_con tys_applied) of
548 [data_con_arg_ty] -- Applied to exactly one type,
549 | isPrimType data_con_arg_ty -- which is primitive
550 -> Just (data_con, data_con_arg_ty)
551 other_cases -> Nothing
552 other_cases -> Nothing
556 splitSigmaTy :: GenType t u -> ([t], [(Class,GenType t u)], GenType t u)
560 (tyvars,rho) = splitForAllTy ty
561 (theta,tau) = splitRhoTy rho
563 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
567 Finding the kind of a type
568 ~~~~~~~~~~~~~~~~~~~~~~~~~~
570 typeKind :: GenType (GenTyVar any) u -> Kind
572 typeKind (TyVarTy tyvar) = tyVarKind tyvar
573 typeKind (TyConTy tycon usage) = tyConKind tycon
574 typeKind (SynTy _ _ ty) = typeKind ty
575 typeKind (FunTy fun arg _) = mkBoxedTypeKind
576 typeKind (DictTy clas arg _) = mkBoxedTypeKind
577 typeKind (AppTy fun arg) = resultKind (typeKind fun)
578 typeKind (ForAllTy _ _) = mkBoxedTypeKind
579 typeKind (ForAllUsageTy _ _ _) = mkBoxedTypeKind
583 Free variables of a type
584 ~~~~~~~~~~~~~~~~~~~~~~~~
586 tyVarsOfType :: GenType (GenTyVar flexi) uvar -> GenTyVarSet flexi
588 tyVarsOfType (TyVarTy tv) = unitTyVarSet tv
589 tyVarsOfType (TyConTy tycon usage) = emptyTyVarSet
590 tyVarsOfType (SynTy _ tys ty) = tyVarsOfTypes tys
591 tyVarsOfType (FunTy arg res _) = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res
592 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg
593 tyVarsOfType (DictTy clas ty _) = tyVarsOfType ty
594 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar
595 tyVarsOfType (ForAllUsageTy _ _ ty) = tyVarsOfType ty
597 tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi
598 tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
600 -- Find the free names of a type, including the type constructors and classes it mentions
601 namesOfType :: GenType (GenTyVar flexi) uvar -> NameSet
602 namesOfType (TyVarTy tv) = unitNameSet (getName tv)
603 namesOfType (TyConTy tycon usage) = unitNameSet (getName tycon)
604 namesOfType (SynTy tycon tys ty) = unitNameSet (getName tycon) `unionNameSets`
606 namesOfType (FunTy arg res _) = namesOfType arg `unionNameSets` namesOfType res
607 namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
608 namesOfType (DictTy clas ty _) = unitNameSet (getName clas) `unionNameSets`
610 namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
611 namesOfType (ForAllUsageTy _ _ ty) = panic "forall usage"
618 -- applyTy :: GenType (GenTyVar flexi) uvar
619 -- -> GenType (GenTyVar flexi) uvar
620 -- -> GenType (GenTyVar flexi) uvar
622 applyTy :: Type -> Type -> Type
624 applyTy (SynTy _ _ fun) arg = applyTy fun arg
625 applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty
626 applyTy ty@(DictTy _ _ _) arg = applyTy (expandTy ty) arg
627 applyTy other arg = panic "applyTy"
631 instantiateTy :: [(GenTyVar flexi, GenType (GenTyVar flexi) uvar)]
632 -> GenType (GenTyVar flexi) uvar
633 -> GenType (GenTyVar flexi) uvar
635 instantiateTauTy :: Eq tv =>
636 [(tv, GenType tv' u)]
640 applyTypeEnvToTy :: TyVarEnv Type -> SigmaType -> SigmaType
642 -- instantiateTauTy works only (a) on types with no ForAlls,
643 -- and when (b) all the type variables are being instantiated
644 -- In return it is more polymorphic than instantiateTy
646 instant_help ty lookup_tv deflt_tv choose_tycon
647 if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
650 go (TyVarTy tv) = case (lookup_tv tv) of
651 Nothing -> deflt_tv tv
653 go ty@(TyConTy tycon usage) = choose_tycon ty tycon usage
654 go (SynTy tycon tys ty) = SynTy tycon (map go tys) (go ty)
655 go (FunTy arg res usage) = FunTy (go arg) (go res) usage
656 go (AppTy fun arg) = AppTy (go fun) (go arg)
657 go (DictTy clas ty usage) = DictTy clas (go ty) usage
658 go (ForAllUsageTy uvar bds ty) = if_usage $
659 ForAllUsageTy uvar bds (go ty)
660 go (ForAllTy tv ty) = if_forall $
661 (if (bound_forall_tv_BAD && maybeToBool (lookup_tv tv)) then
662 trace "instantiateTy: unexpected forall hit"
664 \x->x) ForAllTy (deflt_forall_tv tv) (go ty)
666 instantiateTy [] ty = ty
668 instantiateTy tenv ty
669 = instant_help ty lookup_tv deflt_tv choose_tycon
670 if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
672 lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of
675 _ -> panic "instantiateTy:lookup_tv"
677 deflt_tv tv = TyVarTy tv
678 choose_tycon ty _ _ = ty
681 bound_forall_tv_BAD = True
682 deflt_forall_tv tv = tv
684 instantiateTauTy tenv ty
685 = instant_help ty lookup_tv deflt_tv choose_tycon
686 if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
688 lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of
691 _ -> panic "instantiateTauTy:lookup_tv"
693 deflt_tv tv = panic "instantiateTauTy"
694 choose_tycon _ tycon usage = TyConTy tycon usage
695 if_usage ty = panic "instantiateTauTy:ForAllUsageTy"
696 if_forall ty = panic "instantiateTauTy:ForAllTy"
697 bound_forall_tv_BAD = panic "instantiateTauTy:bound_forall_tv"
698 deflt_forall_tv tv = panic "instantiateTauTy:deflt_forall_tv"
701 -- applyTypeEnv applies a type environment to a type.
702 -- It can handle shadowing; for example:
703 -- f = /\ t1 t2 -> \ d ->
704 -- letrec f' = /\ t1 -> \x -> ...(f' t1 x')...
706 -- Here, when we clone t1 to t1', say, we'll come across shadowing
707 -- when applying the clone environment to the type of f'.
709 -- As a sanity check, we should also check that name capture
710 -- doesn't occur, but that means keeping track of the free variables of the
711 -- range of the TyVarEnv, which I don't do just yet.
713 -- We don't use instant_help because we need to carry in the environment
715 applyTypeEnvToTy tenv ty
718 go tenv ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of
721 go tenv ty@(TyConTy tycon usage) = ty
722 go tenv (SynTy tycon tys ty) = SynTy tycon (map (go tenv) tys) (go tenv ty)
723 go tenv (FunTy arg res usage) = FunTy (go tenv arg) (go tenv res) usage
724 go tenv (AppTy fun arg) = AppTy (go tenv fun) (go tenv arg)
725 go tenv (DictTy clas ty usage) = DictTy clas (go tenv ty) usage
726 go tenv (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go tenv ty)
727 go tenv (ForAllTy tv ty) = ForAllTy tv (go tenv' ty)
729 tenv' = case lookupTyVarEnv tenv tv of
731 Just _ -> delFromTyVarEnv tenv tv
736 :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u'
738 instantiateUsage = panic "instantiateUsage: not implemented"
742 At present there are no unboxed non-primitive types, so
743 isUnboxedType is the same as isPrimType.
745 We're a bit cavalier about finding out whether something is
746 primitive/unboxed or not. Rather than deal with the type
747 arguemnts we just zoom into the function part of the type.
748 That is, given (T a) we just recurse into the "T" part,
752 isPrimType, isUnboxedType :: Type -> Bool
754 isPrimType (AppTy ty _) = isPrimType ty
755 isPrimType (SynTy _ _ ty) = isPrimType ty
756 isPrimType (TyConTy tycon _) = case maybeNewTyCon tycon of
757 Just (tyvars, ty) -> isPrimType ty
758 Nothing -> isPrimTyCon tycon
762 isUnboxedType = isPrimType
765 This is *not* right: it is a placeholder (ToDo 96/03 WDP):
767 typePrimRep :: Type -> PrimRep
769 typePrimRep (SynTy _ _ ty) = typePrimRep ty
770 typePrimRep (AppTy ty _) = typePrimRep ty
771 typePrimRep (TyConTy tc _)
772 | isPrimTyCon tc = case (assocMaybe tc_primrep_list (uniqueOf tc)) of
774 Nothing -> panic "Type.typePrimRep" -- pprPanic "typePrimRep:" (pprTyCon PprDebug tc)
776 | otherwise = case maybeNewTyCon tc of
777 Just (tyvars, ty) | isPrimType ty -> typePrimRep ty
778 _ -> PtrRep -- Default
780 typePrimRep _ = PtrRep -- the "default"
783 = [(addrPrimTyConKey, AddrRep)
784 ,(arrayPrimTyConKey, ArrayRep)
785 ,(byteArrayPrimTyConKey, ByteArrayRep)
786 ,(charPrimTyConKey, CharRep)
787 ,(doublePrimTyConKey, DoubleRep)
788 ,(floatPrimTyConKey, FloatRep)
789 ,(foreignObjPrimTyConKey, ForeignObjRep)
790 ,(intPrimTyConKey, IntRep)
791 ,(mutableArrayPrimTyConKey, ArrayRep)
792 ,(mutableByteArrayPrimTyConKey, ByteArrayRep)
793 ,(stablePtrPrimTyConKey, StablePtrRep)
794 ,(statePrimTyConKey, VoidRep)
795 ,(synchVarPrimTyConKey, PtrRep)
796 ,(voidTyConKey, PtrRep) -- Not VoidRep! That's just for Void#
797 -- The type Void is represented by a pointer to
799 ,(wordPrimTyConKey, WordRep)
803 %************************************************************************
805 \subsection{Matching on types}
807 %************************************************************************
809 Matching is a {\em unidirectional} process, matching a type against a
810 template (which is just a type with type variables in it). The
811 matcher assumes that there are no repeated type variables in the
812 template, so that it simply returns a mapping of type variables to
813 types. It also fails on nested foralls.
815 @matchTys@ matches corresponding elements of a list of templates and
819 matchTy :: GenType t1 u1 -- Template
820 -> GenType t2 u2 -- Proposed instance of template
821 -> Maybe [(t1,GenType t2 u2)] -- Matching substitution
824 matchTys :: [GenType t1 u1] -- Templates
825 -> [GenType t2 u2] -- Proposed instance of template
826 -> Maybe ([(t1,GenType t2 u2)],-- Matching substitution
827 [GenType t2 u2]) -- Left over instance types
829 matchTy ty1 ty2 = match ty1 ty2 (\s -> Just s) []
830 matchTys tys1 tys2 = go [] tys1 tys2
832 go s [] tys2 = Just (s,tys2)
833 go s (ty1:tys1) [] = trace "matchTys" Nothing
834 go s (ty1:tys1) (ty2:tys2) = match ty1 ty2 (\s' -> go s' tys1 tys2) s
837 @match@ is the main function.
840 match :: GenType t1 u1 -> GenType t2 u2 -- Current match pair
841 -> ([(t1, GenType t2 u2)] -> Maybe result) -- Continuation
842 -> [(t1, GenType t2 u2)] -- Current substitution
845 match (TyVarTy v) ty k = \s -> k ((v,ty) : s)
846 match (FunTy fun1 arg1 _) (FunTy fun2 arg2 _) k = match fun1 fun2 (match arg1 arg2 k)
847 match (AppTy fun1 arg1) (AppTy fun2 arg2) k = match fun1 fun2 (match arg1 arg2 k)
848 match (TyConTy con1 _) (TyConTy con2 _) k | con1 == con2 = k
849 match (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) k | clas1 == clas2 = match ty1 ty2 k
850 match (SynTy _ _ ty1) ty2 k = match ty1 ty2 k
851 match ty1 (SynTy _ _ ty2) k = match ty1 ty2 k
853 -- With type synonyms, we have to be careful for the exact
854 -- same reasons as in the unifier. Please see the
855 -- considerable commentary there before changing anything
859 match _ _ _ = \s -> Nothing
862 %************************************************************************
864 \subsection{Equality on types}
866 %************************************************************************
868 The functions eqSimpleTy and eqSimpleTheta are polymorphic in the types t
869 and u, but ONLY WORK FOR SIMPLE TYPES (ie. they panic if they see
870 dictionaries or polymorphic types). The function eqTy has a more
871 specific type, but does the `right thing' for all types.
874 eqSimpleTheta :: (Eq t,Eq u) =>
875 [(Class,GenType t u)] -> [(Class,GenType t u)] -> Bool
877 eqSimpleTheta [] [] = True
878 eqSimpleTheta ((c1,t1):th1) ((c2,t2):th2) =
879 c1==c2 && t1 `eqSimpleTy` t2 && th1 `eqSimpleTheta` th2
880 eqSimpleTheta other1 other2 = False
884 eqSimpleTy :: (Eq t,Eq u) => GenType t u -> GenType t u -> Bool
886 (TyVarTy tv1) `eqSimpleTy` (TyVarTy tv2) =
888 (AppTy f1 a1) `eqSimpleTy` (AppTy f2 a2) =
889 f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2
890 (TyConTy tc1 u1) `eqSimpleTy` (TyConTy tc2 u2) =
891 tc1 == tc2 --ToDo: later: && u1 == u2
893 (FunTy f1 a1 u1) `eqSimpleTy` (FunTy f2 a2 u2) =
894 f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 && u1 == u2
895 (FunTy f1 a1 u1) `eqSimpleTy` t2 =
896 -- Expand t1 just in case t2 matches that version
897 (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) `eqSimpleTy` t2
898 t1 `eqSimpleTy` (FunTy f2 a2 u2) =
899 -- Expand t2 just in case t1 matches that version
900 t1 `eqSimpleTy` (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
902 (SynTy tc1 ts1 t1) `eqSimpleTy` (SynTy tc2 ts2 t2) =
903 (tc1 == tc2 && and (zipWith eqSimpleTy ts1 ts2) && length ts1 == length ts2)
904 || t1 `eqSimpleTy` t2
905 (SynTy _ _ t1) `eqSimpleTy` t2 =
906 t1 `eqSimpleTy` t2 -- Expand the abbrevation and try again
907 t1 `eqSimpleTy` (SynTy _ _ t2) =
908 t1 `eqSimpleTy` t2 -- Expand the abbrevation and try again
910 (DictTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got DictTy"
911 _ `eqSimpleTy` (DictTy _ _ _) = panic "eqSimpleTy: got DictTy"
913 (ForAllTy _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllTy"
914 _ `eqSimpleTy` (ForAllTy _ _) = panic "eqSimpleTy: got ForAllTy"
916 (ForAllUsageTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllUsageTy"
917 _ `eqSimpleTy` (ForAllUsageTy _ _ _) = panic "eqSimpleTy: got ForAllUsageTy"
919 _ `eqSimpleTy` _ = False
922 Types are ordered so we can sort on types in the renamer etc. DNT: Since
923 this class is also used in CoreLint and other such places, we DO expand out
924 Fun/Syn/Dict types (if necessary).
927 eqTy :: Type -> Type -> Bool
930 eq nullTyVarEnv nullUVarEnv t1 t2
932 eq tve uve (TyVarTy tv1) (TyVarTy tv2) =
934 case (lookupTyVarEnv tve tv1) of
937 eq tve uve (AppTy f1 a1) (AppTy f2 a2) =
938 eq tve uve f1 f2 && eq tve uve a1 a2
939 eq tve uve (TyConTy tc1 u1) (TyConTy tc2 u2) =
940 tc1 == tc2 -- ToDo: LATER: && eqUsage uve u1 u2
942 eq tve uve (FunTy f1 a1 u1) (FunTy f2 a2 u2) =
943 eq tve uve f1 f2 && eq tve uve a1 a2 && eqUsage uve u1 u2
944 eq tve uve (FunTy f1 a1 u1) t2 =
945 -- Expand t1 just in case t2 matches that version
946 eq tve uve (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) t2
947 eq tve uve t1 (FunTy f2 a2 u2) =
948 -- Expand t2 just in case t1 matches that version
949 eq tve uve t1 (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
951 eq tve uve (DictTy c1 t1 u1) (DictTy c2 t2 u2)
953 = eq tve uve t1 t2 && eqUsage uve u1 u2
954 -- NB we use a guard for c1==c2 so that if they aren't equal we
955 -- fall through into expanding the type. Why? Because brain-dead
956 -- people might write
957 -- class Foo a => Baz a where {}
958 -- and that means that a Foo dictionary and a Baz dictionary are identical
959 -- Sigh. Let's hope we don't spend too much time in here!
961 eq tve uve t1@(DictTy _ _ _) t2 =
962 eq tve uve (expandTy t1) t2 -- Expand the dictionary and try again
963 eq tve uve t1 t2@(DictTy _ _ _) =
964 eq tve uve t1 (expandTy t2) -- Expand the dictionary and try again
966 eq tve uve (SynTy tc1 ts1 t1) (SynTy tc2 ts2 t2) =
967 (tc1 == tc2 && and (zipWith (eq tve uve) ts1 ts2) && length ts1 == length ts2)
969 eq tve uve (SynTy _ _ t1) t2 =
970 eq tve uve t1 t2 -- Expand the abbrevation and try again
971 eq tve uve t1 (SynTy _ _ t2) =
972 eq tve uve t1 t2 -- Expand the abbrevation and try again
974 eq tve uve (ForAllTy tv1 t1) (ForAllTy tv2 t2) =
975 eq (addOneToTyVarEnv tve tv1 tv2) uve t1 t2
976 eq tve uve (ForAllUsageTy u1 b1 t1) (ForAllUsageTy u2 b2 t2) =
977 eqBounds uve b1 b2 && eq tve (addOneToUVarEnv uve u1 u2) t1 t2
981 eqBounds uve [] [] = True
982 eqBounds uve (u1:b1) (u2:b2) = eqUVar uve u1 u2 && eqBounds uve b1 b2
983 eqBounds uve _ _ = False
987 showTypeCategory :: Type -> Char
989 {C,I,F,D} char, int, float, double
991 S other single-constructor type
992 {c,i,f,d} unboxed ditto
994 s *unpacked" single-cons...
1000 + dictionary, unless it's a ...
1003 M other (multi-constructor) data-con type
1005 - reserved for others to mark as "uninteresting"
1011 case getTyCon_maybe ty of
1012 Nothing -> if maybeToBool (getFunTy_maybe ty)
1017 let utc = uniqueOf tycon in
1018 if utc == charDataConKey then 'C'
1019 else if utc == intDataConKey then 'I'
1020 else if utc == floatDataConKey then 'F'
1021 else if utc == doubleDataConKey then 'D'
1022 else if utc == integerDataConKey then 'J'
1023 else if utc == charPrimTyConKey then 'c'
1024 else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
1025 || utc == addrPrimTyConKey) then 'i'
1026 else if utc == floatPrimTyConKey then 'f'
1027 else if utc == doublePrimTyConKey then 'd'
1028 else if isPrimTyCon tycon {- array, we hope -} then 'A'
1029 else if isEnumerationTyCon tycon then 'E'
1030 else if isTupleTyCon tycon then 'T'
1031 else if maybeToBool (maybeTyConSingleCon tycon) then 'S'
1032 else if utc == listTyConKey then 'L'
1033 else 'M' -- oh, well...