X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FKind.lhs;h=79999c27bfb5a99621141aeebb8dcb870af0841b;hp=fa24fec144003604aa28c5530a3403df860f4b92;hb=ee2dd59cf1c96437696b9ec39b35dd1beea259a1;hpb=24ce1351fb121d429375f411a8a95d619de921e1

diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs
index fa24fec..79999c2 100644
--- a/compiler/types/Kind.lhs
+++ b/compiler/types/Kind.lhs
@@ -5,10 +5,10 @@
 \begin{code}
 module Kind (
 	Kind(..), SimpleKind, 
-	openTypeKind, liftedTypeKind, unliftedTypeKind, 
+	openTypeKind, liftedTypeKind, unliftedTypeKind, unboxedTypeKind,
 	argTypeKind, ubxTupleKind,
 
-	isLiftedTypeKind, isUnliftedTypeKind, 
+	isLiftedTypeKind, isUnliftedTypeKind, isUnliftedBoxedTypeKind,
 	isArgTypeKind, isOpenTypeKind,
 	mkArrowKind, mkArrowKinds,
 
@@ -37,11 +37,11 @@ There's a little subtyping at the kind level:
 		/ \
 	       /   \
 	      ??   (#)
-	     /  \
-            *   #
+	    / | \
+	   *  !  #
 
 where	*    [LiftedTypeKind]   means boxed type
-	#    [UnliftedTypeKind] means unboxed type
+	#    [UnboxedTypeKind]  means unboxed type
 	(#)  [UbxTupleKind]     means unboxed tuple
 	??   [ArgTypeKind]      is the lub of *,#
 	?    [OpenTypeKind]	means any type at all
@@ -55,11 +55,12 @@ In particular:
 \begin{code}
 data Kind 
   = LiftedTypeKind 	--  *
-  | OpenTypeKind	-- ?
-  | UnliftedTypeKind	--  #
-  | UbxTupleKind	-- (##)
-  | ArgTypeKind		-- ??
-  | FunKind Kind Kind	-- k1 -> k2
+  | OpenTypeKind	--  ?
+  | UnboxedTypeKind	--  #
+  | UnliftedTypeKind    --  !
+  | UbxTupleKind	--  (##)
+  | ArgTypeKind		--  ??
+  | FunKind Kind Kind	--  k1 -> k2
   | KindVar KindVar
   deriving( Eq )
 
@@ -120,6 +121,7 @@ less-informative one to the more informative one.  Neat, eh?
 
 \begin{code}
 liftedTypeKind   = LiftedTypeKind
+unboxedTypeKind  = UnboxedTypeKind
 unliftedTypeKind = UnliftedTypeKind
 openTypeKind     = OpenTypeKind
 argTypeKind      = ArgTypeKind
@@ -152,13 +154,18 @@ isLiftedTypeKind, isUnliftedTypeKind :: Kind -> Bool
 isLiftedTypeKind LiftedTypeKind = True
 isLiftedTypeKind other		= False
 
+isUnliftedBoxedTypeKind UnliftedTypeKind = True
+isUnliftedBoxedTypeKind other	    = False
+
 isUnliftedTypeKind UnliftedTypeKind = True
+isUnliftedTypeKind UnboxedTypeKind  = True
 isUnliftedTypeKind other	    = False
 
 isArgTypeKind :: Kind -> Bool
 -- True of any sub-kind of ArgTypeKind 
 isArgTypeKind LiftedTypeKind   = True
 isArgTypeKind UnliftedTypeKind = True
+isArgTypeKind UnboxedTypeKind  = True
 isArgTypeKind ArgTypeKind      = True
 isArgTypeKind other	       = False
 
@@ -174,6 +181,7 @@ isSubKind :: Kind -> Kind -> Bool
 -- (k1 `isSubKind` k2) checks that k1 <: k2
 isSubKind LiftedTypeKind   LiftedTypeKind   = True
 isSubKind UnliftedTypeKind UnliftedTypeKind = True
+isSubKind UnboxedTypeKind  UnboxedTypeKind  = True
 isSubKind UbxTupleKind     UbxTupleKind     = True
 isSubKind k1 		   OpenTypeKind     = isOpenTypeKind k1
 isSubKind k1 		   ArgTypeKind      = isArgTypeKind k1
@@ -219,7 +227,8 @@ pprParendKind k		      = pprKind k
 
 pprKind (KindVar v)      = ppr v
 pprKind LiftedTypeKind   = ptext SLIT("*")
-pprKind UnliftedTypeKind = ptext SLIT("#")
+pprKind UnliftedTypeKind = ptext SLIT("!")
+pprKind UnboxedTypeKind  = ptext SLIT("#")
 pprKind OpenTypeKind     = ptext SLIT("?")
 pprKind ArgTypeKind      = ptext SLIT("??")
 pprKind UbxTupleKind     = ptext SLIT("(#)")