2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
8 openTypeKind, liftedTypeKind, unliftedTypeKind, unboxedTypeKind,
9 argTypeKind, ubxTupleKind,
11 isLiftedTypeKind, isUnliftedTypeKind, isUnliftedBoxedTypeKind,
12 isArgTypeKind, isOpenTypeKind,
13 mkArrowKind, mkArrowKinds,
15 isSubKind, defaultKind,
16 kindFunResult, splitKindFunTys,
18 KindVar, mkKindVar, kindVarRef, kindVarUniq,
19 kindVarOcc, setKindVarOcc,
21 pprKind, pprParendKind
24 #include "HsVersions.h"
26 import Unique ( Unique )
27 import OccName ( OccName, mkOccName, tvName )
34 There's a little subtyping at the kind level:
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
51 error :: forall a:?. String -> a
53 (\(x::t) -> ...) Here t::?? (i.e. not unboxed tuple)
59 | UnboxedTypeKind -- #
60 | UnliftedTypeKind -- !
61 | UbxTupleKind -- (##)
63 | FunKind Kind Kind -- k1 -> k2
67 data KindVar = KVar Unique OccName (IORef (Maybe SimpleKind))
68 -- INVARIANT: a KindVar can only be instantiated by a SimpleKind
70 type SimpleKind = Kind
71 -- A SimpleKind has no ? or # kinds in it:
72 -- sk ::= * | sk1 -> sk2 | kvar
74 instance Eq KindVar where
75 (KVar u1 _ _) == (KVar u2 _ _) = u1 == u2
77 mkKindVar :: Unique -> IORef (Maybe Kind) -> KindVar
78 mkKindVar u r = KVar u kind_var_occ r
80 kindVarRef :: KindVar -> IORef (Maybe Kind)
81 kindVarRef (KVar _ _ ref) = ref
83 kindVarUniq :: KindVar -> Unique
84 kindVarUniq (KVar uniq _ _) = uniq
86 kindVarOcc :: KindVar -> OccName
87 kindVarOcc (KVar _ occ _) = occ
89 setKindVarOcc :: KindVar -> OccName -> KindVar
90 setKindVarOcc (KVar u _ r) occ = KVar u occ r
92 kind_var_occ :: OccName -- Just one for all KindVars
93 -- They may be jiggled by tidying
94 kind_var_occ = mkOccName tvName "k"
99 During kind inference, a kind variable unifies only with
101 sk ::= * | sk1 -> sk2
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#).
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,
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.
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?
123 liftedTypeKind = LiftedTypeKind
124 unboxedTypeKind = UnboxedTypeKind
125 unliftedTypeKind = UnliftedTypeKind
126 openTypeKind = OpenTypeKind
127 argTypeKind = ArgTypeKind
128 ubxTupleKind = UbxTupleKind
130 mkArrowKind :: Kind -> Kind -> Kind
131 mkArrowKind k1 k2 = k1 `FunKind` k2
133 mkArrowKinds :: [Kind] -> Kind -> Kind
134 mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
137 %************************************************************************
141 %************************************************************************
144 kindFunResult :: Kind -> Kind
145 kindFunResult (FunKind _ k) = k
146 kindFunResult k = pprPanic "kindFunResult" (ppr k)
148 splitKindFunTys :: Kind -> ([Kind],Kind)
149 splitKindFunTys (FunKind k1 k2) = case splitKindFunTys k2 of
150 (as, r) -> (k1:as, r)
151 splitKindFunTys k = ([], k)
153 isLiftedTypeKind, isUnliftedTypeKind :: Kind -> Bool
154 isLiftedTypeKind LiftedTypeKind = True
155 isLiftedTypeKind other = False
157 isUnliftedBoxedTypeKind UnliftedTypeKind = True
158 isUnliftedBoxedTypeKind other = False
160 isUnliftedTypeKind UnliftedTypeKind = True
161 isUnliftedTypeKind UnboxedTypeKind = True
162 isUnliftedTypeKind other = False
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
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
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
191 defaultKind :: Kind -> Kind
192 -- Used when generalising: default kind '?' and '??' to '*'
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;
199 -- We want f to get type
200 -- f :: forall (a::*). a -> Bool
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
211 %************************************************************************
215 %************************************************************************
218 instance Outputable KindVar where
219 ppr (KVar uniq occ _) = ppr occ <> ifPprDebug (ppr uniq)
221 instance Outputable Kind where
224 pprParendKind :: Kind -> SDoc
225 pprParendKind k@(FunKind _ _) = parens (pprKind k)
226 pprParendKind k = pprKind k
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]