2 #include "HsVersions.h"
5 GenType(..), Type(..), TauType(..),
7 getTyVar, getTyVar_maybe, isTyVarTy,
8 mkAppTy, mkAppTys, splitAppTy,
9 mkFunTy, mkFunTys, splitFunTy, splitFunTyExpandingDicts,
10 getFunTy_maybe, getFunTyExpandingDicts_maybe,
11 mkTyConTy, getTyCon_maybe, applyTyCon,
13 mkForAllTy, mkForAllTys, getForAllTy_maybe, splitForAllTy,
14 mkForAllUsageTy, getForAllUsageTy,
17 expandTy, -- only let out for debugging (ToDo: rm?)
19 isPrimType, isUnboxedType, typePrimRep,
21 RhoType(..), SigmaType(..), ThetaType(..),
23 mkRhoTy, splitRhoTy, mkTheta,
24 mkSigmaTy, splitSigmaTy,
26 maybeAppTyCon, getAppTyCon,
27 maybeAppDataTyCon, getAppDataTyCon, getAppSpecDataTyCon,
28 maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts,
29 getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts,
32 matchTy, matchTys, eqTy, eqSimpleTy, eqSimpleTheta,
34 instantiateTy, instantiateTauTy, instantiateUsage,
39 tyVarsOfType, tyVarsOfTypes, typeKind
43 import IdLoop -- for paranoia checking
44 import TyLoop -- for paranoia checking
45 import PrelLoop -- for paranoia checking
48 import Class ( classSig, classOpLocalType, GenClass{-instances-} )
49 import Kind ( mkBoxedTypeKind, resultKind )
50 import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, isSynTyCon, tyConArity,
51 tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
52 import TyVar ( tyVarKind, GenTyVar{-instances-}, GenTyVarSet(..),
53 emptyTyVarSet, unionTyVarSets, minusTyVarSet,
54 unitTyVarSet, nullTyVarEnv, lookupTyVarEnv,
55 addOneToTyVarEnv, TyVarEnv(..) )
56 import Usage ( usageOmega, GenUsage, Usage(..), UVar(..), UVarEnv(..),
57 nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar,
61 import Maybes ( maybeToBool )
62 import PrimRep ( PrimRep(..) )
63 import Util ( thenCmp, zipEqual, panic, panic#, assertPanic, pprTrace{-ToDo:rm-}, pprPanic{-ToDo:rm-},
83 type Type = GenType TyVar UVar -- Used after typechecker
85 data GenType tyvar uvar -- Parameterised over type and usage variables
92 | TyConTy -- Constants of a specified kind
93 TyCon -- Must *not* be a SynTyCon
94 (GenUsage uvar) -- Usage gives uvar of the full application,
95 -- iff the full application is of kind Type
96 -- c.f. the Usage field in TyVars
98 | SynTy -- Synonyms must be saturated, and contain their expansion
99 TyCon -- Must be a SynTyCon
101 (GenType tyvar uvar) -- Expansion!
105 (GenType tyvar uvar) -- TypeKind
108 uvar -- Quantify over this
109 [uvar] -- Bounds; the quantified var must be
110 -- less than or equal to all these
113 -- Two special cases that save a *lot* of administrative
116 | FunTy -- BoxedTypeKind
117 (GenType tyvar uvar) -- Both args are of TypeKind
123 (GenType tyvar uvar) -- Arg has kind TypeKind
130 type ThetaType = [(Class, Type)]
131 type SigmaType = Type
137 Removes just the top level of any abbreviations.
140 expandTy :: Type -> Type -- Restricted to Type due to Dict expansion
142 expandTy (FunTy t1 t2 u) = AppTy (AppTy (TyConTy mkFunTyCon u) t1) t2
143 expandTy (SynTy _ _ t) = expandTy t
144 expandTy (DictTy clas ty u)
145 = case all_arg_tys of
147 [arg_ty] -> expandTy arg_ty -- just the <whatever> itself
149 -- The extra expandTy is to make sure that
150 -- the result isn't still a dict, which it might be
151 -- if the original guy was a dict with one superdict and
154 other -> ASSERT(not (null all_arg_tys))
155 foldl AppTy (TyConTy (mkTupleTyCon (length all_arg_tys)) u) all_arg_tys
158 -- Note: length of all_arg_tys can be 0 if the class is
159 -- CCallable, CReturnable (and anything else
160 -- *really weird* that the user writes).
162 (tyvar, super_classes, ops) = classSig clas
163 super_dict_tys = map mk_super_ty super_classes
164 class_op_tys = map mk_op_ty ops
165 all_arg_tys = super_dict_tys ++ class_op_tys
166 mk_super_ty sc = DictTy sc ty usageOmega
167 mk_op_ty op = instantiateTy [(tyvar,ty)] (classOpLocalType op)
172 Simple construction and analysis functions
173 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
175 mkTyVarTy :: t -> GenType t u
176 mkTyVarTys :: [t] -> [GenType t y]
178 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
180 getTyVar :: String -> GenType t u -> t
181 getTyVar msg (TyVarTy tv) = tv
182 getTyVar msg (SynTy _ _ t) = getTyVar msg t
183 getTyVar msg other = panic ("getTyVar: " ++ msg)
185 getTyVar_maybe :: GenType t u -> Maybe t
186 getTyVar_maybe (TyVarTy tv) = Just tv
187 getTyVar_maybe (SynTy _ _ t) = getTyVar_maybe t
188 getTyVar_maybe other = Nothing
190 isTyVarTy :: GenType t u -> Bool
191 isTyVarTy (TyVarTy tv) = True
192 isTyVarTy (SynTy _ _ t) = isTyVarTy t
193 isTyVarTy other = False
199 mkAppTys :: GenType t u -> [GenType t u] -> GenType t u
200 mkAppTys t ts = foldl AppTy t ts
202 splitAppTy :: GenType t u -> (GenType t u, [GenType t u])
203 splitAppTy t = go t []
205 go (AppTy t arg) ts = go t (arg:ts)
206 go (FunTy fun arg u) ts = (TyConTy mkFunTyCon u, fun:arg:ts)
207 go (SynTy _ _ t) ts = go t ts
212 -- NB mkFunTy, mkFunTys puts in Omega usages, for now at least
213 mkFunTy arg res = FunTy arg res usageOmega
215 mkFunTys :: [GenType t u] -> GenType t u -> GenType t u
216 mkFunTys ts t = foldr (\ f a -> FunTy f a usageOmega) t ts
218 -- getFunTy_maybe and splitFunTy *must* have the general type given, which
219 -- means they *can't* do the DictTy jiggery-pokery that
220 -- *is* sometimes required. Hence we also have the ExpandingDicts variants
221 -- The relationship between these
222 -- two functions is like that between eqTy and eqSimpleTy.
223 -- ToDo: NUKE when we do dicts via newtype
225 getFunTy_maybe :: GenType t u -> Maybe (GenType t u, GenType t u)
226 getFunTy_maybe (FunTy arg result _) = Just (arg,result)
227 getFunTy_maybe (AppTy (AppTy (TyConTy tycon _) arg) res)
228 | isFunTyCon tycon = Just (arg, res)
229 getFunTy_maybe (SynTy _ _ t) = getFunTy_maybe t
230 getFunTy_maybe other = Nothing
232 getFunTyExpandingDicts_maybe :: Type -> Maybe (Type, Type)
233 getFunTyExpandingDicts_maybe (FunTy arg result _) = Just (arg,result)
234 getFunTyExpandingDicts_maybe
235 (AppTy (AppTy (TyConTy tycon _) arg) res) | isFunTyCon tycon = Just (arg, res)
236 getFunTyExpandingDicts_maybe (SynTy _ _ t) = getFunTyExpandingDicts_maybe t
237 getFunTyExpandingDicts_maybe ty@(DictTy _ _ _) = getFunTyExpandingDicts_maybe (expandTy ty)
238 getFunTyExpandingDicts_maybe other = Nothing
240 splitFunTy :: GenType t u -> ([GenType t u], GenType t u)
241 splitFunTyExpandingDicts :: Type -> ([Type], Type)
243 splitFunTy t = split_fun_ty getFunTy_maybe t
244 splitFunTyExpandingDicts t = split_fun_ty getFunTyExpandingDicts_maybe t
246 split_fun_ty get t = go t []
248 go t ts = case (get t) of
249 Just (arg,res) -> go res (arg:ts)
250 Nothing -> (reverse ts, t)
254 -- NB applyTyCon puts in usageOmega, for now at least
256 = ASSERT(not (isSynTyCon tycon))
257 TyConTy tycon usageOmega
259 applyTyCon :: TyCon -> [GenType t u] -> GenType t u
261 = ASSERT (not (isSynTyCon tycon))
262 foldl AppTy (TyConTy tycon usageOmega) tys
264 getTyCon_maybe :: GenType t u -> Maybe TyCon
265 --getTyConExpandingDicts_maybe :: Type -> Maybe TyCon
267 getTyCon_maybe (TyConTy tycon _) = Just tycon
268 getTyCon_maybe (SynTy _ _ t) = getTyCon_maybe t
269 getTyCon_maybe other_ty = Nothing
271 --getTyConExpandingDicts_maybe (TyConTy tycon _) = Just tycon
272 --getTyConExpandingDicts_maybe (SynTy _ _ t) = getTyConExpandingDicts_maybe t
273 --getTyConExpandingDicts_maybe ty@(DictTy _ _ _) = getTyConExpandingDicts_maybe (expandTy ty)
274 --getTyConExpandingDicts_maybe other_ty = Nothing
278 mkSynTy syn_tycon tys
279 = ASSERT(isSynTyCon syn_tycon)
280 SynTy syn_tycon tys (instantiateTauTy (zipEqual "mkSynTy" tyvars tys) body)
282 (tyvars, body) = getSynTyConDefn syn_tycon
288 isTauTy :: GenType t u -> Bool
289 isTauTy (TyVarTy v) = True
290 isTauTy (TyConTy _ _) = True
291 isTauTy (AppTy a b) = isTauTy a && isTauTy b
292 isTauTy (FunTy a b _) = isTauTy a && isTauTy b
293 isTauTy (SynTy _ _ ty) = isTauTy ty
294 isTauTy other = False
299 NB mkRhoTy and mkDictTy put in usageOmega, for now at least
302 mkDictTy :: Class -> GenType t u -> GenType t u
303 mkDictTy clas ty = DictTy clas ty usageOmega
305 mkRhoTy :: [(Class, GenType t u)] -> GenType t u -> GenType t u
307 foldr (\(c,t) r -> FunTy (DictTy c t usageOmega) r usageOmega) ty theta
309 splitRhoTy :: GenType t u -> ([(Class,GenType t u)], GenType t u)
313 go (FunTy (DictTy c t _) r _) ts = go r ((c,t):ts)
314 go (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts
317 go (SynTy _ _ t) ts = go t ts
318 go t ts = (reverse ts, t)
321 mkTheta :: [Type] -> ThetaType
322 -- recover a ThetaType from the types of some dictionaries
326 cvt (DictTy clas ty _) = (clas, ty)
327 cvt other = pprPanic "mkTheta:" (pprType PprDebug other)
334 mkForAllTy = ForAllTy
336 mkForAllTys :: [t] -> GenType t u -> GenType t u
337 mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
339 getForAllTy_maybe :: GenType t u -> Maybe (t,GenType t u)
340 getForAllTy_maybe (SynTy _ _ t) = getForAllTy_maybe t
341 getForAllTy_maybe (ForAllTy tyvar t) = Just(tyvar,t)
342 getForAllTy_maybe _ = Nothing
344 splitForAllTy :: GenType t u-> ([t], GenType t u)
345 splitForAllTy t = go t []
347 go (ForAllTy tv t) tvs = go t (tv:tvs)
348 go (SynTy _ _ t) tvs = go t tvs
349 go t tvs = (reverse tvs, t)
353 mkForAllUsageTy :: u -> [u] -> GenType t u -> GenType t u
354 mkForAllUsageTy = ForAllUsageTy
356 getForAllUsageTy :: GenType t u -> Maybe (u,[u],GenType t u)
357 getForAllUsageTy (ForAllUsageTy uvar bounds t) = Just(uvar,bounds,t)
358 getForAllUsageTy (SynTy _ _ t) = getForAllUsageTy t
359 getForAllUsageTy _ = Nothing
362 Applied tycons (includes FunTyCons)
363 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
366 :: GenType tyvar uvar
367 -> Maybe (TyCon, -- the type constructor
368 [GenType tyvar uvar]) -- types to which it is applied
371 = case (getTyCon_maybe app_ty) of
373 Just tycon -> Just (tycon, arg_tys)
375 (app_ty, arg_tys) = splitAppTy ty
379 :: GenType tyvar uvar
380 -> (TyCon, -- the type constructor
381 [GenType tyvar uvar]) -- types to which it is applied
384 = case maybeAppTyCon ty of
387 Nothing -> panic "Type.getAppTyCon" -- (ppr PprShowAll ty)
391 Applied data tycons (give back constrs)
392 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
395 :: GenType tyvar uvar
396 -> Maybe (TyCon, -- the type constructor
397 [GenType tyvar uvar], -- types to which it is applied
398 [Id]) -- its family of data-constructors
399 maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts
400 :: Type -> Maybe (TyCon, [Type], [Id])
402 maybeAppDataTyCon ty = maybe_app_data_tycon (\x->x) ty
403 maybeAppDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty
404 maybeAppSpecDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty
407 maybe_app_data_tycon expand ty
408 = case (getTyCon_maybe app_ty) of
409 Just tycon | isDataTyCon tycon &&
410 tyConArity tycon == length arg_tys
411 -- Must be saturated for ty to be a data type
412 -> Just (tycon, arg_tys, tyConDataCons tycon)
416 (app_ty, arg_tys) = splitAppTy (expand ty)
418 getAppDataTyCon, getAppSpecDataTyCon
419 :: GenType tyvar uvar
420 -> (TyCon, -- the type constructor
421 [GenType tyvar uvar], -- types to which it is applied
422 [Id]) -- its family of data-constructors
423 getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts
424 :: Type -> (TyCon, [Type], [Id])
426 getAppDataTyCon ty = get_app_data_tycon maybeAppDataTyCon ty
427 getAppDataTyConExpandingDicts ty = get_app_data_tycon maybeAppDataTyConExpandingDicts ty
429 -- these should work like the UniTyFuns.getUniDataSpecTyCon* things of old (ToDo)
430 getAppSpecDataTyCon = getAppDataTyCon
431 getAppSpecDataTyConExpandingDicts = getAppDataTyConExpandingDicts
433 get_app_data_tycon maybe ty
437 Nothing -> panic "Type.getAppDataTyCon" -- (pprGenType PprShowAll ty)
441 maybeBoxedPrimType :: Type -> Maybe (Id, Type)
443 maybeBoxedPrimType ty
444 = case (maybeAppDataTyCon ty) of -- Data type,
445 Just (tycon, tys_applied, [data_con]) -- with exactly one constructor
446 -> case (dataConArgTys data_con tys_applied) of
447 [data_con_arg_ty] -- Applied to exactly one type,
448 | isPrimType data_con_arg_ty -- which is primitive
449 -> Just (data_con, data_con_arg_ty)
450 other_cases -> Nothing
451 other_cases -> Nothing
455 splitSigmaTy :: GenType t u -> ([t], [(Class,GenType t u)], GenType t u)
459 (tyvars,rho) = splitForAllTy ty
460 (theta,tau) = splitRhoTy rho
462 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
466 Finding the kind of a type
467 ~~~~~~~~~~~~~~~~~~~~~~~~~~
469 typeKind :: GenType (GenTyVar any) u -> Kind
470 typeKind (TyVarTy tyvar) = tyVarKind tyvar
471 typeKind (TyConTy tycon usage) = tyConKind tycon
472 typeKind (SynTy _ _ ty) = typeKind ty
473 typeKind (FunTy fun arg _) = mkBoxedTypeKind
474 typeKind (DictTy clas arg _) = mkBoxedTypeKind
475 typeKind (AppTy fun arg) = resultKind (typeKind fun)
476 typeKind (ForAllTy _ _) = mkBoxedTypeKind
477 typeKind (ForAllUsageTy _ _ _) = mkBoxedTypeKind
481 Free variables of a type
482 ~~~~~~~~~~~~~~~~~~~~~~~~
484 tyVarsOfType :: GenType (GenTyVar flexi) uvar -> GenTyVarSet flexi
486 tyVarsOfType (TyVarTy tv) = unitTyVarSet tv
487 tyVarsOfType (TyConTy tycon usage) = emptyTyVarSet
488 tyVarsOfType (SynTy _ tys ty) = tyVarsOfTypes tys
489 tyVarsOfType (FunTy arg res _) = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res
490 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg
491 tyVarsOfType (DictTy clas ty _) = tyVarsOfType ty
492 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar
493 tyVarsOfType (ForAllUsageTy _ _ ty) = tyVarsOfType ty
495 tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi
496 tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
503 applyTy :: GenType (GenTyVar flexi) uvar
504 -> GenType (GenTyVar flexi) uvar
505 -> GenType (GenTyVar flexi) uvar
507 applyTy (SynTy _ _ fun) arg = applyTy fun arg
508 applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty
509 applyTy other arg = panic "applyTy"
513 instantiateTy :: [(GenTyVar flexi, GenType (GenTyVar flexi) uvar)]
514 -> GenType (GenTyVar flexi) uvar
515 -> GenType (GenTyVar flexi) uvar
517 instantiateTauTy :: Eq tv =>
518 [(tv, GenType tv' u)]
522 applyTypeEnvToTy :: TyVarEnv Type -> SigmaType -> SigmaType
524 -- instantiateTauTy works only (a) on types with no ForAlls,
525 -- and when (b) all the type variables are being instantiated
526 -- In return it is more polymorphic than instantiateTy
528 instant_help ty lookup_tv deflt_tv choose_tycon
529 if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
532 go (TyVarTy tv) = case (lookup_tv tv) of
533 Nothing -> deflt_tv tv
535 go ty@(TyConTy tycon usage) = choose_tycon ty tycon usage
536 go (SynTy tycon tys ty) = SynTy tycon (map go tys) (go ty)
537 go (FunTy arg res usage) = FunTy (go arg) (go res) usage
538 go (AppTy fun arg) = AppTy (go fun) (go arg)
539 go (DictTy clas ty usage) = DictTy clas (go ty) usage
540 go (ForAllUsageTy uvar bds ty) = if_usage $
541 ForAllUsageTy uvar bds (go ty)
542 go (ForAllTy tv ty) = if_forall $
543 (if (bound_forall_tv_BAD && maybeToBool (lookup_tv tv)) then
544 trace "instantiateTy: unexpected forall hit"
546 \x->x) ForAllTy (deflt_forall_tv tv) (go ty)
548 instantiateTy tenv ty
549 = instant_help ty lookup_tv deflt_tv choose_tycon
550 if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
552 lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of
555 _ -> panic "instantiateTy:lookup_tv"
557 deflt_tv tv = TyVarTy tv
558 choose_tycon ty _ _ = ty
561 bound_forall_tv_BAD = True
562 deflt_forall_tv tv = tv
564 instantiateTauTy tenv ty
565 = instant_help ty lookup_tv deflt_tv choose_tycon
566 if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
568 lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of
571 _ -> panic "instantiateTauTy:lookup_tv"
573 deflt_tv tv = panic "instantiateTauTy"
574 choose_tycon _ tycon usage = TyConTy tycon usage
575 if_usage ty = panic "instantiateTauTy:ForAllUsageTy"
576 if_forall ty = panic "instantiateTauTy:ForAllTy"
577 bound_forall_tv_BAD = panic "instantiateTauTy:bound_forall_tv"
578 deflt_forall_tv tv = panic "instantiateTauTy:deflt_forall_tv"
580 applyTypeEnvToTy tenv ty
581 = instant_help ty lookup_tv deflt_tv choose_tycon
582 if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
584 lookup_tv = lookupTyVarEnv tenv
585 deflt_tv tv = TyVarTy tv
586 choose_tycon ty _ _ = ty
589 bound_forall_tv_BAD = False -- ToDo: probably should be True (i.e., no shadowing)
590 deflt_forall_tv tv = case (lookup_tv tv) of
592 Just (TyVarTy tv2) -> tv2
593 _ -> panic "applyTypeEnvToTy"
598 :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u'
600 instantiateUsage = panic "instantiateUsage: not implemented"
603 At present there are no unboxed non-primitive types, so
604 isUnboxedType is the same as isPrimType.
607 isPrimType, isUnboxedType :: GenType tyvar uvar -> Bool
609 isPrimType (AppTy ty _) = isPrimType ty
610 isPrimType (SynTy _ _ ty) = isPrimType ty
611 isPrimType (TyConTy tycon _) = isPrimTyCon tycon
614 isUnboxedType = isPrimType
617 This is *not* right: it is a placeholder (ToDo 96/03 WDP):
619 typePrimRep :: GenType tyvar uvar -> PrimRep
621 typePrimRep (SynTy _ _ ty) = typePrimRep ty
622 typePrimRep (TyConTy tc _) = if isPrimTyCon tc then panic "typePrimRep:PrimTyCon" else PtrRep
623 typePrimRep (AppTy ty _) = typePrimRep ty
624 typePrimRep _ = PtrRep -- the "default"
627 %************************************************************************
629 \subsection{Matching on types}
631 %************************************************************************
633 Matching is a {\em unidirectional} process, matching a type against a
634 template (which is just a type with type variables in it). The
635 matcher assumes that there are no repeated type variables in the
636 template, so that it simply returns a mapping of type variables to
637 types. It also fails on nested foralls.
639 @matchTys@ matches corresponding elements of a list of templates and
643 matchTy :: GenType t1 u1 -- Template
644 -> GenType t2 u2 -- Proposed instance of template
645 -> Maybe [(t1,GenType t2 u2)] -- Matching substitution
647 matchTys :: [GenType t1 u1] -- Templates
648 -> [GenType t2 u2] -- Proposed instance of template
649 -> Maybe [(t1,GenType t2 u2)] -- Matching substitution
651 matchTy ty1 ty2 = match [] [] ty1 ty2
652 matchTys tys1 tys2 = match' [] (zipEqual "matchTys" tys1 tys2)
655 @match@ is the main function.
658 match :: [(t1, GenType t2 u2)] -- r, the accumulating result
659 -> [(GenType t1 u1, GenType t2 u2)] -- w, the work list
660 -> GenType t1 u1 -> GenType t2 u2 -- Current match pair
661 -> Maybe [(t1, GenType t2 u2)]
663 match r w (TyVarTy v) ty = match' ((v,ty) : r) w
664 match r w (FunTy fun1 arg1 _) (FunTy fun2 arg2 _) = match r ((fun1,fun2):w) arg1 arg2
665 match r w (AppTy fun1 arg1) (AppTy fun2 arg2) = match r ((fun1,fun2):w) arg1 arg2
666 match r w (TyConTy con1 _) (TyConTy con2 _) | con1 == con2 = match' r w
667 match r w (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) | clas1 == clas2 = match r w ty1 ty2
668 match r w (SynTy _ _ ty1) ty2 = match r w ty1 ty2
669 match r w ty1 (SynTy _ _ ty2) = match r w ty1 ty2
671 -- With type synonyms, we have to be careful for the exact
672 -- same reasons as in the unifier. Please see the
673 -- considerable commentary there before changing anything
677 match _ _ _ _ = Nothing
680 match' r ((ty1,ty2):w) = match r w ty1 ty2
683 %************************************************************************
685 \subsection{Equality on types}
687 %************************************************************************
689 The functions eqSimpleTy and eqSimpleTheta are polymorphic in the types t
690 and u, but ONLY WORK FOR SIMPLE TYPES (ie. they panic if they see
691 dictionaries or polymorphic types). The function eqTy has a more
692 specific type, but does the `right thing' for all types.
695 eqSimpleTheta :: (Eq t,Eq u) =>
696 [(Class,GenType t u)] -> [(Class,GenType t u)] -> Bool
698 eqSimpleTheta [] [] = True
699 eqSimpleTheta ((c1,t1):th1) ((c2,t2):th2) =
700 c1==c2 && t1 `eqSimpleTy` t2 && th1 `eqSimpleTheta` th2
701 eqSimpleTheta other1 other2 = False
705 eqSimpleTy :: (Eq t,Eq u) => GenType t u -> GenType t u -> Bool
707 (TyVarTy tv1) `eqSimpleTy` (TyVarTy tv2) =
709 (AppTy f1 a1) `eqSimpleTy` (AppTy f2 a2) =
710 f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2
711 (TyConTy tc1 u1) `eqSimpleTy` (TyConTy tc2 u2) =
712 tc1 == tc2 --ToDo: later: && u1 == u2
714 (FunTy f1 a1 u1) `eqSimpleTy` (FunTy f2 a2 u2) =
715 f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 && u1 == u2
716 (FunTy f1 a1 u1) `eqSimpleTy` t2 =
717 -- Expand t1 just in case t2 matches that version
718 (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) `eqSimpleTy` t2
719 t1 `eqSimpleTy` (FunTy f2 a2 u2) =
720 -- Expand t2 just in case t1 matches that version
721 t1 `eqSimpleTy` (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
723 (SynTy tc1 ts1 t1) `eqSimpleTy` (SynTy tc2 ts2 t2) =
724 (tc1 == tc2 && and (zipWith eqSimpleTy ts1 ts2) && length ts1 == length ts2)
725 || t1 `eqSimpleTy` t2
726 (SynTy _ _ t1) `eqSimpleTy` t2 =
727 t1 `eqSimpleTy` t2 -- Expand the abbrevation and try again
728 t1 `eqSimpleTy` (SynTy _ _ t2) =
729 t1 `eqSimpleTy` t2 -- Expand the abbrevation and try again
731 (DictTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got DictTy"
732 _ `eqSimpleTy` (DictTy _ _ _) = panic "eqSimpleTy: got DictTy"
734 (ForAllTy _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllTy"
735 _ `eqSimpleTy` (ForAllTy _ _) = panic "eqSimpleTy: got ForAllTy"
737 (ForAllUsageTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllUsageTy"
738 _ `eqSimpleTy` (ForAllUsageTy _ _ _) = panic "eqSimpleTy: got ForAllUsageTy"
740 _ `eqSimpleTy` _ = False
743 Types are ordered so we can sort on types in the renamer etc. DNT: Since
744 this class is also used in CoreLint and other such places, we DO expand out
745 Fun/Syn/Dict types (if necessary).
748 eqTy :: Type -> Type -> Bool
751 eq nullTyVarEnv nullUVarEnv t1 t2
753 eq tve uve (TyVarTy tv1) (TyVarTy tv2) =
755 case (lookupTyVarEnv tve tv1) of
758 eq tve uve (AppTy f1 a1) (AppTy f2 a2) =
759 eq tve uve f1 f2 && eq tve uve a1 a2
760 eq tve uve (TyConTy tc1 u1) (TyConTy tc2 u2) =
761 tc1 == tc2 -- ToDo: LATER: && eqUsage uve u1 u2
763 eq tve uve (FunTy f1 a1 u1) (FunTy f2 a2 u2) =
764 eq tve uve f1 f2 && eq tve uve a1 a2 && eqUsage uve u1 u2
765 eq tve uve (FunTy f1 a1 u1) t2 =
766 -- Expand t1 just in case t2 matches that version
767 eq tve uve (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) t2
768 eq tve uve t1 (FunTy f2 a2 u2) =
769 -- Expand t2 just in case t1 matches that version
770 eq tve uve t1 (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
772 eq tve uve (DictTy c1 t1 u1) (DictTy c2 t2 u2)
774 = eq tve uve t1 t2 && eqUsage uve u1 u2
775 -- NB we use a guard for c1==c2 so that if they aren't equal we
776 -- fall through into expanding the type. Why? Because brain-dead
777 -- people might write
778 -- class Foo a => Baz a where {}
779 -- and that means that a Foo dictionary and a Baz dictionary are identical
780 -- Sigh. Let's hope we don't spend too much time in here!
782 eq tve uve t1@(DictTy _ _ _) t2 =
783 eq tve uve (expandTy t1) t2 -- Expand the dictionary and try again
784 eq tve uve t1 t2@(DictTy _ _ _) =
785 eq tve uve t1 (expandTy t2) -- Expand the dictionary and try again
787 eq tve uve (SynTy tc1 ts1 t1) (SynTy tc2 ts2 t2) =
788 (tc1 == tc2 && and (zipWith (eq tve uve) ts1 ts2) && length ts1 == length ts2)
790 eq tve uve (SynTy _ _ t1) t2 =
791 eq tve uve t1 t2 -- Expand the abbrevation and try again
792 eq tve uve t1 (SynTy _ _ t2) =
793 eq tve uve t1 t2 -- Expand the abbrevation and try again
795 eq tve uve (ForAllTy tv1 t1) (ForAllTy tv2 t2) =
796 eq (addOneToTyVarEnv tve tv1 tv2) uve t1 t2
797 eq tve uve (ForAllUsageTy u1 b1 t1) (ForAllUsageTy u2 b2 t2) =
798 eqBounds uve b1 b2 && eq tve (addOneToUVarEnv uve u1 u2) t1 t2
802 eqBounds uve [] [] = True
803 eqBounds uve (u1:b1) (u2:b2) = eqUVar uve u1 u2 && eqBounds uve b1 b2
804 eqBounds uve _ _ = False