[project @ 2005-08-11 08:04:33 by simonpj]

Do 'tidying' on Kinds before printing them.  This avoids printing
stuff like 'k_43b' in user error messages.

To do this, I ended up adding an OccName to Kind.KindVar.  Even
then the implementation is a bit of hack (see comments with
Type.tidyKind).  Still, it's a highly localised hack, whereas the
"right thing" entails making KindVar into a flavour of Var, which
seems like an uncomfortably big change.

   I think this change can merge to the stable branch

diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index 97be0a9..fd0d1ca 100644 (file)
--- a/ghc/compiler/typecheck/TcMType.lhs
+++ b/ghc/compiler/typecheck/TcMType.lhs
@@ -63,7 +63,7 @@ import TcType         ( TcType, TcThetaType, TcTauType, TcPredType,
                          tyVarsOfPred, getClassPredTys_maybe,
                          tyVarsOfType, tyVarsOfTypes, 
                          pprPred, pprTheta, pprClassPred )
-import Kind            ( Kind(..), KindVar(..), mkKindVar, isSubKind,
+import Kind            ( Kind(..), KindVar, kindVarRef, mkKindVar, isSubKind,
                          isLiftedTypeKind, isArgTypeKind, isOpenTypeKind,
                          liftedTypeKind, defaultKind
                        )
@@ -589,8 +589,8 @@ zonkTyVar unbound_var_fn rflag tyvar
 \begin{code}
 readKindVar  :: KindVar -> TcM (Maybe TcKind)
 writeKindVar :: KindVar -> TcKind -> TcM ()
-readKindVar  (KVar _ ref)     = readMutVar ref
-writeKindVar (KVar _ ref) val = writeMutVar ref (Just val)
+readKindVar  kv = readMutVar (kindVarRef kv)
+writeKindVar kv val = writeMutVar (kindVarRef kv) (Just val)
 
 -------------
 zonkTcKind :: TcKind -> TcM TcKind

diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 3beaf55..0e07a32 100644 (file)
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -105,7 +105,7 @@ module TcType (
 
   tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
   tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, tidySkolemTyVar,
-  typeKind, 
+  typeKind, tidyKind,
 
   tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
 
@@ -138,7 +138,7 @@ import Type         (       -- Re-exports
                          tidyTopType, tidyType, tidyPred, tidyTypes,
                          tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
                          tidyTyVarBndr, tidyOpenTyVar,
-                         tidyOpenTyVars, 
+                         tidyOpenTyVars, tidyKind,
                          isSubKind, deShadowTy,
 
                          tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, 

diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs
index be92734..1aa32b6 100644 (file)
--- a/ghc/compiler/typecheck/TcUnify.lhs
+++ b/ghc/compiler/typecheck/TcUnify.lhs
@@ -41,7 +41,7 @@ import TcType         ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType,
                          tyVarsOfType, mkPhiTy, mkTyVarTy, mkPredTy,
                          typeKind, tcSplitFunTy_maybe, mkForAllTys, mkAppTy,
                          tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars,
-                         pprType, tidySkolemTyVar, isSkolemTyVar )
+                         pprType, tidyKind, tidySkolemTyVar, isSkolemTyVar )
 import Kind            ( Kind(..), SimpleKind, KindVar, isArgTypeKind,
                          openTypeKind, liftedTypeKind, mkArrowKind, 
                          isOpenTypeKind, argTypeKind, isLiftedTypeKind, isUnliftedTypeKind,
@@ -1336,6 +1336,9 @@ checkExpectedKind ty act_kind exp_kind
         (act_as, _) = splitKindFunTys act_kind
        n_exp_as = length exp_as
        n_act_as = length act_as
+       
+       (env1, tidy_exp_kind) = tidyKind emptyTidyEnv exp_kind
+       (env2, tidy_act_kind) = tidyKind env1         act_kind
 
        err | n_exp_as < n_act_as       -- E.g. [Maybe]
            = quotes (ppr ty) <+> ptext SLIT("is not applied to enough type arguments")
@@ -1354,11 +1357,11 @@ checkExpectedKind ty act_kind exp_kind
            = ptext SLIT("Kind mis-match")
 
        more_info = sep [ ptext SLIT("Expected kind") <+> 
-                               quotes (pprKind exp_kind) <> comma,
+                               quotes (pprKind tidy_exp_kind) <> comma,
                          ptext SLIT("but") <+> quotes (ppr ty) <+> 
-                               ptext SLIT("has kind") <+> quotes (pprKind act_kind)]
+                               ptext SLIT("has kind") <+> quotes (pprKind tidy_act_kind)]
    in
-   failWithTc (err $$ more_info)
+   failWithTcM (env2, err $$ more_info)
    }
 \end{code}
 

