SYN_IE(RhoType), SYN_IE(SigmaType), SYN_IE(ThetaType),
mkDictTy,
- mkRhoTy, splitRhoTy, mkTheta,
+ mkRhoTy, splitRhoTy, mkTheta, isDictTy,
mkSigmaTy, splitSigmaTy,
maybeAppTyCon, getAppTyCon,
) 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-} )
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,
Pretty
import {-mumble-}
PprStyle
-import {-mumble-}
- PprType --(pprType )
+--import {-mumble-}
+-- PprType --(pprType )
import {-mumble-}
UniqFM (ufmToList )
import {-mumble-}
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
= 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}
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}
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
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
-- 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}
%************************************************************************
projects / ghc-hetmet.git / blobdiff