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,
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 --IMPORT_DELOOPER(IdLoop) -- for paranoia checking
46 IMPORT_DELOOPER(TyLoop)
47 --IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
50 import Class ( classSig, classOpLocalType, GenClass{-instances-} )
51 import Kind ( mkBoxedTypeKind, resultKind, notArrowKind, Kind )
52 import TyCon ( mkFunTyCon, isFunTyCon, isEnumerationTyCon, isTupleTyCon, maybeTyConSingleCon,
53 isPrimTyCon, isDataTyCon, isSynTyCon, maybeNewTyCon, isNewTyCon,
54 tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
55 import TyVar ( tyVarKind, GenTyVar{-instances-}, SYN_IE(GenTyVarSet),
56 emptyTyVarSet, unionTyVarSets, minusTyVarSet,
57 unitTyVarSet, nullTyVarEnv, lookupTyVarEnv, delFromTyVarEnv,
58 addOneToTyVarEnv, SYN_IE(TyVarEnv), SYN_IE(TyVar) )
59 import Usage ( usageOmega, GenUsage, SYN_IE(Usage), SYN_IE(UVar), SYN_IE(UVarEnv),
60 nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar,
63 import Name ( NamedThing(..),
64 NameSet(..), unionNameSets, emptyNameSet, unitNameSet, minusNameSet
68 import Maybes ( maybeToBool, assocMaybe )
69 import PrimRep ( PrimRep(..) )
70 import Unique -- quite a few *Keys
71 import Util ( thenCmp, zipEqual, assoc,
72 panic, panic#, assertPanic, pprPanic,
81 -- PprType --(pprType )
83 -- UniqFM (ufmToList )
93 type Type = GenType TyVar UVar -- Used after typechecker
95 data GenType tyvar uvar -- Parameterised over type and usage variables
102 | TyConTy -- Constants of a specified kind
103 TyCon -- Must *not* be a SynTyCon
104 (GenUsage uvar) -- Usage gives uvar of the full application,
105 -- iff the full application is of kind Type
106 -- c.f. the Usage field in TyVars
108 | SynTy -- Synonyms must be saturated, and contain their expansion
109 TyCon -- Must be a SynTyCon
111 (GenType tyvar uvar) -- Expansion!
115 (GenType tyvar uvar) -- TypeKind
118 uvar -- Quantify over this
119 [uvar] -- Bounds; the quantified var must be
120 -- less than or equal to all these
123 -- Two special cases that save a *lot* of administrative
126 | FunTy -- BoxedTypeKind
127 (GenType tyvar uvar) -- Both args are of TypeKind
133 (GenType tyvar uvar) -- Arg has kind TypeKind
140 type ThetaType = [(Class, Type)]
141 type SigmaType = Type
147 Removes just the top level of any abbreviations.
150 expandTy :: Type -> Type -- Restricted to Type due to Dict expansion
152 expandTy (FunTy t1 t2 u) = AppTy (AppTy (TyConTy mkFunTyCon u) t1) t2
153 expandTy (SynTy _ _ t) = expandTy t
154 expandTy (DictTy clas ty u)
155 = case all_arg_tys of
157 [] -> voidTy -- Empty dictionary represented by Void
159 [arg_ty] -> expandTy arg_ty -- just the <whatever> itself
161 -- The extra expandTy is to make sure that
162 -- the result isn't still a dict, which it might be
163 -- if the original guy was a dict with one superdict and
166 other -> ASSERT(not (null all_arg_tys))
167 foldl AppTy (TyConTy (tupleTyCon (length all_arg_tys)) u) all_arg_tys
170 -- Note: length of all_arg_tys can be 0 if the class is
171 -- CCallable, CReturnable (and anything else
172 -- *really weird* that the user writes).
174 (tyvar, super_classes, ops) = classSig clas
175 super_dict_tys = map mk_super_ty super_classes
176 class_op_tys = map mk_op_ty ops
177 all_arg_tys = super_dict_tys ++ class_op_tys
178 mk_super_ty sc = DictTy sc ty usageOmega
179 mk_op_ty op = instantiateTy [(tyvar,ty)] (classOpLocalType op)
184 Simple construction and analysis functions
185 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
187 mkTyVarTy :: t -> GenType t u
188 mkTyVarTys :: [t] -> [GenType t y]
190 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
192 getTyVar :: String -> GenType t u -> t
193 getTyVar msg (TyVarTy tv) = tv
194 getTyVar msg (SynTy _ _ t) = getTyVar msg t
195 getTyVar msg other = panic ("getTyVar: " ++ msg)
197 getTyVar_maybe :: GenType t u -> Maybe t
198 getTyVar_maybe (TyVarTy tv) = Just tv
199 getTyVar_maybe (SynTy _ _ t) = getTyVar_maybe t
200 getTyVar_maybe other = Nothing
202 isTyVarTy :: GenType t u -> Bool
203 isTyVarTy (TyVarTy tv) = True
204 isTyVarTy (SynTy _ _ t) = isTyVarTy t
205 isTyVarTy other = False
211 mkAppTys :: GenType t u -> [GenType t u] -> GenType t u
212 mkAppTys t ts = foldl AppTy t ts
214 splitAppTy :: GenType t u -> (GenType t u, GenType t u)
215 splitAppTy (AppTy t arg) = (t,arg)
216 splitAppTy (SynTy _ _ t) = splitAppTy t
217 splitAppTy other = panic "splitAppTy"
219 splitAppTys :: GenType t u -> (GenType t u, [GenType t u])
220 splitAppTys t = go t []
222 go (AppTy t arg) ts = go t (arg:ts)
223 go (FunTy fun arg u) ts = (TyConTy mkFunTyCon u, fun:arg:ts)
224 go (SynTy _ _ t) ts = go t ts
229 -- NB mkFunTy, mkFunTys puts in Omega usages, for now at least
230 mkFunTy arg res = FunTy arg res usageOmega
232 mkFunTys :: [GenType t u] -> GenType t u -> GenType t u
233 mkFunTys ts t = foldr (\ f a -> FunTy f a usageOmega) t ts
235 -- getFunTy_maybe and splitFunTy *must* have the general type given, which
236 -- means they *can't* do the DictTy jiggery-pokery that
237 -- *is* sometimes required. Hence we also have the ExpandingDicts variants
238 -- The relationship between these
239 -- two functions is like that between eqTy and eqSimpleTy.
240 -- ToDo: NUKE when we do dicts via newtype
242 getFunTy_maybe :: GenType t u -> Maybe (GenType t u, GenType t u)
243 getFunTy_maybe (FunTy arg result _) = Just (arg,result)
244 getFunTy_maybe (AppTy (AppTy (TyConTy tycon _) arg) res)
245 | isFunTyCon tycon = Just (arg, res)
246 getFunTy_maybe (SynTy _ _ t) = getFunTy_maybe t
247 getFunTy_maybe other = Nothing
249 getFunTyExpandingDicts_maybe :: Bool -- True <=> peek inside newtype applicatons
251 -> Maybe (Type, Type)
253 getFunTyExpandingDicts_maybe peek (FunTy arg result _) = Just (arg,result)
254 getFunTyExpandingDicts_maybe peek
255 (AppTy (AppTy (TyConTy tycon _) arg) res) | isFunTyCon tycon = Just (arg, res)
256 getFunTyExpandingDicts_maybe peek (SynTy _ _ t) = getFunTyExpandingDicts_maybe peek t
257 getFunTyExpandingDicts_maybe peek ty@(DictTy _ _ _) = getFunTyExpandingDicts_maybe peek (expandTy ty)
259 getFunTyExpandingDicts_maybe True (ForAllTy _ ty) = getFunTyExpandingDicts_maybe True ty
260 -- Ignore for-alls when peeking. See note with defn of getFunTyExpandingDictsAndPeeking
262 getFunTyExpandingDicts_maybe peek other
263 | not peek = Nothing -- that was easy
265 = case (maybeAppTyCon other) of
268 | not (isNewTyCon tc) -> Nothing
271 [newtype_con] = tyConDataCons tc -- there must be exactly one...
272 [inside_ty] = dataConArgTys newtype_con arg_tys
274 getFunTyExpandingDicts_maybe peek inside_ty
276 splitFunTy :: GenType t u -> ([GenType t u], GenType t u)
277 splitFunTyExpandingDicts :: Type -> ([Type], Type)
278 splitFunTyExpandingDictsAndPeeking :: Type -> ([Type], Type)
280 splitFunTy t = split_fun_ty getFunTy_maybe t
281 splitFunTyExpandingDicts t = split_fun_ty (getFunTyExpandingDicts_maybe False) t
282 splitFunTyExpandingDictsAndPeeking t = split_fun_ty (getFunTyExpandingDicts_maybe True) t
283 -- This "peeking" stuff is used only by the code generator.
284 -- It's interested in the representation type of things, ignoring:
287 -- expanding dictionary reps
288 -- synonyms, of course
290 split_fun_ty get t = go t []
292 go t ts = case (get t) of
293 Just (arg,res) -> go res (arg:ts)
294 Nothing -> (reverse ts, t)
298 -- NB applyTyCon puts in usageOmega, for now at least
300 = ASSERT(not (isSynTyCon tycon))
301 TyConTy tycon usageOmega
303 applyTyCon :: TyCon -> [GenType t u] -> GenType t u
305 = ASSERT (not (isSynTyCon tycon))
306 --(if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $
307 foldl AppTy (TyConTy tycon usageOmega) tys
309 getTyCon_maybe :: GenType t u -> Maybe TyCon
310 --getTyConExpandingDicts_maybe :: Type -> Maybe TyCon
312 getTyCon_maybe (TyConTy tycon _) = Just tycon
313 getTyCon_maybe (SynTy _ _ t) = getTyCon_maybe t
314 getTyCon_maybe other_ty = Nothing
316 --getTyConExpandingDicts_maybe (TyConTy tycon _) = Just tycon
317 --getTyConExpandingDicts_maybe (SynTy _ _ t) = getTyConExpandingDicts_maybe t
318 --getTyConExpandingDicts_maybe ty@(DictTy _ _ _) = getTyConExpandingDicts_maybe (expandTy ty)
319 --getTyConExpandingDicts_maybe other_ty = Nothing
323 mkSynTy syn_tycon tys
324 = ASSERT(isSynTyCon syn_tycon)
325 SynTy syn_tycon tys (instantiateTauTy (zipEqual "mkSynTy" tyvars tys) body)
327 (tyvars, body) = getSynTyConDefn syn_tycon
333 isTauTy :: GenType t u -> Bool
334 isTauTy (TyVarTy v) = True
335 isTauTy (TyConTy _ _) = True
336 isTauTy (AppTy a b) = isTauTy a && isTauTy b
337 isTauTy (FunTy a b _) = isTauTy a && isTauTy b
338 isTauTy (SynTy _ _ ty) = isTauTy ty
339 isTauTy other = False
344 NB mkRhoTy and mkDictTy put in usageOmega, for now at least
347 mkDictTy :: Class -> GenType t u -> GenType t u
348 mkDictTy clas ty = DictTy clas ty usageOmega
350 mkRhoTy :: [(Class, GenType t u)] -> GenType t u -> GenType t u
352 foldr (\(c,t) r -> FunTy (DictTy c t usageOmega) r usageOmega) ty theta
354 splitRhoTy :: GenType t u -> ([(Class,GenType t u)], GenType t u)
358 go (FunTy (DictTy c t _) r _) ts = go r ((c,t):ts)
359 go (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts
362 go (SynTy _ _ t) ts = go t ts
363 go t ts = (reverse ts, t)
366 mkTheta :: [Type] -> ThetaType
367 -- recover a ThetaType from the types of some dictionaries
371 cvt (DictTy clas ty _) = (clas, ty)
372 cvt other = panic "Type.mkTheta" -- pprPanic "mkTheta:" (pprType PprDebug other)
374 isDictTy (DictTy _ _ _) = True
375 isDictTy (SynTy _ _ t) = isDictTy t
383 mkForAllTy = ForAllTy
385 mkForAllTys :: [t] -> GenType t u -> GenType t u
386 mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
388 getForAllTy_maybe :: GenType t u -> Maybe (t,GenType t u)
389 getForAllTy_maybe (SynTy _ _ t) = getForAllTy_maybe t
390 getForAllTy_maybe (ForAllTy tyvar t) = Just(tyvar,t)
391 getForAllTy_maybe _ = Nothing
393 getForAllTyExpandingDicts_maybe :: Type -> Maybe (TyVar, Type)
394 getForAllTyExpandingDicts_maybe (SynTy _ _ t) = getForAllTyExpandingDicts_maybe t
395 getForAllTyExpandingDicts_maybe (ForAllTy tyvar t) = Just(tyvar,t)
396 getForAllTyExpandingDicts_maybe ty@(DictTy _ _ _) = getForAllTyExpandingDicts_maybe (expandTy ty)
397 getForAllTyExpandingDicts_maybe _ = Nothing
399 splitForAllTy :: GenType t u-> ([t], GenType t u)
400 splitForAllTy t = go t []
402 go (ForAllTy tv t) tvs = go t (tv:tvs)
403 go (SynTy _ _ t) tvs = go t tvs
404 go t tvs = (reverse tvs, t)
408 mkForAllUsageTy :: u -> [u] -> GenType t u -> GenType t u
409 mkForAllUsageTy = ForAllUsageTy
411 getForAllUsageTy :: GenType t u -> Maybe (u,[u],GenType t u)
412 getForAllUsageTy (ForAllUsageTy uvar bounds t) = Just(uvar,bounds,t)
413 getForAllUsageTy (SynTy _ _ t) = getForAllUsageTy t
414 getForAllUsageTy _ = Nothing
417 Applied tycons (includes FunTyCons)
418 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
421 :: GenType tyvar uvar
422 -> Maybe (TyCon, -- the type constructor
423 [GenType tyvar uvar]) -- types to which it is applied
426 = case (getTyCon_maybe app_ty) of
428 Just tycon -> Just (tycon, arg_tys)
430 (app_ty, arg_tys) = splitAppTys ty
434 :: GenType tyvar uvar
435 -> (TyCon, -- the type constructor
436 [GenType tyvar uvar]) -- types to which it is applied
439 = case maybeAppTyCon ty of
442 Nothing -> panic "Type.getAppTyCon" -- (ppr PprShowAll ty)
446 Applied data tycons (give back constrs)
447 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
450 :: GenType (GenTyVar any) uvar
451 -> Maybe (TyCon, -- the type constructor
452 [GenType (GenTyVar any) uvar], -- types to which it is applied
453 [Id]) -- its family of data-constructors
454 maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts
455 :: Type -> Maybe (TyCon, [Type], [Id])
457 maybeAppDataTyCon ty = maybe_app_data_tycon (\x->x) ty
458 maybeAppDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty
459 maybeAppSpecDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty
462 maybe_app_data_tycon expand ty
464 expanded_ty = expand ty
465 (app_ty, arg_tys) = splitAppTys expanded_ty
467 case (getTyCon_maybe app_ty) of
468 Just tycon | --pprTrace "maybe_app:" (ppCat [ppr PprDebug (isDataTyCon tycon), ppr PprDebug (notArrowKind (typeKind expanded_ty))]) $
470 notArrowKind (typeKind expanded_ty)
471 -- Must be saturated for ty to be a data type
472 -> Just (tycon, arg_tys, tyConDataCons tycon)
476 getAppDataTyCon, getAppSpecDataTyCon
477 :: GenType (GenTyVar any) uvar
478 -> (TyCon, -- the type constructor
479 [GenType (GenTyVar any) uvar], -- types to which it is applied
480 [Id]) -- its family of data-constructors
481 getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts
482 :: Type -> (TyCon, [Type], [Id])
484 getAppDataTyCon ty = get_app_data_tycon maybeAppDataTyCon ty
485 getAppDataTyConExpandingDicts ty = --pprTrace "getAppDataTyConEx...:" (pprType PprDebug ty) $
486 get_app_data_tycon maybeAppDataTyConExpandingDicts ty
488 -- these should work like the UniTyFuns.getUniDataSpecTyCon* things of old (ToDo)
489 getAppSpecDataTyCon = getAppDataTyCon
490 getAppSpecDataTyConExpandingDicts = getAppDataTyConExpandingDicts
492 get_app_data_tycon maybe ty
496 Nothing -> panic "Type.getAppDataTyCon"-- (pprGenType PprShowAll ty)
500 maybeBoxedPrimType :: Type -> Maybe (Id, Type)
502 maybeBoxedPrimType ty
503 = case (maybeAppDataTyCon ty) of -- Data type,
504 Just (tycon, tys_applied, [data_con]) -- with exactly one constructor
505 -> case (dataConArgTys data_con tys_applied) of
506 [data_con_arg_ty] -- Applied to exactly one type,
507 | isPrimType data_con_arg_ty -- which is primitive
508 -> Just (data_con, data_con_arg_ty)
509 other_cases -> Nothing
510 other_cases -> Nothing
514 splitSigmaTy :: GenType t u -> ([t], [(Class,GenType t u)], GenType t u)
518 (tyvars,rho) = splitForAllTy ty
519 (theta,tau) = splitRhoTy rho
521 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
525 Finding the kind of a type
526 ~~~~~~~~~~~~~~~~~~~~~~~~~~
528 typeKind :: GenType (GenTyVar any) u -> Kind
530 typeKind (TyVarTy tyvar) = tyVarKind tyvar
531 typeKind (TyConTy tycon usage) = tyConKind tycon
532 typeKind (SynTy _ _ ty) = typeKind ty
533 typeKind (FunTy fun arg _) = mkBoxedTypeKind
534 typeKind (DictTy clas arg _) = mkBoxedTypeKind
535 typeKind (AppTy fun arg) = resultKind (typeKind fun)
536 typeKind (ForAllTy _ _) = mkBoxedTypeKind
537 typeKind (ForAllUsageTy _ _ _) = mkBoxedTypeKind
541 Free variables of a type
542 ~~~~~~~~~~~~~~~~~~~~~~~~
544 tyVarsOfType :: GenType (GenTyVar flexi) uvar -> GenTyVarSet flexi
546 tyVarsOfType (TyVarTy tv) = unitTyVarSet tv
547 tyVarsOfType (TyConTy tycon usage) = emptyTyVarSet
548 tyVarsOfType (SynTy _ tys ty) = tyVarsOfTypes tys
549 tyVarsOfType (FunTy arg res _) = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res
550 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg
551 tyVarsOfType (DictTy clas ty _) = tyVarsOfType ty
552 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar
553 tyVarsOfType (ForAllUsageTy _ _ ty) = tyVarsOfType ty
555 tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi
556 tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
558 -- Find the free names of a type, including the type constructors and classes it mentions
559 namesOfType :: GenType (GenTyVar flexi) uvar -> NameSet
560 namesOfType (TyVarTy tv) = unitNameSet (getName tv)
561 namesOfType (TyConTy tycon usage) = unitNameSet (getName tycon)
562 namesOfType (SynTy tycon tys ty) = unitNameSet (getName tycon) `unionNameSets`
564 namesOfType (FunTy arg res _) = namesOfType arg `unionNameSets` namesOfType res
565 namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
566 namesOfType (DictTy clas ty _) = unitNameSet (getName clas) `unionNameSets`
568 namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
569 namesOfType (ForAllUsageTy _ _ ty) = panic "forall usage"
576 -- applyTy :: GenType (GenTyVar flexi) uvar
577 -- -> GenType (GenTyVar flexi) uvar
578 -- -> GenType (GenTyVar flexi) uvar
580 applyTy :: Type -> Type -> Type
582 applyTy (SynTy _ _ fun) arg = applyTy fun arg
583 applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty
584 applyTy ty@(DictTy _ _ _) arg = applyTy (expandTy ty) arg
585 applyTy other arg = panic "applyTy"
589 instantiateTy :: [(GenTyVar flexi, GenType (GenTyVar flexi) uvar)]
590 -> GenType (GenTyVar flexi) uvar
591 -> GenType (GenTyVar flexi) uvar
593 instantiateTauTy :: Eq tv =>
594 [(tv, GenType tv' u)]
598 applyTypeEnvToTy :: TyVarEnv Type -> SigmaType -> SigmaType
600 -- instantiateTauTy works only (a) on types with no ForAlls,
601 -- and when (b) all the type variables are being instantiated
602 -- In return it is more polymorphic than instantiateTy
604 instant_help ty lookup_tv deflt_tv choose_tycon
605 if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
608 go (TyVarTy tv) = case (lookup_tv tv) of
609 Nothing -> deflt_tv tv
611 go ty@(TyConTy tycon usage) = choose_tycon ty tycon usage
612 go (SynTy tycon tys ty) = SynTy tycon (map go tys) (go ty)
613 go (FunTy arg res usage) = FunTy (go arg) (go res) usage
614 go (AppTy fun arg) = AppTy (go fun) (go arg)
615 go (DictTy clas ty usage) = DictTy clas (go ty) usage
616 go (ForAllUsageTy uvar bds ty) = if_usage $
617 ForAllUsageTy uvar bds (go ty)
618 go (ForAllTy tv ty) = if_forall $
619 (if (bound_forall_tv_BAD && maybeToBool (lookup_tv tv)) then
620 trace "instantiateTy: unexpected forall hit"
622 \x->x) ForAllTy (deflt_forall_tv tv) (go ty)
624 instantiateTy tenv ty
625 = instant_help ty lookup_tv deflt_tv choose_tycon
626 if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
628 lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of
631 _ -> panic "instantiateTy:lookup_tv"
633 deflt_tv tv = TyVarTy tv
634 choose_tycon ty _ _ = ty
637 bound_forall_tv_BAD = True
638 deflt_forall_tv tv = tv
640 instantiateTauTy tenv ty
641 = instant_help ty lookup_tv deflt_tv choose_tycon
642 if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
644 lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of
647 _ -> panic "instantiateTauTy:lookup_tv"
649 deflt_tv tv = panic "instantiateTauTy"
650 choose_tycon _ tycon usage = TyConTy tycon usage
651 if_usage ty = panic "instantiateTauTy:ForAllUsageTy"
652 if_forall ty = panic "instantiateTauTy:ForAllTy"
653 bound_forall_tv_BAD = panic "instantiateTauTy:bound_forall_tv"
654 deflt_forall_tv tv = panic "instantiateTauTy:deflt_forall_tv"
657 -- applyTypeEnv applies a type environment to a type.
658 -- It can handle shadowing; for example:
659 -- f = /\ t1 t2 -> \ d ->
660 -- letrec f' = /\ t1 -> \x -> ...(f' t1 x')...
662 -- Here, when we clone t1 to t1', say, we'll come across shadowing
663 -- when applying the clone environment to the type of f'.
665 -- As a sanity check, we should also check that name capture
666 -- doesn't occur, but that means keeping track of the free variables of the
667 -- range of the TyVarEnv, which I don't do just yet.
669 -- We don't use instant_help because we need to carry in the environment
671 applyTypeEnvToTy tenv ty
674 go tenv ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of
677 go tenv ty@(TyConTy tycon usage) = ty
678 go tenv (SynTy tycon tys ty) = SynTy tycon (map (go tenv) tys) (go tenv ty)
679 go tenv (FunTy arg res usage) = FunTy (go tenv arg) (go tenv res) usage
680 go tenv (AppTy fun arg) = AppTy (go tenv fun) (go tenv arg)
681 go tenv (DictTy clas ty usage) = DictTy clas (go tenv ty) usage
682 go tenv (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go tenv ty)
683 go tenv (ForAllTy tv ty) = ForAllTy tv (go tenv' ty)
685 tenv' = case lookupTyVarEnv tenv tv of
687 Just _ -> delFromTyVarEnv tenv tv
692 :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u'
694 instantiateUsage = panic "instantiateUsage: not implemented"
698 At present there are no unboxed non-primitive types, so
699 isUnboxedType is the same as isPrimType.
701 We're a bit cavalier about finding out whether something is
702 primitive/unboxed or not. Rather than deal with the type
703 arguemnts we just zoom into the function part of the type.
704 That is, given (T a) we just recurse into the "T" part,
708 isPrimType, isUnboxedType :: Type -> Bool
710 isPrimType (AppTy ty _) = isPrimType ty
711 isPrimType (SynTy _ _ ty) = isPrimType ty
712 isPrimType (TyConTy tycon _) = case maybeNewTyCon tycon of
713 Just (tyvars, ty) -> isPrimType ty
714 Nothing -> isPrimTyCon tycon
718 isUnboxedType = isPrimType
721 This is *not* right: it is a placeholder (ToDo 96/03 WDP):
723 typePrimRep :: Type -> PrimRep
725 typePrimRep (SynTy _ _ ty) = typePrimRep ty
726 typePrimRep (AppTy ty _) = typePrimRep ty
727 typePrimRep (TyConTy tc _)
728 | isPrimTyCon tc = case (assocMaybe tc_primrep_list (uniqueOf tc)) of
730 Nothing -> panic "Type.typePrimRep" -- pprPanic "typePrimRep:" (pprTyCon PprDebug tc)
732 | otherwise = case maybeNewTyCon tc of
733 Just (tyvars, ty) | isPrimType ty -> typePrimRep ty
734 _ -> PtrRep -- Default
736 typePrimRep _ = PtrRep -- the "default"
739 = [(addrPrimTyConKey, AddrRep)
740 ,(arrayPrimTyConKey, ArrayRep)
741 ,(byteArrayPrimTyConKey, ByteArrayRep)
742 ,(charPrimTyConKey, CharRep)
743 ,(doublePrimTyConKey, DoubleRep)
744 ,(floatPrimTyConKey, FloatRep)
745 ,(foreignObjPrimTyConKey, ForeignObjRep)
746 ,(intPrimTyConKey, IntRep)
747 ,(mutableArrayPrimTyConKey, ArrayRep)
748 ,(mutableByteArrayPrimTyConKey, ByteArrayRep)
749 ,(stablePtrPrimTyConKey, StablePtrRep)
750 ,(statePrimTyConKey, VoidRep)
751 ,(synchVarPrimTyConKey, PtrRep)
752 ,(voidTyConKey, PtrRep) -- Not VoidRep! That's just for Void#
753 -- The type Void is represented by a pointer to
755 ,(wordPrimTyConKey, WordRep)
759 %************************************************************************
761 \subsection{Matching on types}
763 %************************************************************************
765 Matching is a {\em unidirectional} process, matching a type against a
766 template (which is just a type with type variables in it). The
767 matcher assumes that there are no repeated type variables in the
768 template, so that it simply returns a mapping of type variables to
769 types. It also fails on nested foralls.
771 @matchTys@ matches corresponding elements of a list of templates and
775 matchTy :: GenType t1 u1 -- Template
776 -> GenType t2 u2 -- Proposed instance of template
777 -> Maybe [(t1,GenType t2 u2)] -- Matching substitution
780 matchTys :: [GenType t1 u1] -- Templates
781 -> [GenType t2 u2] -- Proposed instance of template
782 -> Maybe ([(t1,GenType t2 u2)],-- Matching substitution
783 [GenType t2 u2]) -- Left over instance types
785 matchTy ty1 ty2 = match ty1 ty2 (\s -> Just s) []
786 matchTys tys1 tys2 = go [] tys1 tys2
788 go s [] tys2 = Just (s,tys2)
789 go s (ty1:tys1) [] = trace "matchTys" Nothing
790 go s (ty1:tys1) (ty2:tys2) = match ty1 ty2 (\s' -> go s' tys1 tys2) s
793 @match@ is the main function.
796 match :: GenType t1 u1 -> GenType t2 u2 -- Current match pair
797 -> ([(t1, GenType t2 u2)] -> Maybe result) -- Continuation
798 -> [(t1, GenType t2 u2)] -- Current substitution
801 match (TyVarTy v) ty k = \s -> k ((v,ty) : s)
802 match (FunTy fun1 arg1 _) (FunTy fun2 arg2 _) k = match fun1 fun2 (match arg1 arg2 k)
803 match (AppTy fun1 arg1) (AppTy fun2 arg2) k = match fun1 fun2 (match arg1 arg2 k)
804 match (TyConTy con1 _) (TyConTy con2 _) k | con1 == con2 = k
805 match (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) k | clas1 == clas2 = match ty1 ty2 k
806 match (SynTy _ _ ty1) ty2 k = match ty1 ty2 k
807 match ty1 (SynTy _ _ ty2) k = match ty1 ty2 k
809 -- With type synonyms, we have to be careful for the exact
810 -- same reasons as in the unifier. Please see the
811 -- considerable commentary there before changing anything
815 match _ _ _ = \s -> Nothing
818 %************************************************************************
820 \subsection{Equality on types}
822 %************************************************************************
824 The functions eqSimpleTy and eqSimpleTheta are polymorphic in the types t
825 and u, but ONLY WORK FOR SIMPLE TYPES (ie. they panic if they see
826 dictionaries or polymorphic types). The function eqTy has a more
827 specific type, but does the `right thing' for all types.
830 eqSimpleTheta :: (Eq t,Eq u) =>
831 [(Class,GenType t u)] -> [(Class,GenType t u)] -> Bool
833 eqSimpleTheta [] [] = True
834 eqSimpleTheta ((c1,t1):th1) ((c2,t2):th2) =
835 c1==c2 && t1 `eqSimpleTy` t2 && th1 `eqSimpleTheta` th2
836 eqSimpleTheta other1 other2 = False
840 eqSimpleTy :: (Eq t,Eq u) => GenType t u -> GenType t u -> Bool
842 (TyVarTy tv1) `eqSimpleTy` (TyVarTy tv2) =
844 (AppTy f1 a1) `eqSimpleTy` (AppTy f2 a2) =
845 f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2
846 (TyConTy tc1 u1) `eqSimpleTy` (TyConTy tc2 u2) =
847 tc1 == tc2 --ToDo: later: && u1 == u2
849 (FunTy f1 a1 u1) `eqSimpleTy` (FunTy f2 a2 u2) =
850 f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 && u1 == u2
851 (FunTy f1 a1 u1) `eqSimpleTy` t2 =
852 -- Expand t1 just in case t2 matches that version
853 (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) `eqSimpleTy` t2
854 t1 `eqSimpleTy` (FunTy f2 a2 u2) =
855 -- Expand t2 just in case t1 matches that version
856 t1 `eqSimpleTy` (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
858 (SynTy tc1 ts1 t1) `eqSimpleTy` (SynTy tc2 ts2 t2) =
859 (tc1 == tc2 && and (zipWith eqSimpleTy ts1 ts2) && length ts1 == length ts2)
860 || t1 `eqSimpleTy` t2
861 (SynTy _ _ t1) `eqSimpleTy` t2 =
862 t1 `eqSimpleTy` t2 -- Expand the abbrevation and try again
863 t1 `eqSimpleTy` (SynTy _ _ t2) =
864 t1 `eqSimpleTy` t2 -- Expand the abbrevation and try again
866 (DictTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got DictTy"
867 _ `eqSimpleTy` (DictTy _ _ _) = panic "eqSimpleTy: got DictTy"
869 (ForAllTy _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllTy"
870 _ `eqSimpleTy` (ForAllTy _ _) = panic "eqSimpleTy: got ForAllTy"
872 (ForAllUsageTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllUsageTy"
873 _ `eqSimpleTy` (ForAllUsageTy _ _ _) = panic "eqSimpleTy: got ForAllUsageTy"
875 _ `eqSimpleTy` _ = False
878 Types are ordered so we can sort on types in the renamer etc. DNT: Since
879 this class is also used in CoreLint and other such places, we DO expand out
880 Fun/Syn/Dict types (if necessary).
883 eqTy :: Type -> Type -> Bool
886 eq nullTyVarEnv nullUVarEnv t1 t2
888 eq tve uve (TyVarTy tv1) (TyVarTy tv2) =
890 case (lookupTyVarEnv tve tv1) of
893 eq tve uve (AppTy f1 a1) (AppTy f2 a2) =
894 eq tve uve f1 f2 && eq tve uve a1 a2
895 eq tve uve (TyConTy tc1 u1) (TyConTy tc2 u2) =
896 tc1 == tc2 -- ToDo: LATER: && eqUsage uve u1 u2
898 eq tve uve (FunTy f1 a1 u1) (FunTy f2 a2 u2) =
899 eq tve uve f1 f2 && eq tve uve a1 a2 && eqUsage uve u1 u2
900 eq tve uve (FunTy f1 a1 u1) t2 =
901 -- Expand t1 just in case t2 matches that version
902 eq tve uve (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) t2
903 eq tve uve t1 (FunTy f2 a2 u2) =
904 -- Expand t2 just in case t1 matches that version
905 eq tve uve t1 (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
907 eq tve uve (DictTy c1 t1 u1) (DictTy c2 t2 u2)
909 = eq tve uve t1 t2 && eqUsage uve u1 u2
910 -- NB we use a guard for c1==c2 so that if they aren't equal we
911 -- fall through into expanding the type. Why? Because brain-dead
912 -- people might write
913 -- class Foo a => Baz a where {}
914 -- and that means that a Foo dictionary and a Baz dictionary are identical
915 -- Sigh. Let's hope we don't spend too much time in here!
917 eq tve uve t1@(DictTy _ _ _) t2 =
918 eq tve uve (expandTy t1) t2 -- Expand the dictionary and try again
919 eq tve uve t1 t2@(DictTy _ _ _) =
920 eq tve uve t1 (expandTy t2) -- Expand the dictionary and try again
922 eq tve uve (SynTy tc1 ts1 t1) (SynTy tc2 ts2 t2) =
923 (tc1 == tc2 && and (zipWith (eq tve uve) ts1 ts2) && length ts1 == length ts2)
925 eq tve uve (SynTy _ _ t1) t2 =
926 eq tve uve t1 t2 -- Expand the abbrevation and try again
927 eq tve uve t1 (SynTy _ _ t2) =
928 eq tve uve t1 t2 -- Expand the abbrevation and try again
930 eq tve uve (ForAllTy tv1 t1) (ForAllTy tv2 t2) =
931 eq (addOneToTyVarEnv tve tv1 tv2) uve t1 t2
932 eq tve uve (ForAllUsageTy u1 b1 t1) (ForAllUsageTy u2 b2 t2) =
933 eqBounds uve b1 b2 && eq tve (addOneToUVarEnv uve u1 u2) t1 t2
937 eqBounds uve [] [] = True
938 eqBounds uve (u1:b1) (u2:b2) = eqUVar uve u1 u2 && eqBounds uve b1 b2
939 eqBounds uve _ _ = False
943 showTypeCategory :: Type -> Char
945 {C,I,F,D} char, int, float, double
947 S other single-constructor type
948 {c,i,f,d} unboxed ditto
950 s *unpacked" single-cons...
956 + dictionary, unless it's a ...
959 M other (multi-constructor) data-con type
961 - reserved for others to mark as "uninteresting"
967 case getTyCon_maybe ty of
968 Nothing -> if maybeToBool (getFunTy_maybe ty)
973 let utc = uniqueOf tycon in
974 if utc == charDataConKey then 'C'
975 else if utc == intDataConKey then 'I'
976 else if utc == floatDataConKey then 'F'
977 else if utc == doubleDataConKey then 'D'
978 else if utc == integerDataConKey then 'J'
979 else if utc == charPrimTyConKey then 'c'
980 else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
981 || utc == addrPrimTyConKey) then 'i'
982 else if utc == floatPrimTyConKey then 'f'
983 else if utc == doublePrimTyConKey then 'd'
984 else if isPrimTyCon tycon {- array, we hope -} then 'A'
985 else if isEnumerationTyCon tycon then 'E'
986 else if isTupleTyCon tycon then 'T'
987 else if maybeToBool (maybeTyConSingleCon tycon) then 'S'
988 else if utc == listTyConKey then 'L'
989 else 'M' -- oh, well...