ghc/compiler/types/Kind.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996
   3 %
   4 \section[Kind]{The @Kind@ datatype}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module Kind (
  10         Kind(..),               -- Only visible to friends: TcKind
  11
  12         mkArrowKind,
  13         mkTypeKind,
  14         mkUnboxedTypeKind,
  15         mkBoxedTypeKind,
  16
  17         hasMoreBoxityInfo,
  18         resultKind, argKind,
  19
  20         isUnboxedKind, isTypeKind
  21     ) where
  22
  23 import Ubiq{-uitous-}
  24
  25 import Util             ( panic, assertPanic )
  26 --import Outputable     ( Outputable(..) )
  27 import Pretty
  28 \end{code}
  29
  30 \begin{code}
  31 data Kind
  32   = TypeKind            -- Any type (incl unboxed types)
  33   | BoxedTypeKind       -- Any boxed type
  34   | UnboxedTypeKind     -- Any unboxed type
  35   | ArrowKind Kind Kind
  36   deriving Eq
  37
  38 mkArrowKind       = ArrowKind
  39 mkTypeKind        = TypeKind
  40 mkUnboxedTypeKind = UnboxedTypeKind
  41 mkBoxedTypeKind   = BoxedTypeKind
  42
  43 isTypeKind :: Kind -> Bool
  44 isTypeKind TypeKind = True
  45 isTypeKind other    = False
  46
  47 isUnboxedKind :: Kind -> Bool
  48 isUnboxedKind UnboxedTypeKind   = True
  49 isUnboxedKind other             = False
  50
  51 hasMoreBoxityInfo :: Kind -> Kind -> Bool
  52
  53 BoxedTypeKind   `hasMoreBoxityInfo` TypeKind        = True
  54 BoxedTypeKind   `hasMoreBoxityInfo` BoxedTypeKind   = True
  55
  56 UnboxedTypeKind `hasMoreBoxityInfo` TypeKind        = True
  57 UnboxedTypeKind `hasMoreBoxityInfo` UnboxedTypeKind = True
  58
  59 TypeKind        `hasMoreBoxityInfo` TypeKind        = True
  60
  61 kind1           `hasMoreBoxityInfo` kind2           = ASSERT( notArrowKind kind1 &&
  62                                                               notArrowKind kind2 )
  63                                                       False
  64
  65 -- Not exported
  66 notArrowKind (ArrowKind _ _) = False
  67 notArrowKind other_kind      = True
  68
  69 resultKind :: Kind -> Kind      -- Get result from arrow kind
  70 resultKind (ArrowKind _ res_kind) = res_kind
  71 resultKind other_kind             = panic "resultKind"
  72
  73 argKind :: Kind -> Kind         -- Get argument from arrow kind
  74 argKind (ArrowKind arg_kind _) = arg_kind
  75 argKind other_kind             = panic "argKind"
  76 \end{code}
  77
  78 Printing
  79 ~~~~~~~~
  80 \begin{code}
  81 instance Outputable Kind where
  82   ppr sty kind = pprKind kind
  83
  84 pprKind TypeKind        = ppStr "*"
  85 pprKind BoxedTypeKind   = ppStr "*b"
  86 pprKind UnboxedTypeKind = ppStr "*u"
  87 pprKind (ArrowKind k1 k2) = ppSep [pprKind_parend k1, ppStr "->", pprKind k2]
  88
  89 pprKind_parend k@(ArrowKind _ _) = ppBesides [ppLparen, pprKind k, ppRparen]
  90 pprKind_parend k                 = pprKind k
  91 \end{code}