From 89627230a1b0e25a148621509d19297454f692eb Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 11 Aug 2005 08:04:34 +0000 Subject: [PATCH] [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 --- ghc/compiler/typecheck/TcMType.lhs | 6 +++--- ghc/compiler/typecheck/TcType.lhs | 4 ++-- ghc/compiler/typecheck/TcUnify.lhs | 11 ++++++---- ghc/compiler/types/Kind.lhs | 36 ++++++++++++++++++++++++-------- ghc/compiler/types/Type.lhs | 40 +++++++++++++++++++++++++++++++++++- 5 files changed, 78 insertions(+), 19 deletions(-) diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index 97be0a9..fd0d1ca 100644 --- 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 --- 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 --- 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 --- 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 --- 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} + %************************************************************************ %* * -- 1.7.10.4