diff --git a/ghc/compiler/types/Kind.lhs b/ghc/compiler/types/Kind.lhs
index ac89b3b..fa24fec 100644 (file)
--- a/ghc/compiler/types/Kind.lhs
+++ b/ghc/compiler/types/Kind.lhs
@@ -4,7 +4,7 @@
 
 \begin{code}
 module Kind (
-       Kind(..), KindVar(..), SimpleKind,
+       Kind(..), SimpleKind, 
        openTypeKind, liftedTypeKind, unliftedTypeKind, 
        argTypeKind, ubxTupleKind,
 
@@ -13,7 +13,10 @@ module Kind (
        mkArrowKind, mkArrowKinds,
 
         isSubKind, defaultKind, 
-       kindFunResult, splitKindFunTys, mkKindVar,
+       kindFunResult, splitKindFunTys, 
+
+       KindVar, mkKindVar, kindVarRef, kindVarUniq, 
+       kindVarOcc, setKindVarOcc,
 
        pprKind, pprParendKind
      ) where
@@ -21,6 +24,7 @@ module Kind (
 #include "HsVersions.h"
 
 import Unique  ( Unique )
+import OccName  ( OccName, mkOccName, tvName )
 import Outputable
 import DATA_IOREF
 \end{code}
@@ -59,7 +63,7 @@ data Kind
   | KindVar KindVar
   deriving( Eq )
 
-data KindVar = KVar Unique (IORef (Maybe SimpleKind))
+data KindVar = KVar Unique OccName (IORef (Maybe SimpleKind))
   -- INVARIANT: a KindVar can only be instantiated by a SimpleKind
 
 type SimpleKind = Kind 
@@ -67,10 +71,26 @@ type SimpleKind = Kind
   -- sk ::= * | sk1 -> sk2 | kvar
 
 instance Eq KindVar where
-  (KVar u1 _) == (KVar u2 _) = u1 == u2
+  (KVar u1 _ _) == (KVar u2 _ _) = u1 == u2
 
 mkKindVar :: Unique -> IORef (Maybe Kind) -> KindVar
-mkKindVar = KVar
+mkKindVar u r = KVar u kind_var_occ r
+
+kindVarRef :: KindVar -> IORef (Maybe Kind)
+kindVarRef (KVar _ _ ref) = ref
+
+kindVarUniq :: KindVar -> Unique
+kindVarUniq (KVar uniq _ _) = uniq
+
+kindVarOcc :: KindVar -> OccName
+kindVarOcc (KVar _ occ _) = occ
+
+setKindVarOcc :: KindVar -> OccName -> KindVar
+setKindVarOcc (KVar u _ r) occ = KVar u occ r
+
+kind_var_occ :: OccName        -- Just one for all KindVars
+                       -- They may be jiggled by tidying
+kind_var_occ = mkOccName tvName "k"
 \end{code}
 
 Kind inference
@@ -188,7 +208,7 @@ defaultKind kind     = kind
 
 \begin{code}
 instance Outputable KindVar where
-  ppr (KVar uniq _) = text "k_" <> ppr uniq
+  ppr (KVar uniq occ _) = ppr occ <> ifPprDebug (ppr uniq)
 
 instance Outputable Kind where
   ppr k = pprKind k
@@ -204,7 +224,5 @@ pprKind OpenTypeKind     = ptext SLIT("?")
 pprKind ArgTypeKind      = ptext SLIT("??")
 pprKind UbxTupleKind     = ptext SLIT("(#)")
 pprKind (FunKind k1 k2)  = sep [ pprParendKind k1, arrow <+> pprKind k2]
-\end{code}
-
-
 
+\end{code}

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index a376cf7..b31bec9 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, 
@@ -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
 
@@ -749,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}
+
 
 %************************************************************************
 %*                                                                     *