compiler/types/Kind.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
   3 %
   4
   5 \begin{code}
   6 module Kind (
   7         Kind(..), SimpleKind,
   8         openTypeKind, liftedTypeKind, unliftedTypeKind, unboxedTypeKind,
   9         argTypeKind, ubxTupleKind,
  10
  11         isLiftedTypeKind, isUnliftedTypeKind, isUnliftedBoxedTypeKind,
  12         isArgTypeKind, isOpenTypeKind,
  13         mkArrowKind, mkArrowKinds,
  14
  15         isSubKind, defaultKind,
  16         kindFunResult, splitKindFunTys,
  17
  18         KindVar, mkKindVar, kindVarRef, kindVarUniq,
  19         kindVarOcc, setKindVarOcc,
  20
  21         pprKind, pprParendKind
  22      ) where
  23
  24 #include "HsVersions.h"
  25
  26 import Unique   ( Unique )
  27 import OccName  ( OccName, mkOccName, tvName )
  28 import Outputable
  29 import DATA_IOREF
  30 \end{code}
  31
  32 Kinds
  33 ~~~~~
  34 There's a little subtyping at the kind level:
  35
  36                  ?
  37                 / \
  38                /   \
  39               ??   (#)
  40             / | \
  41            *  !  #
  42
  43 where   *    [LiftedTypeKind]   means boxed type
  44         #    [UnboxedTypeKind]  means unboxed type
  45         (#)  [UbxTupleKind]     means unboxed tuple
  46         ??   [ArgTypeKind]      is the lub of *,#
  47         ?    [OpenTypeKind]     means any type at all
  48
  49 In particular:
  50
  51         error :: forall a:?. String -> a
  52         (->)  :: ?? -> ? -> *
  53         (\(x::t) -> ...)        Here t::?? (i.e. not unboxed tuple)
  54
  55 \begin{code}
  56 data Kind
  57   = LiftedTypeKind      --  *
  58   | OpenTypeKind        --  ?
  59   | UnboxedTypeKind     --  #
  60   | UnliftedTypeKind    --  !
  61   | UbxTupleKind        --  (##)
  62   | ArgTypeKind         --  ??
  63   | FunKind Kind Kind   --  k1 -> k2
  64   | KindVar KindVar
  65   deriving( Eq )
  66
  67 data KindVar = KVar Unique OccName (IORef (Maybe SimpleKind))
  68   -- INVARIANT: a KindVar can only be instantiated by a SimpleKind
  69
  70 type SimpleKind = Kind
  71   -- A SimpleKind has no ? or # kinds in it:
  72   -- sk ::= * | sk1 -> sk2 | kvar
  73
  74 instance Eq KindVar where
  75   (KVar u1 _ _) == (KVar u2 _ _) = u1 == u2
  76
  77 mkKindVar :: Unique -> IORef (Maybe Kind) -> KindVar
  78 mkKindVar u r = KVar u kind_var_occ r
  79
  80 kindVarRef :: KindVar -> IORef (Maybe Kind)
  81 kindVarRef (KVar _ _ ref) = ref
  82
  83 kindVarUniq :: KindVar -> Unique
  84 kindVarUniq (KVar uniq _ _) = uniq
  85
  86 kindVarOcc :: KindVar -> OccName
  87 kindVarOcc (KVar _ occ _) = occ
  88
  89 setKindVarOcc :: KindVar -> OccName -> KindVar
  90 setKindVarOcc (KVar u _ r) occ = KVar u occ r
  91
  92 kind_var_occ :: OccName -- Just one for all KindVars
  93                         -- They may be jiggled by tidying
  94 kind_var_occ = mkOccName tvName "k"
  95 \end{code}
  96
  97 Kind inference
  98 ~~~~~~~~~~~~~~
  99 During kind inference, a kind variable unifies only with
 100 a "simple kind", sk
 101         sk ::= * | sk1 -> sk2
 102 For example
 103         data T a = MkT a (T Int#)
 104 fails.  We give T the kind (k -> *), and the kind variable k won't unify
 105 with # (the kind of Int#).
 106
 107 Type inference
 108 ~~~~~~~~~~~~~~
 109 When creating a fresh internal type variable, we give it a kind to express
 110 constraints on it.  E.g. in (\x->e) we make up a fresh type variable for x,
 111 with kind ??.
 112
 113 During unification we only bind an internal type variable to a type
 114 whose kind is lower in the sub-kind hierarchy than the kind of the tyvar.
 115
 116 When unifying two internal type variables, we collect their kind constraints by
 117 finding the GLB of the two.  Since the partial order is a tree, they only
 118 have a glb if one is a sub-kind of the other.  In that case, we bind the
 119 less-informative one to the more informative one.  Neat, eh?
 120
 121
 122 \begin{code}
 123 liftedTypeKind   = LiftedTypeKind
 124 unboxedTypeKind  = UnboxedTypeKind
 125 unliftedTypeKind = UnliftedTypeKind
 126 openTypeKind     = OpenTypeKind
 127 argTypeKind      = ArgTypeKind
 128 ubxTupleKind     = UbxTupleKind
 129
 130 mkArrowKind :: Kind -> Kind -> Kind
 131 mkArrowKind k1 k2 = k1 `FunKind` k2
 132
 133 mkArrowKinds :: [Kind] -> Kind -> Kind
 134 mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
 135 \end{code}
 136
 137 %************************************************************************
 138 %*                                                                      *
 139         Functions over Kinds
 140 %*                                                                      *
 141 %************************************************************************
 142
 143 \begin{code}
 144 kindFunResult :: Kind -> Kind
 145 kindFunResult (FunKind _ k) = k
 146 kindFunResult k = pprPanic "kindFunResult" (ppr k)
 147
 148 splitKindFunTys :: Kind -> ([Kind],Kind)
 149 splitKindFunTys (FunKind k1 k2) = case splitKindFunTys k2 of
 150                                     (as, r) -> (k1:as, r)
 151 splitKindFunTys k = ([], k)
 152
 153 isLiftedTypeKind, isUnliftedTypeKind :: Kind -> Bool
 154 isLiftedTypeKind LiftedTypeKind = True
 155 isLiftedTypeKind other          = False
 156
 157 isUnliftedBoxedTypeKind UnliftedTypeKind = True
 158 isUnliftedBoxedTypeKind other       = False
 159
 160 isUnliftedTypeKind UnliftedTypeKind = True
 161 isUnliftedTypeKind UnboxedTypeKind  = True
 162 isUnliftedTypeKind other            = False
 163
 164 isArgTypeKind :: Kind -> Bool
 165 -- True of any sub-kind of ArgTypeKind
 166 isArgTypeKind LiftedTypeKind   = True
 167 isArgTypeKind UnliftedTypeKind = True
 168 isArgTypeKind UnboxedTypeKind  = True
 169 isArgTypeKind ArgTypeKind      = True
 170 isArgTypeKind other            = False
 171
 172 isOpenTypeKind :: Kind -> Bool
 173 -- True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
 174 isOpenTypeKind (FunKind _ _) = False
 175 isOpenTypeKind (KindVar _)   = False    -- This is a conservative answer
 176                                         -- It matters in the call to isSubKind in
 177                                         -- checkExpectedKind.
 178 isOpenTypeKind other         = True
 179
 180 isSubKind :: Kind -> Kind -> Bool
 181 -- (k1 `isSubKind` k2) checks that k1 <: k2
 182 isSubKind LiftedTypeKind   LiftedTypeKind   = True
 183 isSubKind UnliftedTypeKind UnliftedTypeKind = True
 184 isSubKind UnboxedTypeKind  UnboxedTypeKind  = True
 185 isSubKind UbxTupleKind     UbxTupleKind     = True
 186 isSubKind k1               OpenTypeKind     = isOpenTypeKind k1
 187 isSubKind k1               ArgTypeKind      = isArgTypeKind k1
 188 isSubKind (FunKind a1 r1) (FunKind a2 r2)   = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
 189 isSubKind k1              k2                = False
 190
 191 defaultKind :: Kind -> Kind
 192 -- Used when generalising: default kind '?' and '??' to '*'
 193 --
 194 -- When we generalise, we make generic type variables whose kind is
 195 -- simple (* or *->* etc).  So generic type variables (other than
 196 -- built-in constants like 'error') always have simple kinds.  This is important;
 197 -- consider
 198 --      f x = True
 199 -- We want f to get type
 200 --      f :: forall (a::*). a -> Bool
 201 -- Not
 202 --      f :: forall (a::??). a -> Bool
 203 -- because that would allow a call like (f 3#) as well as (f True),
 204 --and the calling conventions differ.  This defaulting is done in TcMType.zonkTcTyVarBndr.
 205 defaultKind OpenTypeKind = LiftedTypeKind
 206 defaultKind ArgTypeKind  = LiftedTypeKind
 207 defaultKind kind         = kind
 208 \end{code}
 209
 210
 211 %************************************************************************
 212 %*                                                                      *
 213                 Pretty printing
 214 %*                                                                      *
 215 %************************************************************************
 216
 217 \begin{code}
 218 instance Outputable KindVar where
 219   ppr (KVar uniq occ _) = ppr occ <> ifPprDebug (ppr uniq)
 220
 221 instance Outputable Kind where
 222   ppr k = pprKind k
 223
 224 pprParendKind :: Kind -> SDoc
 225 pprParendKind k@(FunKind _ _) = parens (pprKind k)
 226 pprParendKind k               = pprKind k
 227
 228 pprKind (KindVar v)      = ppr v
 229 pprKind LiftedTypeKind   = ptext SLIT("*")
 230 pprKind UnliftedTypeKind = ptext SLIT("!")
 231 pprKind UnboxedTypeKind  = ptext SLIT("#")
 232 pprKind OpenTypeKind     = ptext SLIT("?")
 233 pprKind ArgTypeKind      = ptext SLIT("??")
 234 pprKind UbxTupleKind     = ptext SLIT("(#)")
 235 pprKind (FunKind k1 k2)  = sep [ pprParendKind k1, arrow <+> pprKind k2]
 236
 237 \end{code}