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 module Kind (
   8         GenKind(..),    -- Only visible to friends: TcKind
   9         Kind,
  10
  11         mkArrowKind,
  12         mkTypeKind,
  13         mkUnboxedTypeKind,
  14         mkBoxedTypeKind,
  15
  16         hasMoreBoxityInfo,
  17         resultKind, argKind,
  18
  19         pprKind, pprParendKind,
  20
  21         isUnboxedTypeKind, isTypeKind, isBoxedTypeKind
  22     ) where
  23
  24 #include "HsVersions.h"
  25
  26 import Util             ( panic, assertPanic )
  27 import Unique           ( Unique, pprUnique )
  28 import BasicTypes       ( Unused )
  29 import Outputable
  30 \end{code}
  31
  32 \begin{code}
  33 data GenKind flexi
  34   = TypeKind            -- Any type (incl unboxed types)
  35   | BoxedTypeKind       -- Any boxed type
  36   | UnboxedTypeKind     -- Any unboxed type
  37   | ArrowKind (GenKind flexi) (GenKind flexi)
  38   | VarKind Unique flexi
  39
  40 type Kind = GenKind Unused      -- No variables at all
  41
  42 instance Eq (GenKind flexi) where
  43   TypeKind          == TypeKind          = True
  44   BoxedTypeKind     == BoxedTypeKind     = True
  45   UnboxedTypeKind   == UnboxedTypeKind   = True
  46   (ArrowKind j1 j2) == (ArrowKind k1 k2) = j1==k1 && j2==k2
  47   (VarKind u1 _)    == (VarKind u2 _)    = u1==u2
  48   k1                == k2                = False
  49
  50 mkArrowKind       = ArrowKind
  51 mkTypeKind        = TypeKind
  52 mkUnboxedTypeKind = UnboxedTypeKind
  53 mkBoxedTypeKind   = BoxedTypeKind
  54
  55 isTypeKind :: GenKind flexi -> Bool
  56 isTypeKind TypeKind = True
  57 isTypeKind other    = False
  58
  59 isBoxedTypeKind :: GenKind flexi -> Bool
  60 isBoxedTypeKind BoxedTypeKind = True
  61 isBoxedTypeKind other         = False
  62
  63 isUnboxedTypeKind :: GenKind flexi -> Bool
  64 isUnboxedTypeKind UnboxedTypeKind = True
  65 isUnboxedTypeKind other           = False
  66
  67 hasMoreBoxityInfo :: GenKind flexi -> GenKind flexi -> Bool
  68
  69 BoxedTypeKind   `hasMoreBoxityInfo` TypeKind        = True
  70 BoxedTypeKind   `hasMoreBoxityInfo` BoxedTypeKind   = True
  71
  72 UnboxedTypeKind `hasMoreBoxityInfo` TypeKind        = True
  73 UnboxedTypeKind `hasMoreBoxityInfo` UnboxedTypeKind = True
  74
  75 TypeKind        `hasMoreBoxityInfo` TypeKind        = True
  76
  77 kind1@(ArrowKind _ _) `hasMoreBoxityInfo` kind2@(ArrowKind _ _)
  78   = ASSERT( if kind1 == kind2 then True
  79             else pprPanic "hadMoreBoxityInfo" (ppr kind1 <> comma <+> ppr kind2) )
  80     True
  81         -- The two kinds can be arrow kinds; for example when unifying
  82         -- (m1 Int) and (m2 Int) we end up unifying m1 and m2, which should
  83         -- have the same kind.
  84
  85 kind1           `hasMoreBoxityInfo` kind2           = False
  86
  87 resultKind :: GenKind flexi -> GenKind flexi    -- Get result from arrow kind
  88 resultKind (ArrowKind _ res_kind) = res_kind
  89 resultKind other_kind             = panic "resultKind"
  90
  91 argKind :: GenKind flexi -> GenKind flexi               -- Get argument from arrow kind
  92 argKind (ArrowKind arg_kind _) = arg_kind
  93 argKind other_kind             = panic "argKind"
  94 \end{code}
  95
  96 Printing
  97 ~~~~~~~~
  98 \begin{code}
  99 instance Outputable (GenKind flexi) where
 100   ppr kind = pprKind kind
 101
 102 pprKind TypeKind          = text "**"   -- Can be boxed or unboxed
 103 pprKind BoxedTypeKind     = char '*'
 104 pprKind UnboxedTypeKind   = text  "*#"  -- Unboxed
 105 pprKind (ArrowKind k1 k2) = sep [pprParendKind k1, text "->", pprKind k2]
 106 pprKind (VarKind u _)     = char 'k' <> pprUnique u
 107
 108 pprParendKind k@(ArrowKind _ _) = parens (pprKind k)
 109 pprParendKind k                 = pprKind k
 110 \end{code}