Commit 89627230 authored by simonpj's avatar simonpj
Browse files

[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
parent 70cfef77
......@@ -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
......
......@@ -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,
......
......@@ -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}
......
......@@ -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}
......@@ -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}
%************************************************************************
%* *
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment