X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FKind.lhs;h=fa24fec144003604aa28c5530a3403df860f4b92;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=a65ec1ba6231dc90a478e42cb38668e850dcff98;hpb=f714e6b642fd614a9971717045ae47c3d871275e;p=ghc-hetmet.git

diff --git a/ghc/compiler/types/Kind.lhs b/ghc/compiler/types/Kind.lhs
index a65ec1b..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}
@@ -44,33 +48,49 @@ where	*    [LiftedTypeKind]   means boxed type
 
 In particular:
 
-	error :: forall a:<any>. String -> a
+	error :: forall a:?. String -> a
 	(->)  :: ?? -> ? -> *
-	(\(x::t) -> ...)	Here t::<any> (i.e. not unboxed tuple)
+	(\(x::t) -> ...)	Here t::?? (i.e. not unboxed tuple)
 
 \begin{code}
 data Kind 
-  = LiftedTypeKind 	-- *
+  = LiftedTypeKind 	--  *
   | OpenTypeKind	-- ?
-  | UnliftedTypeKind	-- #
+  | UnliftedTypeKind	--  #
   | UbxTupleKind	-- (##)
   | ArgTypeKind		-- ??
   | FunKind Kind Kind	-- k1 -> k2
   | KindVar KindVar
   deriving( Eq )
 
-data KindVar = KVar Unique (IORef (Maybe SimpleKind))
-  -- INVARIANT: a KindVar can only be instantaited by a SimpleKind
+data KindVar = KVar Unique OccName (IORef (Maybe SimpleKind))
+  -- INVARIANT: a KindVar can only be instantiated by a SimpleKind
 
 type SimpleKind = Kind	
   -- A SimpleKind has no ? or # kinds in it:
   -- 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
@@ -97,11 +117,6 @@ finding the GLB of the two.  Since the partial order is a tree, they only
 have a glb if one is a sub-kind of the other.  In that case, we bind the
 less-informative one to the more informative one.  Neat, eh?
 
-In the olden days, when we generalise, we make generic type variables
-whose kind is simple.  So generic type variables (other than built-in
-constants like 'error') always have simple kinds.  But I don't see any
-reason to do that any more (TcMType.zapTcTyVarToTyVar).
-
 
 \begin{code}
 liftedTypeKind   = LiftedTypeKind
@@ -150,6 +165,9 @@ isArgTypeKind other	       = False
 isOpenTypeKind :: Kind -> Bool
 -- True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
 isOpenTypeKind (FunKind _ _) = False
+isOpenTypeKind (KindVar _)   = False	-- This is a conservative answer
+					-- It matters in the call to isSubKind in
+					-- checkExpectedKind.
 isOpenTypeKind other	     = True
 
 isSubKind :: Kind -> Kind -> Bool
@@ -159,12 +177,23 @@ isSubKind UnliftedTypeKind UnliftedTypeKind = True
 isSubKind UbxTupleKind     UbxTupleKind     = True
 isSubKind k1 		   OpenTypeKind     = isOpenTypeKind k1
 isSubKind k1 		   ArgTypeKind      = isArgTypeKind k1
-isSubKind (FunKind a1 r1) (FunKind a2 r2)
-  = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
-isSubKind k1 k2 = False
+isSubKind (FunKind a1 r1) (FunKind a2 r2)   = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
+isSubKind k1		  k2		    = False
 
 defaultKind :: Kind -> Kind
 -- Used when generalising: default kind '?' and '??' to '*'
+-- 
+-- When we generalise, we make generic type variables whose kind is
+-- simple (* or *->* etc).  So generic type variables (other than
+-- built-in constants like 'error') always have simple kinds.  This is important;
+-- consider
+--	f x = True
+-- We want f to get type
+--	f :: forall (a::*). a -> Bool
+-- Not 
+--	f :: forall (a::??). a -> Bool
+-- because that would allow a call like (f 3#) as well as (f True),
+--and the calling conventions differ.  This defaulting is done in TcMType.zonkTcTyVarBndr.
 defaultKind OpenTypeKind = LiftedTypeKind
 defaultKind ArgTypeKind  = LiftedTypeKind
 defaultKind kind	 = kind
@@ -179,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
@@ -194,8 +223,6 @@ pprKind UnliftedTypeKind = ptext SLIT("#")
 pprKind OpenTypeKind     = ptext SLIT("?")
 pprKind ArgTypeKind      = ptext SLIT("??")
 pprKind UbxTupleKind     = ptext SLIT("(#)")
-pprKind (FunKind k1 k2)  = sep [ pprKind k1, arrow <+> pprParendKind k2]
-\end{code}
-
-
+pprKind (FunKind k1 k2)  = sep [ pprParendKind k1, arrow <+> pprKind k2]
 
+\end{code}