[project @ 2005-10-27 14:34:32 by simonpj]

[ghc-hetmet.git] / ghc / compiler / types / Type.lhs

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 7fa651a..b911493 100644 (file)
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -54,6 +54,7 @@ module Type (
        tidyTyVarBndr, tidyFreeTyVars,
        tidyOpenTyVar, tidyOpenTyVars,
        tidyTopType,   tidyPred,
+       tidyKind,
 
        -- Comparison
        coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, 
@@ -70,8 +71,8 @@ module Type (
        extendTvSubst, extendTvSubstList, isInScope, composeTvSubst,
 
        -- Performing substitution on types
-       substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr,
-       deShadowTy, 
+       substTy, substTys, substTyWith, substTheta, 
+       substPred, substTyVar, substTyVarBndr, deShadowTy, 
 
        -- Pretty-printing
        pprType, pprParendType, pprTyThingCategory,
@@ -87,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
 
@@ -588,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}
 
@@ -748,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}
+
 
 %************************************************************************
 %*                                                                     *
@@ -1082,6 +1121,11 @@ mkOpenTvSubst env = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env
 
 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.
@@ -1091,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
@@ -1118,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) 
@@ -1134,7 +1186,8 @@ instance Outputable TvSubst where
 
 \begin{code}
 substTyWith :: [TyVar] -> [Type] -> Type -> Type
-substTyWith tvs tys = substTy (zipOpenTvSubst tvs tys)
+substTyWith tvs tys = ASSERT( length tvs == length tys )
+                     substTy (zipOpenTvSubst tvs tys)
 
 substTy :: TvSubst -> Type  -> Type
 substTy subst ty | isEmptyTvSubst subst = ty