X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=4ae211d7c47fe9d8b48a5be891398adb97f509c9;hb=12899612693163154531da3285ec99c1c8ca2226;hp=bebf0f5c83d57388e799602660a9b4b8832f8db1;hpb=26741ec416bae2c502ef00a2ba0e79050a32cb67;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index bebf0f5..4ae211d 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -21,7 +21,7 @@ module Type ( SYN_IE(RhoType), SYN_IE(SigmaType), SYN_IE(ThetaType), mkDictTy, - mkRhoTy, splitRhoTy, mkTheta, + mkRhoTy, splitRhoTy, mkTheta, isDictTy, mkSigmaTy, splitSigmaTy, maybeAppTyCon, getAppTyCon, @@ -41,9 +41,9 @@ module Type ( ) where IMP_Ubiq() -IMPORT_DELOOPER(IdLoop) -- for paranoia checking -IMPORT_DELOOPER(TyLoop) -- for paranoia checking -IMPORT_DELOOPER(PrelLoop) -- for paranoia checking +--IMPORT_DELOOPER(IdLoop) -- for paranoia checking +IMPORT_DELOOPER(TyLoop) +--IMPORT_DELOOPER(PrelLoop) -- for paranoia checking -- friends: import Class ( classSig, classOpLocalType, GenClass{-instances-} ) @@ -53,7 +53,7 @@ import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, tyConKind, tyConDataCons, getSynTyConDefn, TyCon ) import TyVar ( tyVarKind, GenTyVar{-instances-}, SYN_IE(GenTyVarSet), emptyTyVarSet, unionTyVarSets, minusTyVarSet, - unitTyVarSet, nullTyVarEnv, lookupTyVarEnv, + unitTyVarSet, nullTyVarEnv, lookupTyVarEnv, delFromTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv), SYN_IE(TyVar) ) import Usage ( usageOmega, GenUsage, SYN_IE(Usage), SYN_IE(UVar), SYN_IE(UVarEnv), nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar, @@ -72,8 +72,8 @@ import {-mumble-} Pretty import {-mumble-} PprStyle -import {-mumble-} - PprType --(pprType ) +--import {-mumble-} +-- PprType --(pprType ) import {-mumble-} UniqFM (ufmToList ) import {-mumble-} @@ -281,8 +281,8 @@ mkTyConTy tycon applyTyCon :: TyCon -> [GenType t u] -> GenType t u applyTyCon tycon tys - = --ASSERT (not (isSynTyCon tycon)) - (if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $ + = ASSERT (not (isSynTyCon tycon)) + --(if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $ foldl AppTy (TyConTy tycon usageOmega) tys getTyCon_maybe :: GenType t u -> Maybe TyCon @@ -348,7 +348,11 @@ mkTheta dict_tys = map cvt dict_tys where cvt (DictTy clas ty _) = (clas, ty) - cvt other = pprPanic "mkTheta:" (pprType PprDebug other) + cvt other = panic "Type.mkTheta" -- pprPanic "mkTheta:" (pprType PprDebug other) + +isDictTy (DictTy _ _ _) = True +isDictTy (SynTy _ _ t) = isDictTy t +isDictTy _ = False \end{code} @@ -612,20 +616,38 @@ instantiateTauTy tenv ty bound_forall_tv_BAD = panic "instantiateTauTy:bound_forall_tv" deflt_forall_tv tv = panic "instantiateTauTy:deflt_forall_tv" + +-- applyTypeEnv applies a type environment to a type. +-- It can handle shadowing; for example: +-- f = /\ t1 t2 -> \ d -> +-- letrec f' = /\ t1 -> \x -> ...(f' t1 x')... +-- in f' t1 +-- Here, when we clone t1 to t1', say, we'll come across shadowing +-- when applying the clone environment to the type of f'. +-- +-- As a sanity check, we should also check that name capture +-- doesn't occur, but that means keeping track of the free variables of the +-- range of the TyVarEnv, which I don't do just yet. +-- +-- We don't use instant_help because we need to carry in the environment + applyTypeEnvToTy tenv ty - = instant_help ty lookup_tv deflt_tv choose_tycon - if_usage if_forall bound_forall_tv_BAD deflt_forall_tv + = go tenv ty where - lookup_tv = lookupTyVarEnv tenv - deflt_tv tv = TyVarTy tv - choose_tycon ty _ _ = ty - if_usage ty = ty - if_forall ty = ty - bound_forall_tv_BAD = False -- ToDo: probably should be True (i.e., no shadowing) - deflt_forall_tv tv = case (lookup_tv tv) of - Nothing -> tv - Just (TyVarTy tv2) -> tv2 - _ -> pprPanic "applyTypeEnvToTy:" (ppAbove (ppr PprShowAll tv) (ppr PprShowAll ty)) + go tenv ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of + Nothing -> ty + Just ty -> ty + go tenv ty@(TyConTy tycon usage) = ty + go tenv (SynTy tycon tys ty) = SynTy tycon (map (go tenv) tys) (go tenv ty) + go tenv (FunTy arg res usage) = FunTy (go tenv arg) (go tenv res) usage + go tenv (AppTy fun arg) = AppTy (go tenv fun) (go tenv arg) + go tenv (DictTy clas ty usage) = DictTy clas (go tenv ty) usage + go tenv (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go tenv ty) + go tenv (ForAllTy tv ty) = ForAllTy tv (go tenv' ty) + where + tenv' = case lookupTyVarEnv tenv tv of + Nothing -> tenv + Just _ -> delFromTyVarEnv tenv tv \end{code} \begin{code} @@ -668,7 +690,7 @@ typePrimRep (AppTy ty _) = typePrimRep ty typePrimRep (TyConTy tc _) | isPrimTyCon tc = case (assocMaybe tc_primrep_list (uniqueOf tc)) of Just xx -> xx - Nothing -> pprPanic "typePrimRep:" (pprTyCon PprDebug tc) + Nothing -> panic "Type.typePrimRep" -- pprPanic "typePrimRep:" (pprTyCon PprDebug tc) | otherwise = case maybeNewTyCon tc of Just (tyvars, ty) | isPrimType ty -> typePrimRep ty @@ -714,30 +736,38 @@ types. matchTy :: GenType t1 u1 -- Template -> GenType t2 u2 -- Proposed instance of template -> Maybe [(t1,GenType t2 u2)] -- Matching substitution + matchTys :: [GenType t1 u1] -- Templates -> [GenType t2 u2] -- Proposed instance of template - -> Maybe [(t1,GenType t2 u2)] -- Matching substitution + -> Maybe ([(t1,GenType t2 u2)],-- Matching substitution + [GenType t2 u2]) -- Left over instance types + +matchTy ty1 ty2 = match ty1 ty2 (\s -> Just s) [] +matchTys tys1 tys2 = go [] tys1 tys2 + where + go s [] tys2 = Just (s,tys2) + go s (ty1:tys1) [] = panic "matchTys" + go s (ty1:tys1) (ty2:tys2) = match ty1 ty2 (\s' -> go s' tys1 tys2) s + -matchTy ty1 ty2 = match [] [] ty1 ty2 -matchTys tys1 tys2 = match' [] (zipEqual "matchTys" tys1 tys2) \end{code} @match@ is the main function. \begin{code} -match :: [(t1, GenType t2 u2)] -- r, the accumulating result - -> [(GenType t1 u1, GenType t2 u2)] -- w, the work list - -> GenType t1 u1 -> GenType t2 u2 -- Current match pair - -> Maybe [(t1, GenType t2 u2)] - -match r w (TyVarTy v) ty = match' ((v,ty) : r) w -match r w (FunTy fun1 arg1 _) (FunTy fun2 arg2 _) = match r ((fun1,fun2):w) arg1 arg2 -match r w (AppTy fun1 arg1) (AppTy fun2 arg2) = match r ((fun1,fun2):w) arg1 arg2 -match r w (TyConTy con1 _) (TyConTy con2 _) | con1 == con2 = match' r w -match r w (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) | clas1 == clas2 = match r w ty1 ty2 -match r w (SynTy _ _ ty1) ty2 = match r w ty1 ty2 -match r w ty1 (SynTy _ _ ty2) = match r w ty1 ty2 +match :: GenType t1 u1 -> GenType t2 u2 -- Current match pair + -> ([(t1, GenType t2 u2)] -> Maybe result) -- Continuation + -> [(t1, GenType t2 u2)] -- Current substitution + -> Maybe result + +match (TyVarTy v) ty k = \s -> k ((v,ty) : s) +match (FunTy fun1 arg1 _) (FunTy fun2 arg2 _) k = match fun1 fun2 (match arg1 arg2 k) +match (AppTy fun1 arg1) (AppTy fun2 arg2) k = match fun1 fun2 (match arg1 arg2 k) +match (TyConTy con1 _) (TyConTy con2 _) k | con1 == con2 = k +match (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) k | clas1 == clas2 = match ty1 ty2 k +match (SynTy _ _ ty1) ty2 k = match ty1 ty2 k +match ty1 (SynTy _ _ ty2) k = match ty1 ty2 k -- With type synonyms, we have to be careful for the exact -- same reasons as in the unifier. Please see the @@ -745,10 +775,7 @@ match r w ty1 (SynTy _ _ ty2) = match r w ty1 ty2 -- here! (WDP 95/05) -- Catch-all fails -match _ _ _ _ = Nothing - -match' r [] = Just r -match' r ((ty1,ty2):w) = match r w ty1 ty2 +match _ _ _ = \s -> Nothing \end{code} %************************************************************************