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, pprTrace{-ToDo:rm-}, pprPanic{-ToDo:rm-},
76 -- PprType --(pprType )
87 type Type = GenType TyVar UVar -- Used after typechecker
89 data GenType tyvar uvar -- Parameterised over type and usage variables
96 | TyConTy -- Constants of a specified kind
97 TyCon -- Must *not* be a SynTyCon
98 (GenUsage uvar) -- Usage gives uvar of the full application,
99 -- iff the full application is of kind Type
100 -- c.f. the Usage field in TyVars
102 | SynTy -- Synonyms must be saturated, and contain their expansion
103 TyCon -- Must be a SynTyCon
105 (GenType tyvar uvar) -- Expansion!
109 (GenType tyvar uvar) -- TypeKind
112 uvar -- Quantify over this
113 [uvar] -- Bounds; the quantified var must be
114 -- less than or equal to all these
117 -- Two special cases that save a *lot* of administrative
120 | FunTy -- BoxedTypeKind
121 (GenType tyvar uvar) -- Both args are of TypeKind
127 (GenType tyvar uvar) -- Arg has kind TypeKind
134 type ThetaType = [(Class, Type)]
135 type SigmaType = Type
141 Removes just the top level of any abbreviations.
144 expandTy :: Type -> Type -- Restricted to Type due to Dict expansion
146 expandTy (FunTy t1 t2 u) = AppTy (AppTy (TyConTy mkFunTyCon u) t1) t2
147 expandTy (SynTy _ _ t) = expandTy t
148 expandTy (DictTy clas ty u)
149 = case all_arg_tys of
151 [] -> voidTy -- Empty dictionary represented by Void
153 [arg_ty] -> expandTy arg_ty -- just the <whatever> itself
155 -- The extra expandTy is to make sure that
156 -- the result isn't still a dict, which it might be
157 -- if the original guy was a dict with one superdict and
160 other -> ASSERT(not (null all_arg_tys))
161 foldl AppTy (TyConTy (mkTupleTyCon (length all_arg_tys)) u) all_arg_tys
164 -- Note: length of all_arg_tys can be 0 if the class is
165 -- CCallable, CReturnable (and anything else
166 -- *really weird* that the user writes).
168 (tyvar, super_classes, ops) = classSig clas
169 super_dict_tys = map mk_super_ty super_classes
170 class_op_tys = map mk_op_ty ops
171 all_arg_tys = super_dict_tys ++ class_op_tys
172 mk_super_ty sc = DictTy sc ty usageOmega
173 mk_op_ty op = instantiateTy [(tyvar,ty)] (classOpLocalType op)
178 Simple construction and analysis functions
179 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
181 mkTyVarTy :: t -> GenType t u
182 mkTyVarTys :: [t] -> [GenType t y]
184 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
186 getTyVar :: String -> GenType t u -> t
187 getTyVar msg (TyVarTy tv) = tv
188 getTyVar msg (SynTy _ _ t) = getTyVar msg t
189 getTyVar msg other = panic ("getTyVar: " ++ msg)
191 getTyVar_maybe :: GenType t u -> Maybe t
192 getTyVar_maybe (TyVarTy tv) = Just tv
193 getTyVar_maybe (SynTy _ _ t) = getTyVar_maybe t
194 getTyVar_maybe other = Nothing
196 isTyVarTy :: GenType t u -> Bool
197 isTyVarTy (TyVarTy tv) = True
198 isTyVarTy (SynTy _ _ t) = isTyVarTy t
199 isTyVarTy other = False
205 mkAppTys :: GenType t u -> [GenType t u] -> GenType t u
206 mkAppTys t ts = foldl AppTy t ts
208 splitAppTy :: GenType t u -> (GenType t u, [GenType t u])
209 splitAppTy t = go t []
211 go (AppTy t arg) ts = go t (arg:ts)
212 go (FunTy fun arg u) ts = (TyConTy mkFunTyCon u, fun:arg:ts)
213 go (SynTy _ _ t) ts = go t ts
218 -- NB mkFunTy, mkFunTys puts in Omega usages, for now at least
219 mkFunTy arg res = FunTy arg res usageOmega
221 mkFunTys :: [GenType t u] -> GenType t u -> GenType t u
222 mkFunTys ts t = foldr (\ f a -> FunTy f a usageOmega) t ts
224 -- getFunTy_maybe and splitFunTy *must* have the general type given, which
225 -- means they *can't* do the DictTy jiggery-pokery that
226 -- *is* sometimes required. Hence we also have the ExpandingDicts variants
227 -- The relationship between these
228 -- two functions is like that between eqTy and eqSimpleTy.
229 -- ToDo: NUKE when we do dicts via newtype
231 getFunTy_maybe :: GenType t u -> Maybe (GenType t u, GenType t u)
232 getFunTy_maybe (FunTy arg result _) = Just (arg,result)
233 getFunTy_maybe (AppTy (AppTy (TyConTy tycon _) arg) res)
234 | isFunTyCon tycon = Just (arg, res)
235 getFunTy_maybe (SynTy _ _ t) = getFunTy_maybe t
236 getFunTy_maybe other = Nothing
238 getFunTyExpandingDicts_maybe :: Bool -- True <=> peek inside newtype applicatons
240 -> Maybe (Type, Type)
242 getFunTyExpandingDicts_maybe peek (FunTy arg result _) = Just (arg,result)
243 getFunTyExpandingDicts_maybe peek
244 (AppTy (AppTy (TyConTy tycon _) arg) res) | isFunTyCon tycon = Just (arg, res)
245 getFunTyExpandingDicts_maybe peek (SynTy _ _ t) = getFunTyExpandingDicts_maybe peek t
246 getFunTyExpandingDicts_maybe peek ty@(DictTy _ _ _) = getFunTyExpandingDicts_maybe peek (expandTy ty)
247 getFunTyExpandingDicts_maybe peek other
248 | not peek = Nothing -- that was easy
250 = case (maybeAppTyCon other) of
253 | not (isNewTyCon tc) -> Nothing
256 [newtype_con] = tyConDataCons tc -- there must be exactly one...
257 [inside_ty] = dataConArgTys newtype_con arg_tys
259 getFunTyExpandingDicts_maybe peek inside_ty
261 splitFunTy :: GenType t u -> ([GenType t u], GenType t u)
262 splitFunTyExpandingDicts :: Type -> ([Type], Type)
263 splitFunTyExpandingDictsAndPeeking :: Type -> ([Type], Type)
265 splitFunTy t = split_fun_ty getFunTy_maybe t
266 splitFunTyExpandingDicts t = split_fun_ty (getFunTyExpandingDicts_maybe False) t
267 splitFunTyExpandingDictsAndPeeking t = split_fun_ty (getFunTyExpandingDicts_maybe True) t
269 split_fun_ty get t = go t []
271 go t ts = case (get t) of
272 Just (arg,res) -> go res (arg:ts)
273 Nothing -> (reverse ts, t)
277 -- NB applyTyCon puts in usageOmega, for now at least
279 = ASSERT(not (isSynTyCon tycon))
280 TyConTy tycon usageOmega
282 applyTyCon :: TyCon -> [GenType t u] -> GenType t u
284 = ASSERT (not (isSynTyCon tycon))
285 --(if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $
286 foldl AppTy (TyConTy tycon usageOmega) tys
288 getTyCon_maybe :: GenType t u -> Maybe TyCon
289 --getTyConExpandingDicts_maybe :: Type -> Maybe TyCon
291 getTyCon_maybe (TyConTy tycon _) = Just tycon
292 getTyCon_maybe (SynTy _ _ t) = getTyCon_maybe t
293 getTyCon_maybe other_ty = Nothing
295 --getTyConExpandingDicts_maybe (TyConTy tycon _) = Just tycon
296 --getTyConExpandingDicts_maybe (SynTy _ _ t) = getTyConExpandingDicts_maybe t
297 --getTyConExpandingDicts_maybe ty@(DictTy _ _ _) = getTyConExpandingDicts_maybe (expandTy ty)
298 --getTyConExpandingDicts_maybe other_ty = Nothing
302 mkSynTy syn_tycon tys
303 = ASSERT(isSynTyCon syn_tycon)
304 SynTy syn_tycon tys (instantiateTauTy (zipEqual "mkSynTy" tyvars tys) body)
306 (tyvars, body) = getSynTyConDefn syn_tycon
312 isTauTy :: GenType t u -> Bool
313 isTauTy (TyVarTy v) = True
314 isTauTy (TyConTy _ _) = True
315 isTauTy (AppTy a b) = isTauTy a && isTauTy b
316 isTauTy (FunTy a b _) = isTauTy a && isTauTy b
317 isTauTy (SynTy _ _ ty) = isTauTy ty
318 isTauTy other = False
323 NB mkRhoTy and mkDictTy put in usageOmega, for now at least
326 mkDictTy :: Class -> GenType t u -> GenType t u
327 mkDictTy clas ty = DictTy clas ty usageOmega
329 mkRhoTy :: [(Class, GenType t u)] -> GenType t u -> GenType t u
331 foldr (\(c,t) r -> FunTy (DictTy c t usageOmega) r usageOmega) ty theta
333 splitRhoTy :: GenType t u -> ([(Class,GenType t u)], GenType t u)
337 go (FunTy (DictTy c t _) r _) ts = go r ((c,t):ts)
338 go (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts
341 go (SynTy _ _ t) ts = go t ts
342 go t ts = (reverse ts, t)
345 mkTheta :: [Type] -> ThetaType
346 -- recover a ThetaType from the types of some dictionaries
350 cvt (DictTy clas ty _) = (clas, ty)
351 cvt other = panic "Type.mkTheta" -- pprPanic "mkTheta:" (pprType PprDebug other)
353 isDictTy (DictTy _ _ _) = True
354 isDictTy (SynTy _ _ t) = isDictTy t
362 mkForAllTy = ForAllTy
364 mkForAllTys :: [t] -> GenType t u -> GenType t u
365 mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
367 getForAllTy_maybe :: GenType t u -> Maybe (t,GenType t u)
368 getForAllTy_maybe (SynTy _ _ t) = getForAllTy_maybe t
369 getForAllTy_maybe (ForAllTy tyvar t) = Just(tyvar,t)
370 getForAllTy_maybe _ = Nothing
372 getForAllTyExpandingDicts_maybe :: Type -> Maybe (TyVar, Type)
373 getForAllTyExpandingDicts_maybe (SynTy _ _ t) = getForAllTyExpandingDicts_maybe t
374 getForAllTyExpandingDicts_maybe (ForAllTy tyvar t) = Just(tyvar,t)
375 getForAllTyExpandingDicts_maybe ty@(DictTy _ _ _) = getForAllTyExpandingDicts_maybe (expandTy ty)
376 getForAllTyExpandingDicts_maybe _ = Nothing
378 splitForAllTy :: GenType t u-> ([t], GenType t u)
379 splitForAllTy t = go t []
381 go (ForAllTy tv t) tvs = go t (tv:tvs)
382 go (SynTy _ _ t) tvs = go t tvs
383 go t tvs = (reverse tvs, t)
387 mkForAllUsageTy :: u -> [u] -> GenType t u -> GenType t u
388 mkForAllUsageTy = ForAllUsageTy
390 getForAllUsageTy :: GenType t u -> Maybe (u,[u],GenType t u)
391 getForAllUsageTy (ForAllUsageTy uvar bounds t) = Just(uvar,bounds,t)
392 getForAllUsageTy (SynTy _ _ t) = getForAllUsageTy t
393 getForAllUsageTy _ = Nothing
396 Applied tycons (includes FunTyCons)
397 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
400 :: GenType tyvar uvar
401 -> Maybe (TyCon, -- the type constructor
402 [GenType tyvar uvar]) -- types to which it is applied
405 = case (getTyCon_maybe app_ty) of
407 Just tycon -> Just (tycon, arg_tys)
409 (app_ty, arg_tys) = splitAppTy ty
413 :: GenType tyvar uvar
414 -> (TyCon, -- the type constructor
415 [GenType tyvar uvar]) -- types to which it is applied
418 = case maybeAppTyCon ty of
421 Nothing -> panic "Type.getAppTyCon" -- (ppr PprShowAll ty)
425 Applied data tycons (give back constrs)
426 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
429 :: GenType (GenTyVar any) uvar
430 -> Maybe (TyCon, -- the type constructor
431 [GenType (GenTyVar any) uvar], -- types to which it is applied
432 [Id]) -- its family of data-constructors
433 maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts
434 :: Type -> Maybe (TyCon, [Type], [Id])
436 maybeAppDataTyCon ty = maybe_app_data_tycon (\x->x) ty
437 maybeAppDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty
438 maybeAppSpecDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty
441 maybe_app_data_tycon expand ty
443 expanded_ty = expand ty
444 (app_ty, arg_tys) = splitAppTy expanded_ty
446 case (getTyCon_maybe app_ty) of
447 Just tycon | --pprTrace "maybe_app:" (ppCat [ppr PprDebug (isDataTyCon tycon), ppr PprDebug (notArrowKind (typeKind expanded_ty))]) $
449 notArrowKind (typeKind expanded_ty)
450 -- Must be saturated for ty to be a data type
451 -> Just (tycon, arg_tys, tyConDataCons tycon)
455 getAppDataTyCon, getAppSpecDataTyCon
456 :: GenType (GenTyVar any) uvar
457 -> (TyCon, -- the type constructor
458 [GenType (GenTyVar any) uvar], -- types to which it is applied
459 [Id]) -- its family of data-constructors
460 getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts
461 :: Type -> (TyCon, [Type], [Id])
463 getAppDataTyCon ty = get_app_data_tycon maybeAppDataTyCon ty
464 getAppDataTyConExpandingDicts ty = --pprTrace "getAppDataTyConEx...:" (pprType PprDebug ty) $
465 get_app_data_tycon maybeAppDataTyConExpandingDicts ty
467 -- these should work like the UniTyFuns.getUniDataSpecTyCon* things of old (ToDo)
468 getAppSpecDataTyCon = getAppDataTyCon
469 getAppSpecDataTyConExpandingDicts = getAppDataTyConExpandingDicts
471 get_app_data_tycon maybe ty
475 Nothing -> panic "Type.getAppDataTyCon" -- (pprGenType PprShowAll ty)
479 maybeBoxedPrimType :: Type -> Maybe (Id, Type)
481 maybeBoxedPrimType ty
482 = case (maybeAppDataTyCon ty) of -- Data type,
483 Just (tycon, tys_applied, [data_con]) -- with exactly one constructor
484 -> case (dataConArgTys data_con tys_applied) of
485 [data_con_arg_ty] -- Applied to exactly one type,
486 | isPrimType data_con_arg_ty -- which is primitive
487 -> Just (data_con, data_con_arg_ty)
488 other_cases -> Nothing
489 other_cases -> Nothing
493 splitSigmaTy :: GenType t u -> ([t], [(Class,GenType t u)], GenType t u)
497 (tyvars,rho) = splitForAllTy ty
498 (theta,tau) = splitRhoTy rho
500 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
504 Finding the kind of a type
505 ~~~~~~~~~~~~~~~~~~~~~~~~~~
507 typeKind :: GenType (GenTyVar any) u -> Kind
509 typeKind (TyVarTy tyvar) = tyVarKind tyvar
510 typeKind (TyConTy tycon usage) = tyConKind tycon
511 typeKind (SynTy _ _ ty) = typeKind ty
512 typeKind (FunTy fun arg _) = mkBoxedTypeKind
513 typeKind (DictTy clas arg _) = mkBoxedTypeKind
514 typeKind (AppTy fun arg) = resultKind (typeKind fun)
515 typeKind (ForAllTy _ _) = mkBoxedTypeKind
516 typeKind (ForAllUsageTy _ _ _) = mkBoxedTypeKind
520 Free variables of a type
521 ~~~~~~~~~~~~~~~~~~~~~~~~
523 tyVarsOfType :: GenType (GenTyVar flexi) uvar -> GenTyVarSet flexi
525 tyVarsOfType (TyVarTy tv) = unitTyVarSet tv
526 tyVarsOfType (TyConTy tycon usage) = emptyTyVarSet
527 tyVarsOfType (SynTy _ tys ty) = tyVarsOfTypes tys
528 tyVarsOfType (FunTy arg res _) = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res
529 tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg
530 tyVarsOfType (DictTy clas ty _) = tyVarsOfType ty
531 tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar
532 tyVarsOfType (ForAllUsageTy _ _ ty) = tyVarsOfType ty
534 tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi
535 tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
542 applyTy :: GenType (GenTyVar flexi) uvar
543 -> GenType (GenTyVar flexi) uvar
544 -> GenType (GenTyVar flexi) uvar
546 applyTy (SynTy _ _ fun) arg = applyTy fun arg
547 applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty
548 applyTy other arg = panic "applyTy"
552 instantiateTy :: [(GenTyVar flexi, GenType (GenTyVar flexi) uvar)]
553 -> GenType (GenTyVar flexi) uvar
554 -> GenType (GenTyVar flexi) uvar
556 instantiateTauTy :: Eq tv =>
557 [(tv, GenType tv' u)]
561 applyTypeEnvToTy :: TyVarEnv Type -> SigmaType -> SigmaType
563 -- instantiateTauTy works only (a) on types with no ForAlls,
564 -- and when (b) all the type variables are being instantiated
565 -- In return it is more polymorphic than instantiateTy
567 instant_help ty lookup_tv deflt_tv choose_tycon
568 if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
571 go (TyVarTy tv) = case (lookup_tv tv) of
572 Nothing -> deflt_tv tv
574 go ty@(TyConTy tycon usage) = choose_tycon ty tycon usage
575 go (SynTy tycon tys ty) = SynTy tycon (map go tys) (go ty)
576 go (FunTy arg res usage) = FunTy (go arg) (go res) usage
577 go (AppTy fun arg) = AppTy (go fun) (go arg)
578 go (DictTy clas ty usage) = DictTy clas (go ty) usage
579 go (ForAllUsageTy uvar bds ty) = if_usage $
580 ForAllUsageTy uvar bds (go ty)
581 go (ForAllTy tv ty) = if_forall $
582 (if (bound_forall_tv_BAD && maybeToBool (lookup_tv tv)) then
583 trace "instantiateTy: unexpected forall hit"
585 \x->x) ForAllTy (deflt_forall_tv tv) (go ty)
587 instantiateTy tenv ty
588 = instant_help ty lookup_tv deflt_tv choose_tycon
589 if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
591 lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of
594 _ -> panic "instantiateTy:lookup_tv"
596 deflt_tv tv = TyVarTy tv
597 choose_tycon ty _ _ = ty
600 bound_forall_tv_BAD = True
601 deflt_forall_tv tv = tv
603 instantiateTauTy tenv ty
604 = instant_help ty lookup_tv deflt_tv choose_tycon
605 if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
607 lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of
610 _ -> panic "instantiateTauTy:lookup_tv"
612 deflt_tv tv = panic "instantiateTauTy"
613 choose_tycon _ tycon usage = TyConTy tycon usage
614 if_usage ty = panic "instantiateTauTy:ForAllUsageTy"
615 if_forall ty = panic "instantiateTauTy:ForAllTy"
616 bound_forall_tv_BAD = panic "instantiateTauTy:bound_forall_tv"
617 deflt_forall_tv tv = panic "instantiateTauTy:deflt_forall_tv"
620 -- applyTypeEnv applies a type environment to a type.
621 -- It can handle shadowing; for example:
622 -- f = /\ t1 t2 -> \ d ->
623 -- letrec f' = /\ t1 -> \x -> ...(f' t1 x')...
625 -- Here, when we clone t1 to t1', say, we'll come across shadowing
626 -- when applying the clone environment to the type of f'.
628 -- As a sanity check, we should also check that name capture
629 -- doesn't occur, but that means keeping track of the free variables of the
630 -- range of the TyVarEnv, which I don't do just yet.
632 -- We don't use instant_help because we need to carry in the environment
634 applyTypeEnvToTy tenv ty
637 go tenv ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of
640 go tenv ty@(TyConTy tycon usage) = ty
641 go tenv (SynTy tycon tys ty) = SynTy tycon (map (go tenv) tys) (go tenv ty)
642 go tenv (FunTy arg res usage) = FunTy (go tenv arg) (go tenv res) usage
643 go tenv (AppTy fun arg) = AppTy (go tenv fun) (go tenv arg)
644 go tenv (DictTy clas ty usage) = DictTy clas (go tenv ty) usage
645 go tenv (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go tenv ty)
646 go tenv (ForAllTy tv ty) = ForAllTy tv (go tenv' ty)
648 tenv' = case lookupTyVarEnv tenv tv of
650 Just _ -> delFromTyVarEnv tenv tv
655 :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u'
657 instantiateUsage = panic "instantiateUsage: not implemented"
661 At present there are no unboxed non-primitive types, so
662 isUnboxedType is the same as isPrimType.
664 We're a bit cavalier about finding out whether something is
665 primitive/unboxed or not. Rather than deal with the type
666 arguemnts we just zoom into the function part of the type.
667 That is, given (T a) we just recurse into the "T" part,
671 isPrimType, isUnboxedType :: Type -> Bool
673 isPrimType (AppTy ty _) = isPrimType ty
674 isPrimType (SynTy _ _ ty) = isPrimType ty
675 isPrimType (TyConTy tycon _) = case maybeNewTyCon tycon of
676 Just (tyvars, ty) -> isPrimType ty
677 Nothing -> isPrimTyCon tycon
681 isUnboxedType = isPrimType
684 This is *not* right: it is a placeholder (ToDo 96/03 WDP):
686 typePrimRep :: Type -> PrimRep
688 typePrimRep (SynTy _ _ ty) = typePrimRep ty
689 typePrimRep (AppTy ty _) = typePrimRep ty
690 typePrimRep (TyConTy tc _)
691 | isPrimTyCon tc = case (assocMaybe tc_primrep_list (uniqueOf tc)) of
693 Nothing -> panic "Type.typePrimRep" -- pprPanic "typePrimRep:" (pprTyCon PprDebug tc)
695 | otherwise = case maybeNewTyCon tc of
696 Just (tyvars, ty) | isPrimType ty -> typePrimRep ty
697 _ -> PtrRep -- Default
699 typePrimRep _ = PtrRep -- the "default"
702 = [(addrPrimTyConKey, AddrRep)
703 ,(arrayPrimTyConKey, ArrayRep)
704 ,(byteArrayPrimTyConKey, ByteArrayRep)
705 ,(charPrimTyConKey, CharRep)
706 ,(doublePrimTyConKey, DoubleRep)
707 ,(floatPrimTyConKey, FloatRep)
708 ,(foreignObjPrimTyConKey, ForeignObjRep)
709 ,(intPrimTyConKey, IntRep)
710 ,(mutableArrayPrimTyConKey, ArrayRep)
711 ,(mutableByteArrayPrimTyConKey, ByteArrayRep)
712 ,(stablePtrPrimTyConKey, StablePtrRep)
713 ,(statePrimTyConKey, VoidRep)
714 ,(synchVarPrimTyConKey, PtrRep)
715 ,(voidTyConKey, VoidRep)
716 ,(wordPrimTyConKey, WordRep)
720 %************************************************************************
722 \subsection{Matching on types}
724 %************************************************************************
726 Matching is a {\em unidirectional} process, matching a type against a
727 template (which is just a type with type variables in it). The
728 matcher assumes that there are no repeated type variables in the
729 template, so that it simply returns a mapping of type variables to
730 types. It also fails on nested foralls.
732 @matchTys@ matches corresponding elements of a list of templates and
736 matchTy :: GenType t1 u1 -- Template
737 -> GenType t2 u2 -- Proposed instance of template
738 -> Maybe [(t1,GenType t2 u2)] -- Matching substitution
740 matchTys :: [GenType t1 u1] -- Templates
741 -> [GenType t2 u2] -- Proposed instance of template
742 -> Maybe [(t1,GenType t2 u2)] -- Matching substitution
744 matchTy ty1 ty2 = match [] [] ty1 ty2
745 matchTys tys1 tys2 = match' [] (zipEqual "matchTys" tys1 tys2)
748 @match@ is the main function.
751 match :: [(t1, GenType t2 u2)] -- r, the accumulating result
752 -> [(GenType t1 u1, GenType t2 u2)] -- w, the work list
753 -> GenType t1 u1 -> GenType t2 u2 -- Current match pair
754 -> Maybe [(t1, GenType t2 u2)]
756 match r w (TyVarTy v) ty = match' ((v,ty) : r) w
757 match r w (FunTy fun1 arg1 _) (FunTy fun2 arg2 _) = match r ((fun1,fun2):w) arg1 arg2
758 match r w (AppTy fun1 arg1) (AppTy fun2 arg2) = match r ((fun1,fun2):w) arg1 arg2
759 match r w (TyConTy con1 _) (TyConTy con2 _) | con1 == con2 = match' r w
760 match r w (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) | clas1 == clas2 = match r w ty1 ty2
761 match r w (SynTy _ _ ty1) ty2 = match r w ty1 ty2
762 match r w ty1 (SynTy _ _ ty2) = match r w ty1 ty2
764 -- With type synonyms, we have to be careful for the exact
765 -- same reasons as in the unifier. Please see the
766 -- considerable commentary there before changing anything
770 match _ _ _ _ = Nothing
773 match' r ((ty1,ty2):w) = match r w ty1 ty2
776 %************************************************************************
778 \subsection{Equality on types}
780 %************************************************************************
782 The functions eqSimpleTy and eqSimpleTheta are polymorphic in the types t
783 and u, but ONLY WORK FOR SIMPLE TYPES (ie. they panic if they see
784 dictionaries or polymorphic types). The function eqTy has a more
785 specific type, but does the `right thing' for all types.
788 eqSimpleTheta :: (Eq t,Eq u) =>
789 [(Class,GenType t u)] -> [(Class,GenType t u)] -> Bool
791 eqSimpleTheta [] [] = True
792 eqSimpleTheta ((c1,t1):th1) ((c2,t2):th2) =
793 c1==c2 && t1 `eqSimpleTy` t2 && th1 `eqSimpleTheta` th2
794 eqSimpleTheta other1 other2 = False
798 eqSimpleTy :: (Eq t,Eq u) => GenType t u -> GenType t u -> Bool
800 (TyVarTy tv1) `eqSimpleTy` (TyVarTy tv2) =
802 (AppTy f1 a1) `eqSimpleTy` (AppTy f2 a2) =
803 f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2
804 (TyConTy tc1 u1) `eqSimpleTy` (TyConTy tc2 u2) =
805 tc1 == tc2 --ToDo: later: && u1 == u2
807 (FunTy f1 a1 u1) `eqSimpleTy` (FunTy f2 a2 u2) =
808 f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 && u1 == u2
809 (FunTy f1 a1 u1) `eqSimpleTy` t2 =
810 -- Expand t1 just in case t2 matches that version
811 (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) `eqSimpleTy` t2
812 t1 `eqSimpleTy` (FunTy f2 a2 u2) =
813 -- Expand t2 just in case t1 matches that version
814 t1 `eqSimpleTy` (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
816 (SynTy tc1 ts1 t1) `eqSimpleTy` (SynTy tc2 ts2 t2) =
817 (tc1 == tc2 && and (zipWith eqSimpleTy ts1 ts2) && length ts1 == length ts2)
818 || t1 `eqSimpleTy` t2
819 (SynTy _ _ t1) `eqSimpleTy` t2 =
820 t1 `eqSimpleTy` t2 -- Expand the abbrevation and try again
821 t1 `eqSimpleTy` (SynTy _ _ t2) =
822 t1 `eqSimpleTy` t2 -- Expand the abbrevation and try again
824 (DictTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got DictTy"
825 _ `eqSimpleTy` (DictTy _ _ _) = panic "eqSimpleTy: got DictTy"
827 (ForAllTy _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllTy"
828 _ `eqSimpleTy` (ForAllTy _ _) = panic "eqSimpleTy: got ForAllTy"
830 (ForAllUsageTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllUsageTy"
831 _ `eqSimpleTy` (ForAllUsageTy _ _ _) = panic "eqSimpleTy: got ForAllUsageTy"
833 _ `eqSimpleTy` _ = False
836 Types are ordered so we can sort on types in the renamer etc. DNT: Since
837 this class is also used in CoreLint and other such places, we DO expand out
838 Fun/Syn/Dict types (if necessary).
841 eqTy :: Type -> Type -> Bool
844 eq nullTyVarEnv nullUVarEnv t1 t2
846 eq tve uve (TyVarTy tv1) (TyVarTy tv2) =
848 case (lookupTyVarEnv tve tv1) of
851 eq tve uve (AppTy f1 a1) (AppTy f2 a2) =
852 eq tve uve f1 f2 && eq tve uve a1 a2
853 eq tve uve (TyConTy tc1 u1) (TyConTy tc2 u2) =
854 tc1 == tc2 -- ToDo: LATER: && eqUsage uve u1 u2
856 eq tve uve (FunTy f1 a1 u1) (FunTy f2 a2 u2) =
857 eq tve uve f1 f2 && eq tve uve a1 a2 && eqUsage uve u1 u2
858 eq tve uve (FunTy f1 a1 u1) t2 =
859 -- Expand t1 just in case t2 matches that version
860 eq tve uve (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) t2
861 eq tve uve t1 (FunTy f2 a2 u2) =
862 -- Expand t2 just in case t1 matches that version
863 eq tve uve t1 (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
865 eq tve uve (DictTy c1 t1 u1) (DictTy c2 t2 u2)
867 = eq tve uve t1 t2 && eqUsage uve u1 u2
868 -- NB we use a guard for c1==c2 so that if they aren't equal we
869 -- fall through into expanding the type. Why? Because brain-dead
870 -- people might write
871 -- class Foo a => Baz a where {}
872 -- and that means that a Foo dictionary and a Baz dictionary are identical
873 -- Sigh. Let's hope we don't spend too much time in here!
875 eq tve uve t1@(DictTy _ _ _) t2 =
876 eq tve uve (expandTy t1) t2 -- Expand the dictionary and try again
877 eq tve uve t1 t2@(DictTy _ _ _) =
878 eq tve uve t1 (expandTy t2) -- Expand the dictionary and try again
880 eq tve uve (SynTy tc1 ts1 t1) (SynTy tc2 ts2 t2) =
881 (tc1 == tc2 && and (zipWith (eq tve uve) ts1 ts2) && length ts1 == length ts2)
883 eq tve uve (SynTy _ _ t1) t2 =
884 eq tve uve t1 t2 -- Expand the abbrevation and try again
885 eq tve uve t1 (SynTy _ _ t2) =
886 eq tve uve t1 t2 -- Expand the abbrevation and try again
888 eq tve uve (ForAllTy tv1 t1) (ForAllTy tv2 t2) =
889 eq (addOneToTyVarEnv tve tv1 tv2) uve t1 t2
890 eq tve uve (ForAllUsageTy u1 b1 t1) (ForAllUsageTy u2 b2 t2) =
891 eqBounds uve b1 b2 && eq tve (addOneToUVarEnv uve u1 u2) t1 t2
895 eqBounds uve [] [] = True
896 eqBounds uve (u1:b1) (u2:b2) = eqUVar uve u1 u2 && eqBounds uve b1 b2
897 eqBounds uve _ _ = False