X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FKind.lhs;h=ab77d19805450336ba625cef9f6cd7b76fa96f45;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hp=0b247e4171e326a72f16efb4709643f6573d9cc3;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git

diff --git a/ghc/compiler/types/Kind.lhs b/ghc/compiler/types/Kind.lhs
index 0b247e4..ab77d19 100644
--- a/ghc/compiler/types/Kind.lhs
+++ b/ghc/compiler/types/Kind.lhs
@@ -4,6 +4,8 @@
 \section[Kind]{The @Kind@ datatype}
 
 \begin{code}
+#include "HsVersions.h"
+
 module Kind (
 	Kind(..),		-- Only visible to friends: TcKind
 
@@ -12,13 +14,18 @@ module Kind (
 	mkUnboxedTypeKind,
 	mkBoxedTypeKind,
 
-	isSubKindOf,
-	resultKind, argKind
+	hasMoreBoxityInfo,
+	resultKind, argKind,
+
+	isUnboxedKind, isTypeKind,
+	notArrowKind
     ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
 
-import Util		( panic )
+import Util		( panic, assertPanic )
+--import Outputable	( Outputable(..) )
+import Pretty
 \end{code}
 
 \begin{code}
@@ -34,11 +41,34 @@ mkTypeKind  	  = TypeKind
 mkUnboxedTypeKind = UnboxedTypeKind
 mkBoxedTypeKind   = BoxedTypeKind
 
-isSubKindOf :: Kind -> Kind -> Bool
+isTypeKind :: Kind -> Bool
+isTypeKind TypeKind = True
+isTypeKind other    = False
+
+isUnboxedKind :: Kind -> Bool
+isUnboxedKind UnboxedTypeKind 	= True
+isUnboxedKind other		= False
+
+hasMoreBoxityInfo :: Kind -> Kind -> Bool
+
+BoxedTypeKind 	`hasMoreBoxityInfo` TypeKind	    = True
+BoxedTypeKind   `hasMoreBoxityInfo` BoxedTypeKind   = True
+
+UnboxedTypeKind `hasMoreBoxityInfo` TypeKind 	    = True
+UnboxedTypeKind `hasMoreBoxityInfo` UnboxedTypeKind = True
+
+TypeKind	`hasMoreBoxityInfo` TypeKind	    = True
 
-BoxedTypeKind   `isSubKindOf` TypeKind = True
-UnboxedTypeKind `isSubKindOf` TypeKind = True
-kind1		`isSubKindOf` kind2    = kind1 == kind2
+kind1@(ArrowKind _ _) `hasMoreBoxityInfo` kind2@(ArrowKind _ _) = ASSERT( kind1 == kind2 )
+								  True
+	-- The two kinds can be arrow kinds; for example when unifying
+	-- (m1 Int) and (m2 Int) we end up unifying m1 and m2, which should
+	-- have the same kind.
+
+kind1		`hasMoreBoxityInfo` kind2	    = False
+
+notArrowKind (ArrowKind _ _) = False
+notArrowKind other_kind	     = True
 
 resultKind :: Kind -> Kind	-- Get result from arrow kind
 resultKind (ArrowKind _ res_kind) = res_kind
@@ -48,3 +78,18 @@ argKind :: Kind -> Kind		-- Get argument from arrow kind
 argKind (ArrowKind arg_kind _) = arg_kind
 argKind other_kind 	       = panic "argKind"
 \end{code}
+
+Printing
+~~~~~~~~
+\begin{code}
+instance Outputable Kind where
+  ppr sty kind = pprKind kind
+
+pprKind TypeKind        = ppStr "*"
+pprKind BoxedTypeKind   = ppStr "*b"
+pprKind UnboxedTypeKind = ppStr "*u"
+pprKind (ArrowKind k1 k2) = ppSep [pprKind_parend k1, ppStr "->", pprKind k2]
+
+pprKind_parend k@(ArrowKind _ _) = ppBesides [ppLparen, pprKind k, ppRparen]
+pprKind_parend k		 = pprKind k
+\end{code}