X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=b9114935c0d3e009eedd992bee2ef122e99f071a;hb=36436bc62a98f53e126ec02fe946337c4c766c3f;hp=9bad29d22dc487eb3020b64bec679c4f3165271a;hpb=837824d2ff329a0f68c1434ae6812bea3ac7ec5f;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 9bad29d..b911493 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -29,7 +29,7 @@ module Type ( mkSynTy, - repType, typePrimRep, coreView, + repType, typePrimRep, coreView, deepCoreView, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, applyTy, applyTys, isForAllTy, dropForAlls, @@ -54,23 +54,25 @@ module Type ( tidyTyVarBndr, tidyFreeTyVars, tidyOpenTyVar, tidyOpenTyVars, tidyTopType, tidyPred, + tidyKind, -- Comparison - eqType, + coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, + tcEqPred, tcCmpPred, tcEqTypeX, -- Seq seqType, seqTypes, -- Type substitutions - TvSubst(..), -- Representation visible to a few friends - TvSubstEnv, emptyTvSubst, - mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst, + TvSubstEnv, emptyTvSubstEnv, -- Representation widely visible + TvSubst(..), emptyTvSubst, -- Representation visible to a few friends + mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst, getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, - extendTvSubst, extendTvSubstList, isInScope, + extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, -- Performing substitution on types - substTy, substTys, substTyWith, substTheta, substTyVar, - deShadowTy, + substTy, substTys, substTyWith, substTheta, + substPred, substTyVar, substTyVarBndr, deShadowTy, -- Pretty-printing pprType, pprParendType, pprTyThingCategory, @@ -86,7 +88,7 @@ import TypeRep -- friends: import Kind -import Var ( Var, TyVar, tyVarKind, tyVarName, setTyVarName ) +import Var ( Var, TyVar, tyVarKind, tyVarName, setTyVarName, mkTyVar ) import VarEnv import VarSet @@ -100,10 +102,10 @@ import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon, ) -- others -import CmdLineOpts ( opt_DictsStrict ) +import StaticFlags ( opt_DictsStrict ) import SrcLoc ( noSrcLoc ) import Unique ( Uniquable(..) ) -import Util ( mapAccumL, seqList, lengthIs, snocView ) +import Util ( mapAccumL, seqList, lengthIs, snocView, thenCmp, isEqual ) import Outputable import UniqSet ( sizeUniqSet ) -- Should come via VarSet import Maybe ( isJust ) @@ -132,6 +134,17 @@ coreView (PredTy p) = Just (predTypeRep p) coreView (TyConApp tc tys) = expandNewTcApp tc tys coreView ty = Nothing +deepCoreView :: Type -> Type +-- Apply coreView recursively +deepCoreView ty + | Just ty' <- coreView ty = deepCoreView ty' +deepCoreView (TyVarTy tv) = TyVarTy tv +deepCoreView (TyConApp tc tys) = TyConApp tc (map deepCoreView tys) +deepCoreView (AppTy t1 t2) = AppTy (deepCoreView t1) (deepCoreView t2) +deepCoreView (FunTy t1 t2) = FunTy (deepCoreView t1) (deepCoreView t2) +deepCoreView (ForAllTy tv ty) = ForAllTy tv (deepCoreView ty) + -- No NoteTy, no PredTy + expandNewTcApp :: TyCon -> [Type] -> Maybe Type -- A local helper function (not exported) -- Expands *the outermoset level of* a newtype application to @@ -576,8 +589,9 @@ splitRecNewType_maybe (TyConApp tc tys) -- to *types* (of kind *) ASSERT( isRecursiveTyCon tc ) -- Guaranteed by coreView case newTyConRhs tc of - (tvs, rep_ty) -> Just (substTyWith tvs tys rep_ty) - + (tvs, rep_ty) -> ASSERT( length tvs == length tys ) + Just (substTyWith tvs tys rep_ty) + splitRecNewType_maybe other = Nothing \end{code} @@ -736,6 +750,43 @@ tidyTopType ty = tidyType emptyTidyEnv ty \end{code} +%************************************************************************ +%* * + Tidying Kinds +%* * +%************************************************************************ + +We use a grevious hack for tidying KindVars. A TidyEnv contains +a (VarEnv Var) substitution, to express the renaming; but +KindVars are not Vars. The Right Thing ultimately is to make them +into Vars (and perhaps make Kinds into Types), but I just do a hack +here: I make up a TyVar just to remember the new OccName for the +renamed KindVar + +\begin{code} +tidyKind :: TidyEnv -> Kind -> (TidyEnv, Kind) +tidyKind env@(tidy_env, subst) (KindVar kvar) + | Just tv <- lookupVarEnv_Directly subst uniq + = (env, KindVar (setKindVarOcc kvar (getOccName tv))) + | otherwise + = ((tidy', subst'), KindVar kvar') + where + uniq = kindVarUniq kvar + (tidy', occ') = tidyOccName tidy_env (kindVarOcc kvar) + kvar' = setKindVarOcc kvar occ' + fake_tv = mkTyVar tv_name (panic "tidyKind:fake tv kind") + tv_name = mkInternalName uniq occ' noSrcLoc + subst' = extendVarEnv subst fake_tv fake_tv + +tidyKind env (FunKind k1 k2) + = (env2, FunKind k1' k2') + where + (env1, k1') = tidyKind env k1 + (env2, k2') = tidyKind env1 k2 + +tidyKind env k = (env, k) -- Atomic kinds +\end{code} + %************************************************************************ %* * @@ -835,33 +886,75 @@ seqPred (IParam n ty) = n `seq` seqType ty %************************************************************************ %* * -\subsection{Equality on types} + Comparison of types + (We don't use instances so that we know where it happens) %* * %************************************************************************ -Comparison; don't use instances so that we know where it happens. -Look through newtypes but not usage types. +Two flavours: + +* tcEqType, tcCmpType do *not* look through newtypes, PredTypes +* coreEqType *does* look through them Note that eqType can respond 'False' for partial applications of newtypes. Consider newtype Parser m a = MkParser (Foogle m a) - Does Monad (Parser m) `eqType` Monad (Foogle m) - Well, yes, but eqType won't see that they are the same. I don't think this is harmful, but it's soemthing to watch out for. +First, the external interface + +\begin{code} +coreEqType :: Type -> Type -> Bool +coreEqType t1 t2 = isEqual $ cmpType (deepCoreView t1) (deepCoreView t2) + +tcEqType :: Type -> Type -> Bool +tcEqType t1 t2 = isEqual $ cmpType t1 t2 + +tcEqTypes :: [Type] -> [Type] -> Bool +tcEqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2 + +tcCmpType :: Type -> Type -> Ordering +tcCmpType t1 t2 = cmpType t1 t2 + +tcCmpTypes :: [Type] -> [Type] -> Ordering +tcCmpTypes tys1 tys2 = cmpTypes tys1 tys2 + +tcEqPred :: PredType -> PredType -> Bool +tcEqPred p1 p2 = isEqual $ cmpPred p1 p2 + +tcCmpPred :: PredType -> PredType -> Ordering +tcCmpPred p1 p2 = cmpPred p1 p2 + +tcEqTypeX :: RnEnv2 -> Type -> Type -> Bool +tcEqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2 +\end{code} + +Now here comes the real worker + \begin{code} -eqType t1 t2 = eq_ty emptyVarEnv t1 t2 +cmpType :: Type -> Type -> Ordering +cmpType t1 t2 = cmpTypeX rn_env t1 t2 + where + rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType t1 `unionVarSet` tyVarsOfType t2)) + +cmpTypes :: [Type] -> [Type] -> Ordering +cmpTypes ts1 ts2 = cmpTypesX rn_env ts1 ts2 + where + rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2)) + +cmpPred :: PredType -> PredType -> Ordering +cmpPred p1 p2 = cmpPredX rn_env p1 p2 + where + rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfPred p1 `unionVarSet` tyVarsOfPred p2)) --- Look through Notes, PredTy, newtype applications -eq_ty env t1 t2 | Just t1' <- coreView t1 = eq_ty env t1' t2 -eq_ty env t1 t2 | Just t2' <- coreView t2 = eq_ty env t1 t2' +cmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse -- NB: we *cannot* short-cut the newtype comparison thus: --- eq_ty env (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) --- | (tc1 == tc2) = (eq_tys env tys1 tys2) +-- eqTypeX env (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) +-- | (tc1 == tc2) = (eqTypeXs env tys1 tys2) -- -- Consider: -- newtype T a = MkT [a] @@ -876,21 +969,58 @@ eq_ty env t1 t2 | Just t2' <- coreView t2 = eq_ty env t1 t2' -- but we can only expand saturated newtypes, so just comparing -- T with [] won't do. --- The rest is plain sailing -eq_ty env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of - Just tv1a -> tv1a == tv2 - Nothing -> tv1 == tv2 -eq_ty env (ForAllTy tv1 t1) (ForAllTy tv2 t2) - | tv1 == tv2 = eq_ty (delVarEnv env tv1) t1 t2 - | otherwise = eq_ty (extendVarEnv env tv1 tv2) t1 t2 -eq_ty env (AppTy s1 t1) (AppTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2) -eq_ty env (FunTy s1 t1) (FunTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2) -eq_ty env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 == tc2) && (eq_tys env tys1 tys2) -eq_ty env t1 t2 = False - -eq_tys env [] [] = True -eq_tys env (t1:tys1) (t2:tys2) = (eq_ty env t1 t2) && (eq_tys env tys1 tys2) -eq_tys env tys1 tys2 = False +cmpTypeX env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 `compare` rnOccR env tv2 +cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTypeX (rnBndr2 env tv1 tv2) t1 t2 +cmpTypeX env (AppTy s1 t1) (AppTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2 +cmpTypeX env (FunTy s1 t1) (FunTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2 +cmpTypeX env (PredTy p1) (PredTy p2) = cmpPredX env p1 p2 +cmpTypeX env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` cmpTypesX env tys1 tys2 +cmpTypeX env (NoteTy _ t1) t2 = cmpTypeX env t1 t2 +cmpTypeX env t1 (NoteTy _ t2) = cmpTypeX env t1 t2 + + -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < PredTy +cmpTypeX env (AppTy _ _) (TyVarTy _) = GT + +cmpTypeX env (FunTy _ _) (TyVarTy _) = GT +cmpTypeX env (FunTy _ _) (AppTy _ _) = GT + +cmpTypeX env (TyConApp _ _) (TyVarTy _) = GT +cmpTypeX env (TyConApp _ _) (AppTy _ _) = GT +cmpTypeX env (TyConApp _ _) (FunTy _ _) = GT + +cmpTypeX env (ForAllTy _ _) (TyVarTy _) = GT +cmpTypeX env (ForAllTy _ _) (AppTy _ _) = GT +cmpTypeX env (ForAllTy _ _) (FunTy _ _) = GT +cmpTypeX env (ForAllTy _ _) (TyConApp _ _) = GT + +cmpTypeX env (PredTy _) t2 = GT + +cmpTypeX env _ _ = LT + +------------- +cmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering +cmpTypesX env [] [] = EQ +cmpTypesX env (t1:tys1) (t2:tys2) = cmpTypeX env t1 t2 `thenCmp` cmpTypesX env tys1 tys2 +cmpTypesX env [] tys = LT +cmpTypesX env ty [] = GT + +------------- +cmpPredX :: RnEnv2 -> PredType -> PredType -> Ordering +cmpPredX env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` cmpTypeX env ty1 ty2 + -- Compare types as well as names for implicit parameters + -- This comparison is used exclusively (I think) for the + -- finite map built in TcSimplify +cmpPredX env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` cmpTypesX env tys1 tys2 +cmpPredX env (IParam _ _) (ClassP _ _) = LT +cmpPredX env (ClassP _ _) (IParam _ _) = GT +\end{code} + +PredTypes are used as a FM key in TcSimplify, +so we take the easy path and make them an instance of Ord + +\begin{code} +instance Eq PredType where { (==) = tcEqPred } +instance Ord PredType where { compare = tcCmpPred } \end{code} @@ -903,7 +1033,7 @@ eq_tys env tys1 tys2 = False \begin{code} data TvSubst = TvSubst InScopeSet -- The in-scope type variables - TvSubstEnv -- The substitution itself; guaranteed idempotent + TvSubstEnv -- The substitution itself -- See Note [Apply Once] {- ---------------------------------------------------------- @@ -934,11 +1064,29 @@ type TvSubstEnv = TyVarEnv Type -- in the middle of matching, and unification (see Types.Unify) -- So you have to look at the context to know if it's idempotent or -- apply-once or whatever +emptyTvSubstEnv :: TvSubstEnv +emptyTvSubstEnv = emptyVarEnv + +composeTvSubst :: InScopeSet -> TvSubstEnv -> TvSubstEnv -> TvSubstEnv +-- (compose env1 env2)(x) is env1(env2(x)); i.e. apply env2 then env1 +-- It assumes that both are idempotent +-- Typically, env1 is the refinement to a base substitution env2 +composeTvSubst in_scope env1 env2 + = env1 `plusVarEnv` mapVarEnv (substTy subst1) env2 + -- First apply env1 to the range of env2 + -- Then combine the two, making sure that env1 loses if + -- both bind the same variable; that's why env1 is the + -- *left* argument to plusVarEnv, because the right arg wins + where + subst1 = TvSubst in_scope env1 emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv isEmptyTvSubst :: TvSubst -> Bool isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env +mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst +mkTvSubst = TvSubst + getTvSubstEnv :: TvSubst -> TvSubstEnv getTvSubstEnv (TvSubst _ env) = env @@ -948,6 +1096,9 @@ getTvInScope (TvSubst in_scope _) = in_scope isInScope :: Var -> TvSubst -> Bool isInScope v (TvSubst in_scope _) = v `elemInScopeSet` in_scope +notElemTvSubst :: TyVar -> TvSubst -> Bool +notElemTvSubst tv (TvSubst _ env) = not (tv `elemVarEnv` env) + setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst setTvSubstEnv (TvSubst in_scope _) env = TvSubst in_scope env @@ -961,16 +1112,20 @@ extendTvSubstList :: TvSubst -> [TyVar] -> [Type] -> TvSubst extendTvSubstList (TvSubst in_scope env) tvs tys = TvSubst in_scope (extendVarEnvList env (tvs `zip` tys)) --- mkTvSubst and zipTvSubst generate the in-scope set from +-- mkOpenTvSubst and zipOpenTvSubst generate the in-scope set from -- the types given; but it's just a thunk so with a bit of luck -- it'll never be evaluated -mkTvSubst :: TvSubstEnv -> TvSubst -mkTvSubst env - = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env +mkOpenTvSubst :: TvSubstEnv -> TvSubst +mkOpenTvSubst env = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env -zipTvSubst :: [TyVar] -> [Type] -> TvSubst -zipTvSubst tyvars tys +zipOpenTvSubst :: [TyVar] -> [Type] -> TvSubst +zipOpenTvSubst tyvars tys +#ifdef DEBUG + | length tyvars /= length tys + = pprTrace "zipOpenTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst + | otherwise +#endif = TvSubst (mkInScopeSet (tyVarsOfTypes tys)) (zipTyEnv tyvars tys) -- mkTopTvSubst is called when doing top-level substitutions. @@ -980,7 +1135,13 @@ mkTopTvSubst :: [(TyVar, Type)] -> TvSubst mkTopTvSubst prs = TvSubst emptyInScopeSet (mkVarEnv prs) zipTopTvSubst :: [TyVar] -> [Type] -> TvSubst -zipTopTvSubst tyvars tys = TvSubst emptyInScopeSet (zipTyEnv tyvars tys) +zipTopTvSubst tyvars tys +#ifdef DEBUG + | length tyvars /= length tys + = pprTrace "zipOpenTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst + | otherwise +#endif + = TvSubst emptyInScopeSet (zipTyEnv tyvars tys) zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv zipTyEnv tyvars tys @@ -1007,6 +1168,8 @@ zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendVarEnv env tv ty) -- and so generated a rep type mentioning t not t2. -- -- Simplest fix is to nuke the "optimisation" +zip_ty_env tvs tys env = pprTrace "Var/Type length mismatch: " (ppr tvs $$ ppr tys) env +-- zip_ty_env _ _ env = env instance Outputable TvSubst where ppr (TvSubst ins env) @@ -1023,7 +1186,8 @@ instance Outputable TvSubst where \begin{code} substTyWith :: [TyVar] -> [Type] -> Type -> Type -substTyWith tvs tys = substTy (zipTvSubst tvs tys) +substTyWith tvs tys = ASSERT( length tvs == length tys ) + substTy (zipOpenTvSubst tvs tys) substTy :: TvSubst -> Type -> Type substTy subst ty | isEmptyTvSubst subst = ty @@ -1047,13 +1211,10 @@ substPred subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys) -- Note that the in_scope set is poked only if we hit a forall -- so it may often never be fully computed -subst_ty subst@(TvSubst in_scope env) ty +subst_ty subst ty = go ty where - go ty@(TyVarTy tv) = case (lookupVarEnv env tv) of - Nothing -> ty - Just ty' -> ty' -- See Note [Apply Once] - + go (TyVarTy tv) = substTyVar subst tv go (TyConApp tc tys) = let args = map go tys in args `seqList` TyConApp tc args @@ -1067,11 +1228,17 @@ subst_ty subst@(TvSubst in_scope env) ty -- The mkAppTy smart constructor is important -- we might be replacing (a Int), represented with App -- by [Int], represented with TyConApp - go (ForAllTy tv ty) = case substTyVar subst tv of + go (ForAllTy tv ty) = case substTyVarBndr subst tv of (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty) -substTyVar :: TvSubst -> TyVar -> (TvSubst, TyVar) -substTyVar subst@(TvSubst in_scope env) old_var +substTyVar :: TvSubst -> TyVar -> Type +substTyVar (TvSubst in_scope env) tv + = case (lookupVarEnv env tv) of + Nothing -> TyVarTy tv + Just ty' -> ty' -- See Note [Apply Once] + +substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar) +substTyVarBndr subst@(TvSubst in_scope env) old_var | old_var == new_var -- No need to clone -- But we *must* zap any current substitution for the variable. -- For example: @@ -1080,7 +1247,8 @@ substTyVar subst@(TvSubst in_scope env) old_var -- -- The new_id isn't cloned, but it may have a different type -- etc, so we must return it, not the old id - = (TvSubst (in_scope `extendInScopeSet` new_var) (delVarEnv env old_var), + = (TvSubst (in_scope `extendInScopeSet` new_var) + (delVarEnv env old_var), new_var) | otherwise -- The new binder is in scope so @@ -1088,11 +1256,10 @@ substTyVar subst@(TvSubst in_scope env) old_var -- Extending the substitution to do this renaming also -- has the (correct) effect of discarding any existing -- substitution for that variable - = (TvSubst (in_scope `extendInScopeSet` new_var) (extendVarEnv env old_var (TyVarTy new_var)), + = (TvSubst (in_scope `extendInScopeSet` new_var) + (extendVarEnv env old_var (TyVarTy new_var)), new_var) where new_var = uniqAway in_scope old_var -- The uniqAway part makes sure the new variable is not already in scope \end{code} - -