[project @ 1997-05-26 01:54:18 by sof]

[ghc-hetmet.git] / ghc / compiler / types / Kind.lhs

diff --git a/ghc/compiler/types/Kind.lhs b/ghc/compiler/types/Kind.lhs
index 945c66b..5509070 100644 (file)
--- 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,14 +14,20 @@ module Kind (
        mkUnboxedTypeKind,
        mkBoxedTypeKind,
 
-       isSubKindOf,
-       resultKind, argKind
+       hasMoreBoxityInfo,
+       resultKind, argKind,
+
+       pprKind, pprParendKind,
+
+       isUnboxedTypeKind, isTypeKind, isBoxedTypeKind,
+       notArrowKind
     ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
 
-import Util            ( panic )
-import Outputable      ( Outputable(..) )
+import Util            ( panic, assertPanic )
+
+import Outputable      ( Outputable(..), pprQuote )
 import Pretty
 \end{code}
 
@@ -36,11 +44,38 @@ mkTypeKind            = TypeKind
 mkUnboxedTypeKind = UnboxedTypeKind
 mkBoxedTypeKind   = BoxedTypeKind
 
-isSubKindOf :: Kind -> Kind -> Bool
+isTypeKind :: Kind -> Bool
+isTypeKind TypeKind = True
+isTypeKind other    = False
+
+isBoxedTypeKind :: Kind -> Bool
+isBoxedTypeKind BoxedTypeKind = True
+isBoxedTypeKind other         = False
+
+isUnboxedTypeKind :: Kind -> Bool
+isUnboxedTypeKind UnboxedTypeKind = True
+isUnboxedTypeKind 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
+
+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
 
-BoxedTypeKind   `isSubKindOf` TypeKind = True
-UnboxedTypeKind `isSubKindOf` TypeKind = True
-kind1          `isSubKindOf` kind2    = kind1 == kind2
+notArrowKind (ArrowKind _ _) = False
+notArrowKind other_kind             = True
 
 resultKind :: Kind -> Kind     -- Get result from arrow kind
 resultKind (ArrowKind _ res_kind) = res_kind
@@ -55,13 +90,13 @@ Printing
 ~~~~~~~~
 \begin{code}
 instance Outputable Kind where
-  ppr sty kind = pprKind kind
+  ppr sty kind = pprQuote sty $ \ _ -> 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 TypeKind        = char '*'     -- Can be boxed or unboxed
+pprKind BoxedTypeKind   = char '*'
+pprKind UnboxedTypeKind = text  "*#"   -- Unboxed
+pprKind (ArrowKind k1 k2) = sep [pprParendKind k1, text "->", pprKind k2]
 
-pprKind_parend k@(ArrowKind _ _) = ppBesides [ppLparen, pprKind k, ppRparen]
-pprKind_parend k                = pprKind k
+pprParendKind k@(ArrowKind _ _) = parens (pprKind k)
+pprParendKind k                        = pprKind k
 \end{code}