2 #include "HsVersions.h"
5 GenType(..), SYN_IE(Type), SYN_IE(TauType),
7 getTyVar, getTyVar_maybe, isTyVarTy,
8 mkAppTy, mkAppTys, splitAppTy,
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, typeKind
44 --IMPORT_DELOOPER(IdLoop) -- for paranoia checking
45 IMPORT_DELOOPER(TyLoop)
46 --IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
49 import Class ( classSig, classOpLocalType, GenClass{-instances-} )
50 import Kind ( mkBoxedTypeKind, resultKind, notArrowKind, Kind )
51 import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon,
52 isPrimTyCon, isDataTyCon, isSynTyCon, maybeNewTyCon, isNewTyCon,
53 tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
54 import TyVar ( tyVarKind, GenTyVar{-instances-}, SYN_IE(GenTyVarSet),
55 emptyTyVarSet, unionTyVarSets, minusTyVarSet,
56 unitTyVarSet, nullTyVarEnv, lookupTyVarEnv, delFromTyVarEnv,
57 addOneToTyVarEnv, SYN_IE(TyVarEnv), SYN_IE(TyVar) )
58 import Usage ( usageOmega, GenUsage, SYN_IE(Usage), SYN_IE(UVar), SYN_IE(UVarEnv),
59 nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar,
63 import Maybes ( maybeToBool, assocMaybe )
64 import PrimRep ( PrimRep(..) )
65 import Unique -- quite a few *Keys
66 import Util ( thenCmp, zipEqual, assoc,
67 panic, panic#, assertPanic, pprPanic,
76 -- PprType --(pprType )
78 -- UniqFM (ufmToList )
88 type Type = GenType TyVar UVar -- Used after typechecker
90 data GenType tyvar uvar -- Parameterised over type and usage variables
97 | TyConTy -- Constants of a specified kind
98 TyCon -- Must *not* be a SynTyCon
99 (GenUsage uvar) -- Usage gives uvar of the full application,
100 -- iff the full application is of kind Type
101 -- c.f. the Usage field in TyVars
103 | SynTy -- Synonyms must be saturated, and contain their expansion
104 TyCon -- Must be a SynTyCon
106 (GenType tyvar uvar) -- Expansion!
110 (GenType tyvar uvar) -- TypeKind
113 uvar -- Quantify over this
114 [uvar] -- Bounds; the quantified var must be
115 -- less than or equal to all these
118 -- Two special cases that save a *lot* of administrative
121 | FunTy -- BoxedTypeKind
122 (GenType tyvar uvar) -- Both args are of TypeKind
128 (GenType tyvar uvar) -- Arg has kind TypeKind
135 type ThetaType = [(Class, Type)]
136 type SigmaType = Type
142 Removes just the top level of any abbreviations.
145 expandTy :: Type -> Type -- Restricted to Type due to Dict expansion
147 expandTy (FunTy t1 t2 u) = AppTy (AppTy (TyConTy mkFunTyCon u) t1) t2
148 expandTy (SynTy _ _ t) = expandTy t
149 expandTy (DictTy clas ty u)
150 = case all_arg_tys of
152 [] -> voidTy -- Empty dictionary represented by Void
154 [arg_ty] -> expandTy arg_ty -- just the <whatever> itself
156 -- The extra expandTy is to make sure that
157 -- the result isn't still a dict, which it might be
158 -- if the original guy was a dict with one superdict and
161 other -> ASSERT(not (null all_arg_tys))
162 foldl AppTy (TyConTy (mkTupleTyCon (length all_arg_tys)) u) all_arg_tys
165 -- Note: length of all_arg_tys can be 0 if the class is
166 -- CCallable, CReturnable (and anything else
167 -- *really weird* that the user writes).
169 (tyvar, super_classes, ops) = classSig clas
170 super_dict_tys = map mk_super_ty super_classes
171 class_op_tys = map mk_op_ty ops
172 all_arg_tys = super_dict_tys ++ class_op_tys
173 mk_super_ty sc = DictTy sc ty usageOmega
174 mk_op_ty op = instantiateTy [(tyvar,ty)] (classOpLocalType op)
179 Simple construction and analysis functions
180 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
182 mkTyVarTy :: t -> GenType t u
183 mkTyVarTys :: [t] -> [GenType t y]
185 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
187 getTyVar :: String -> GenType t u -> t
188 getTyVar msg (TyVarTy tv) = tv
189 getTyVar msg (SynTy _ _ t) = getTyVar msg t
190 getTyVar msg other = panic ("getTyVar: " ++ msg)
192 getTyVar_maybe :: GenType t u -> Maybe t
193 getTyVar_maybe (TyVarTy tv) = Just tv
194 getTyVar_maybe (SynTy _ _ t) = getTyVar_maybe t
195 getTyVar_maybe other = Nothing
197 isTyVarTy :: GenType t u -> Bool
198 isTyVarTy (TyVarTy tv) = True
199 isTyVarTy (SynTy _ _ t) = isTyVarTy t
200 isTyVarTy other = False
206 mkAppTys :: GenType t u -> [GenType t u] -> GenType t u
207 mkAppTys t ts = foldl AppTy t ts
209 splitAppTy :: GenType t u -> (GenType t u, [GenType t u])
210 splitAppTy t = go t []
212 go (AppTy t arg) ts = go t (arg:ts)
213 go (FunTy fun arg u) ts = (TyConTy mkFunTyCon u, fun:arg:ts)
214 go (SynTy _ _ t) ts = go t ts
219 -- NB mkFunTy, mkFunTys puts in Omega usages, for now at least
220 mkFunTy arg res = FunTy arg res usageOmega
222 mkFunTys :: [GenType t u] -> GenType t u -> GenType t u
223 mkFunTys ts t = foldr (\ f a -> FunTy f a usageOmega) t ts
225 -- getFunTy_maybe and splitFunTy *must* have the general type given, which
226 -- means they *can't* do the DictTy jiggery-pokery that
227 -- *is* sometimes required. Hence we also have the ExpandingDicts variants
228 -- The relationship between these
229 -- two functions is like that between eqTy and eqSimpleTy.
230 -- ToDo: NUKE when we do dicts via newtype
232 getFunTy_maybe :: GenType t u -> Maybe (GenType t u, GenType t u)
233 getFunTy_maybe (FunTy arg result _) = Just (arg,result)
234 getFunTy_maybe (AppTy (AppTy (TyConTy tycon _) arg) res)
235 | isFunTyCon tycon = Just (arg, res)
236 getFunTy_maybe (SynTy _ _ t) = getFunTy_maybe t
237 getFunTy_maybe other = Nothing
239 getFunTyExpandingDicts_maybe :: Bool -- True <=> peek inside newtype applicatons
241 -> Maybe (Type, Type)
243 getFunTyExpandingDicts_maybe peek (FunTy arg result _) = Just (arg,result)
244 getFunTyExpandingDicts_maybe peek
245 (AppTy (AppTy (TyConTy tycon _) arg) res) | isFunTyCon tycon = Just (arg, res)
246 getFunTyExpandingDicts_maybe peek (SynTy _ _ t) = getFunTyExpandingDicts_maybe peek t
247 getFunTyExpandingDicts_maybe peek ty@(DictTy _ _ _) = getFunTyExpandingDicts_maybe peek (expandTy ty)
248 getFunTyExpandingDicts_maybe peek other
249 | not peek = Nothing -- that was easy
251 = case (maybeAppTyCon other) of
254 | not (isNewTyCon tc) -> Nothing
257 [newtype_con] = tyConDataCons tc -- there must be exactly one...
258 [inside_ty] = dataConArgTys newtype_con arg_tys
260 getFunTyExpandingDicts_maybe peek inside_ty
262 splitFunTy :: GenType t u -> ([GenType t u], GenType t u)
263 splitFunTyExpandingDicts :: Type -> ([Type], Type)
264 splitFunTyExpandingDictsAndPeeking :: Type -> ([Type], Type)
266 splitFunTy t = split_fun_ty getFunTy_maybe t
267 splitFunTyExpandingDicts t = split_fun_ty (getFunTyExpandingDicts_maybe False) t
268 splitFunTyExpandingDictsAndPeeking t = split_fun_ty (getFunTyExpandingDicts_maybe True) t
270 split_fun_ty get t = go t []
272 go t ts = case (get t) of
273 Just (arg,res) -> go res (arg:ts)
274 Nothing -> (reverse ts, t)
278 -- NB applyTyCon puts in usageOmega, for now at least
280 = ASSERT(not (isSynTyCon tycon))
281 TyConTy tycon usageOmega
283 applyTyCon :: TyCon -> [GenType t u] -> GenType t u
285 = ASSERT (not (isSynTyCon tycon))
286 --(if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $
287 foldl AppTy (TyConTy tycon usageOmega) tys
289 getTyCon_maybe :: GenType t u -> Maybe TyCon
290 --getTyConExpandingDicts_maybe :: Type -> Maybe TyCon
292 getTyCon_maybe (TyConTy tycon _) = Just tycon
293 getTyCon_maybe (SynTy _ _ t) = getTyCon_maybe t
294 getTyCon_maybe other_ty = Nothing
296 --getTyConExpandingDicts_maybe (TyConTy tycon _) = Just tycon
297 --getTyConExpandingDicts_maybe (SynTy _ _ t) = getTyConExpandingDicts_maybe t
298 --getTyConExpandingDicts_maybe ty@(DictTy _ _ _) = getTyConExpandingDicts_maybe (expandTy ty)
299 --getTyConExpandingDicts_maybe other_ty = Nothing
303 mkSynTy syn_tycon tys
304 = ASSERT(isSynTyCon syn_tycon)
305 SynTy syn_tycon tys (instantiateTauTy (zipEqual "mkSynTy" tyvars tys) body)
307 (tyvars, body) = getSynTyConDefn syn_tycon
313 isTauTy :: GenType t u -> Bool
314 isTauTy (TyVarTy v) = True
315 isTauTy (TyConTy _ _) = True
316 isTauTy (AppTy a b) = isTauTy a && isTauTy b
317 isTauTy (FunTy a b _) = isTauTy a && isTauTy b
318 isTauTy (SynTy _ _ ty) = isTauTy ty
319 isTauTy other = False
324 NB mkRhoTy and mkDictTy put in usageOmega, for now at least
327 mkDictTy :: Class -> GenType t u -> GenType t u
328 mkDictTy clas ty = DictTy clas ty usageOmega
330 mkRhoTy :: [(Class, GenType t u)] -> GenType t u -> GenType t u
332 foldr (\(c,t) r -> FunTy (DictTy c t usageOmega) r usageOmega) ty theta
334 splitRhoTy :: GenType t u -> ([(Class,GenType t u)], GenType t u)
338 go (FunTy (DictTy c t _) r _) ts = go r ((c,t):ts)
339 go (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts
342 go (SynTy _ _ t) ts = go t ts
343 go t ts = (reverse ts, t)
346 mkTheta :: [Type] -> ThetaType
347 -- recover a ThetaType from the types of some dictionaries
351 cvt (DictTy clas ty _) = (clas, ty)
352 cvt other = panic "Type.mkTheta" -- pprPanic "mkTheta:" (pprType PprDebug other)
354 isDictTy (DictTy _ _ _) = True
355 isDictTy (SynTy _ _ t) = isDictTy t
363 mkForAllTy = ForAllTy
365 mkForAllTys :: [t] -> GenType t u -> GenType t u
366 mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
368 getForAllTy_maybe :: GenType t u -> Maybe (t,GenType t u)
369 getForAllTy_maybe (SynTy _ _ t) = getForAllTy_maybe t
370 getForAllTy_maybe (ForAllTy tyvar t) = Just(tyvar,t)
371 getForAllTy_maybe _ = Nothing
373 getForAllTyExpandingDicts_maybe :: Type -> Maybe (TyVar, Type)
374 getForAllTyExpandingDicts_maybe (SynTy _ _ t) = getForAllTyExpandingDicts_maybe t
375 getForAllTyExpandingDicts_maybe (ForAllTy tyvar t) = Just(tyvar,t)
376 getForAllTyExpandingDicts_maybe ty@(DictTy _ _ _) = getForAllTyExpandingDicts_maybe (expandTy ty)
377 getForAllTyExpandingDicts_maybe _ = Nothing
379 splitForAllTy :: GenType t u-> ([t], GenType t u)
380 splitForAllTy t = go t []
382 go (ForAllTy tv t) tvs = go t (tv:tvs)
383 go (SynTy _ _ t) tvs = go t tvs
384 go t tvs = (reverse tvs, t)
388 mkForAllUsageTy :: u -> [u] -> GenType t u -> GenType t u
389 mkForAllUsageTy = ForAllUsageTy
391 getForAllUsageTy :: GenType t u -> Maybe (u,[u],GenType t u)
392 getForAllUsageTy (ForAllUsageTy uvar bounds t) = Just(uvar,bounds,t)
393 getForAllUsageTy (SynTy _ _ t) = getForAllUsageTy t
394 getForAllUsageTy _ = Nothing
397 Applied tycons (includes FunTyCons)
398 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
401 :: GenType tyvar uvar
402 -> Maybe (TyCon, -- the type constructor
403 [GenType tyvar uvar]) -- types to which it is applied
406 = case (getTyCon_maybe app_ty) of
408 Just tycon -> Just (tycon, arg_tys)
410 (app_ty, arg_tys) = splitAppTy ty
414 :: GenType tyvar uvar
415 -> (TyCon, -- the type constructor
416 [GenType tyvar uvar]) -- types to which it is applied
419 = case maybeAppTyCon ty of
422 Nothing -> panic "Type.getAppTyCon" -- (ppr PprShowAll ty)
426 Applied data tycons (give back constrs)
427 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
430 :: GenType (GenTyVar any) uvar
431 -> Maybe (TyCon, -- the type constructor
432 [GenType (GenTyVar any) uvar], -- types to which it is applied
433 [Id]) -- its family of data-constructors
434 maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts
435 :: Type -> Maybe (TyCon, [Type], [Id])
437 maybeAppDataTyCon ty = maybe_app_data_tycon (\x->x) ty
438 maybeAppDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty
439 maybeAppSpecDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty
442 maybe_app_data_tycon expand ty
444 expanded_ty = expand ty
445 (app_ty, arg_tys) = splitAppTy expanded_ty
447 case (getTyCon_maybe app_ty) of
448 Just tycon | --pprTrace "maybe_app:" (ppCat [ppr PprDebug (isDataTyCon tycon), ppr PprDebug (notArrowKind (typeKind expanded_ty))]) $
450 notArrowKind (typeKind expanded_ty)
451 -- Must be saturated for ty to be a data type
452 -> Just (tycon, arg_tys, tyConDataCons tycon)
456 getAppDataTyCon, getAppSpecDataTyCon
457 :: GenType (GenTyVar any) uvar
458 -> (TyCon, -- the type constructor
459 [GenType (GenTyVar any) uvar], -- types to which it is applied
460 [Id]) -- its family of data-constructors
461 getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts
462 :: Type -> (TyCon, [Type], [Id])
464 getAppDataTyCon ty = get_app_data_tycon maybeAppDataTyCon ty
465 getAppDataTyConExpandingDicts ty = --pprTrace "getAppDataTyConEx...:" (pprType PprDebug ty) $
466 get_app_data_tycon maybeAppDataTyConExpandingDicts ty
468 -- these should work like the UniTyFuns.getUniDataSpecTyCon* things of old (ToDo)
469 getAppSpecDataTyCon = getAppDataTyCon
470 getAppSpecDataTyConExpandingDicts = getAppDataTyConExpandingDicts
472 get_app_data_tycon maybe ty
476 Nothing -> panic "Type.getAppDataTyCon"-- (pprGenType PprShowAll ty)
480 maybeBoxedPrimType :: Type -> Maybe (Id, Type)
482 maybeBoxedPrimType ty
483 = case (maybeAppDataTyCon ty) of -- Data type,
484 Just (tycon, tys_applied, [data_con]) -- with exactly one constructor
485 -> case (dataConArgTys data_con tys_applied) of
486 [data_con_arg_ty] -- Applied to exactly one type,
487 | isPrimType data_con_arg_ty -- which is primitive
488 -> Just (data_con, data_con_arg_ty)
489 other_cases -> Nothing
490 other_cases -> Nothing
494 splitSigmaTy :: GenType t u -> ([t], [(Class,GenType t u)], GenType t u)
498 (tyvars,rho) = splitForAllTy ty
499 (theta,tau) = splitRhoTy rho
501 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
505 Finding the kind of a type
506 ~~~~~~~~~~~~~~~~~~~~~~~~~~
508 typeKind :: GenType (GenTyVar any) u -> Kind
510 typeKind (TyVarTy tyvar) = tyVarKind tyvar
511 typeKind (TyConTy tycon usage) = tyConKind tycon
512 typeKind (SynTy _ _ ty) = typeKind ty
513 typeKind (FunTy fun arg _) = mkBoxedTypeKind
514 typeKind (DictTy clas arg _) = mkBoxedTypeKind
515 typeKind (AppTy fun arg) = resultKind (typeKind fun)
516 typeKind (ForAllTy _ _) = mkBoxedTypeKind
517 typeKind (ForAllUsageTy _ _ _) = mkBoxedTypeKind
521 Free variables of a type
522 ~~~~~~~~~~~~~~~~~~~~~~~~
524 tyVarsOfType :: GenType (GenTyVar flexi) uvar -> GenTyVarSet flexi
526 tyVarsOfType (TyVarTy tv) = unitTyVarSet tv
527 tyVarsOfType (TyConTy tycon usage) = emptyTyVarSet
528 tyVarsOfType (SynTy _ tys ty) = tyVarsOfTypes tys
529 tyVarsOfType (FunTy arg res _) = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res
530 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg
531 tyVarsOfType (DictTy clas ty _) = tyVarsOfType ty
532 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar
533 tyVarsOfType (ForAllUsageTy _ _ ty) = tyVarsOfType ty
535 tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi
536 tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
543 applyTy :: GenType (GenTyVar flexi) uvar
544 -> GenType (GenTyVar flexi) uvar
545 -> GenType (GenTyVar flexi) uvar
547 applyTy (SynTy _ _ fun) arg = applyTy fun arg
548 applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty
549 applyTy other arg = panic "applyTy"
553 instantiateTy :: [(GenTyVar flexi, GenType (GenTyVar flexi) uvar)]
554 -> GenType (GenTyVar flexi) uvar
555 -> GenType (GenTyVar flexi) uvar
557 instantiateTauTy :: Eq tv =>
558 [(tv, GenType tv' u)]
562 applyTypeEnvToTy :: TyVarEnv Type -> SigmaType -> SigmaType
564 -- instantiateTauTy works only (a) on types with no ForAlls,
565 -- and when (b) all the type variables are being instantiated
566 -- In return it is more polymorphic than instantiateTy
568 instant_help ty lookup_tv deflt_tv choose_tycon
569 if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
572 go (TyVarTy tv) = case (lookup_tv tv) of
573 Nothing -> deflt_tv tv
575 go ty@(TyConTy tycon usage) = choose_tycon ty tycon usage
576 go (SynTy tycon tys ty) = SynTy tycon (map go tys) (go ty)
577 go (FunTy arg res usage) = FunTy (go arg) (go res) usage
578 go (AppTy fun arg) = AppTy (go fun) (go arg)
579 go (DictTy clas ty usage) = DictTy clas (go ty) usage
580 go (ForAllUsageTy uvar bds ty) = if_usage $
581 ForAllUsageTy uvar bds (go ty)
582 go (ForAllTy tv ty) = if_forall $
583 (if (bound_forall_tv_BAD && maybeToBool (lookup_tv tv)) then
584 trace "instantiateTy: unexpected forall hit"
586 \x->x) ForAllTy (deflt_forall_tv tv) (go ty)
588 instantiateTy tenv ty
589 = instant_help ty lookup_tv deflt_tv choose_tycon
590 if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
592 lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of
595 _ -> panic "instantiateTy:lookup_tv"
597 deflt_tv tv = TyVarTy tv
598 choose_tycon ty _ _ = ty
601 bound_forall_tv_BAD = True
602 deflt_forall_tv tv = tv
604 instantiateTauTy tenv ty
605 = instant_help ty lookup_tv deflt_tv choose_tycon
606 if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
608 lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of
611 _ -> panic "instantiateTauTy:lookup_tv"
613 deflt_tv tv = panic "instantiateTauTy"
614 choose_tycon _ tycon usage = TyConTy tycon usage
615 if_usage ty = panic "instantiateTauTy:ForAllUsageTy"
616 if_forall ty = panic "instantiateTauTy:ForAllTy"
617 bound_forall_tv_BAD = panic "instantiateTauTy:bound_forall_tv"
618 deflt_forall_tv tv = panic "instantiateTauTy:deflt_forall_tv"
621 -- applyTypeEnv applies a type environment to a type.
622 -- It can handle shadowing; for example:
623 -- f = /\ t1 t2 -> \ d ->
624 -- letrec f' = /\ t1 -> \x -> ...(f' t1 x')...
626 -- Here, when we clone t1 to t1', say, we'll come across shadowing
627 -- when applying the clone environment to the type of f'.
629 -- As a sanity check, we should also check that name capture
630 -- doesn't occur, but that means keeping track of the free variables of the
631 -- range of the TyVarEnv, which I don't do just yet.
633 -- We don't use instant_help because we need to carry in the environment
635 applyTypeEnvToTy tenv ty
638 go tenv ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of
641 go tenv ty@(TyConTy tycon usage) = ty
642 go tenv (SynTy tycon tys ty) = SynTy tycon (map (go tenv) tys) (go tenv ty)
643 go tenv (FunTy arg res usage) = FunTy (go tenv arg) (go tenv res) usage
644 go tenv (AppTy fun arg) = AppTy (go tenv fun) (go tenv arg)
645 go tenv (DictTy clas ty usage) = DictTy clas (go tenv ty) usage
646 go tenv (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go tenv ty)
647 go tenv (ForAllTy tv ty) = ForAllTy tv (go tenv' ty)
649 tenv' = case lookupTyVarEnv tenv tv of
651 Just _ -> delFromTyVarEnv tenv tv
656 :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u'
658 instantiateUsage = panic "instantiateUsage: not implemented"
662 At present there are no unboxed non-primitive types, so
663 isUnboxedType is the same as isPrimType.
665 We're a bit cavalier about finding out whether something is
666 primitive/unboxed or not. Rather than deal with the type
667 arguemnts we just zoom into the function part of the type.
668 That is, given (T a) we just recurse into the "T" part,
672 isPrimType, isUnboxedType :: Type -> Bool
674 isPrimType (AppTy ty _) = isPrimType ty
675 isPrimType (SynTy _ _ ty) = isPrimType ty
676 isPrimType (TyConTy tycon _) = case maybeNewTyCon tycon of
677 Just (tyvars, ty) -> isPrimType ty
678 Nothing -> isPrimTyCon tycon
682 isUnboxedType = isPrimType
685 This is *not* right: it is a placeholder (ToDo 96/03 WDP):
687 typePrimRep :: Type -> PrimRep
689 typePrimRep (SynTy _ _ ty) = typePrimRep ty
690 typePrimRep (AppTy ty _) = typePrimRep ty
691 typePrimRep (TyConTy tc _)
692 | isPrimTyCon tc = case (assocMaybe tc_primrep_list (uniqueOf tc)) of
694 Nothing -> panic "Type.typePrimRep" -- pprPanic "typePrimRep:" (pprTyCon PprDebug tc)
696 | otherwise = case maybeNewTyCon tc of
697 Just (tyvars, ty) | isPrimType ty -> typePrimRep ty
698 _ -> PtrRep -- Default
700 typePrimRep _ = PtrRep -- the "default"
703 = [(addrPrimTyConKey, AddrRep)
704 ,(arrayPrimTyConKey, ArrayRep)
705 ,(byteArrayPrimTyConKey, ByteArrayRep)
706 ,(charPrimTyConKey, CharRep)
707 ,(doublePrimTyConKey, DoubleRep)
708 ,(floatPrimTyConKey, FloatRep)
709 ,(foreignObjPrimTyConKey, ForeignObjRep)
710 ,(intPrimTyConKey, IntRep)
711 ,(mutableArrayPrimTyConKey, ArrayRep)
712 ,(mutableByteArrayPrimTyConKey, ByteArrayRep)
713 ,(stablePtrPrimTyConKey, StablePtrRep)
714 ,(statePrimTyConKey, VoidRep)
715 ,(synchVarPrimTyConKey, PtrRep)
716 ,(voidTyConKey, VoidRep)
717 ,(wordPrimTyConKey, WordRep)
721 %************************************************************************
723 \subsection{Matching on types}
725 %************************************************************************
727 Matching is a {\em unidirectional} process, matching a type against a
728 template (which is just a type with type variables in it). The
729 matcher assumes that there are no repeated type variables in the
730 template, so that it simply returns a mapping of type variables to
731 types. It also fails on nested foralls.
733 @matchTys@ matches corresponding elements of a list of templates and
737 matchTy :: GenType t1 u1 -- Template
738 -> GenType t2 u2 -- Proposed instance of template
739 -> Maybe [(t1,GenType t2 u2)] -- Matching substitution
742 matchTys :: [GenType t1 u1] -- Templates
743 -> [GenType t2 u2] -- Proposed instance of template
744 -> Maybe ([(t1,GenType t2 u2)],-- Matching substitution
745 [GenType t2 u2]) -- Left over instance types
747 matchTy ty1 ty2 = match ty1 ty2 (\s -> Just s) []
748 matchTys tys1 tys2 = go [] tys1 tys2
750 go s [] tys2 = Just (s,tys2)
751 go s (ty1:tys1) [] = trace "matchTys" Nothing
752 go s (ty1:tys1) (ty2:tys2) = match ty1 ty2 (\s' -> go s' tys1 tys2) s
755 @match@ is the main function.
758 match :: GenType t1 u1 -> GenType t2 u2 -- Current match pair
759 -> ([(t1, GenType t2 u2)] -> Maybe result) -- Continuation
760 -> [(t1, GenType t2 u2)] -- Current substitution
763 match (TyVarTy v) ty k = \s -> k ((v,ty) : s)
764 match (FunTy fun1 arg1 _) (FunTy fun2 arg2 _) k = match fun1 fun2 (match arg1 arg2 k)
765 match (AppTy fun1 arg1) (AppTy fun2 arg2) k = match fun1 fun2 (match arg1 arg2 k)
766 match (TyConTy con1 _) (TyConTy con2 _) k | con1 == con2 = k
767 match (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) k | clas1 == clas2 = match ty1 ty2 k
768 match (SynTy _ _ ty1) ty2 k = match ty1 ty2 k
769 match ty1 (SynTy _ _ ty2) k = match ty1 ty2 k
771 -- With type synonyms, we have to be careful for the exact
772 -- same reasons as in the unifier. Please see the
773 -- considerable commentary there before changing anything
777 match _ _ _ = \s -> Nothing
780 %************************************************************************
782 \subsection{Equality on types}
784 %************************************************************************
786 The functions eqSimpleTy and eqSimpleTheta are polymorphic in the types t
787 and u, but ONLY WORK FOR SIMPLE TYPES (ie. they panic if they see
788 dictionaries or polymorphic types). The function eqTy has a more
789 specific type, but does the `right thing' for all types.
792 eqSimpleTheta :: (Eq t,Eq u) =>
793 [(Class,GenType t u)] -> [(Class,GenType t u)] -> Bool
795 eqSimpleTheta [] [] = True
796 eqSimpleTheta ((c1,t1):th1) ((c2,t2):th2) =
797 c1==c2 && t1 `eqSimpleTy` t2 && th1 `eqSimpleTheta` th2
798 eqSimpleTheta other1 other2 = False
802 eqSimpleTy :: (Eq t,Eq u) => GenType t u -> GenType t u -> Bool
804 (TyVarTy tv1) `eqSimpleTy` (TyVarTy tv2) =
806 (AppTy f1 a1) `eqSimpleTy` (AppTy f2 a2) =
807 f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2
808 (TyConTy tc1 u1) `eqSimpleTy` (TyConTy tc2 u2) =
809 tc1 == tc2 --ToDo: later: && u1 == u2
811 (FunTy f1 a1 u1) `eqSimpleTy` (FunTy f2 a2 u2) =
812 f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 && u1 == u2
813 (FunTy f1 a1 u1) `eqSimpleTy` t2 =
814 -- Expand t1 just in case t2 matches that version
815 (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) `eqSimpleTy` t2
816 t1 `eqSimpleTy` (FunTy f2 a2 u2) =
817 -- Expand t2 just in case t1 matches that version
818 t1 `eqSimpleTy` (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
820 (SynTy tc1 ts1 t1) `eqSimpleTy` (SynTy tc2 ts2 t2) =
821 (tc1 == tc2 && and (zipWith eqSimpleTy ts1 ts2) && length ts1 == length ts2)
822 || t1 `eqSimpleTy` t2
823 (SynTy _ _ t1) `eqSimpleTy` t2 =
824 t1 `eqSimpleTy` t2 -- Expand the abbrevation and try again
825 t1 `eqSimpleTy` (SynTy _ _ t2) =
826 t1 `eqSimpleTy` t2 -- Expand the abbrevation and try again
828 (DictTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got DictTy"
829 _ `eqSimpleTy` (DictTy _ _ _) = panic "eqSimpleTy: got DictTy"
831 (ForAllTy _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllTy"
832 _ `eqSimpleTy` (ForAllTy _ _) = panic "eqSimpleTy: got ForAllTy"
834 (ForAllUsageTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllUsageTy"
835 _ `eqSimpleTy` (ForAllUsageTy _ _ _) = panic "eqSimpleTy: got ForAllUsageTy"
837 _ `eqSimpleTy` _ = False
840 Types are ordered so we can sort on types in the renamer etc. DNT: Since
841 this class is also used in CoreLint and other such places, we DO expand out
842 Fun/Syn/Dict types (if necessary).
845 eqTy :: Type -> Type -> Bool
848 eq nullTyVarEnv nullUVarEnv t1 t2
850 eq tve uve (TyVarTy tv1) (TyVarTy tv2) =
852 case (lookupTyVarEnv tve tv1) of
855 eq tve uve (AppTy f1 a1) (AppTy f2 a2) =
856 eq tve uve f1 f2 && eq tve uve a1 a2
857 eq tve uve (TyConTy tc1 u1) (TyConTy tc2 u2) =
858 tc1 == tc2 -- ToDo: LATER: && eqUsage uve u1 u2
860 eq tve uve (FunTy f1 a1 u1) (FunTy f2 a2 u2) =
861 eq tve uve f1 f2 && eq tve uve a1 a2 && eqUsage uve u1 u2
862 eq tve uve (FunTy f1 a1 u1) t2 =
863 -- Expand t1 just in case t2 matches that version
864 eq tve uve (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) t2
865 eq tve uve t1 (FunTy f2 a2 u2) =
866 -- Expand t2 just in case t1 matches that version
867 eq tve uve t1 (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
869 eq tve uve (DictTy c1 t1 u1) (DictTy c2 t2 u2)
871 = eq tve uve t1 t2 && eqUsage uve u1 u2
872 -- NB we use a guard for c1==c2 so that if they aren't equal we
873 -- fall through into expanding the type. Why? Because brain-dead
874 -- people might write
875 -- class Foo a => Baz a where {}
876 -- and that means that a Foo dictionary and a Baz dictionary are identical
877 -- Sigh. Let's hope we don't spend too much time in here!
879 eq tve uve t1@(DictTy _ _ _) t2 =
880 eq tve uve (expandTy t1) t2 -- Expand the dictionary and try again
881 eq tve uve t1 t2@(DictTy _ _ _) =
882 eq tve uve t1 (expandTy t2) -- Expand the dictionary and try again
884 eq tve uve (SynTy tc1 ts1 t1) (SynTy tc2 ts2 t2) =
885 (tc1 == tc2 && and (zipWith (eq tve uve) ts1 ts2) && length ts1 == length ts2)
887 eq tve uve (SynTy _ _ t1) t2 =
888 eq tve uve t1 t2 -- Expand the abbrevation and try again
889 eq tve uve t1 (SynTy _ _ t2) =
890 eq tve uve t1 t2 -- Expand the abbrevation and try again
892 eq tve uve (ForAllTy tv1 t1) (ForAllTy tv2 t2) =
893 eq (addOneToTyVarEnv tve tv1 tv2) uve t1 t2
894 eq tve uve (ForAllUsageTy u1 b1 t1) (ForAllUsageTy u2 b2 t2) =
895 eqBounds uve b1 b2 && eq tve (addOneToUVarEnv uve u1 u2) t1 t2
899 eqBounds uve [] [] = True
900 eqBounds uve (u1:b1) (u2:b2) = eqUVar uve u1 u2 && eqBounds uve b1 b2
901 eqBounds uve _ _ = False