2 #include "HsVersions.h"
6 Kind, mkTypeKind, mkBoxedTypeKind, mkUnboxedTypeKind, mkArrowKind,
7 hasMoreBoxityInfo, -- Kind -> Kind -> Bool
8 resultKind, -- Kind -> Kind
10 TcKind, mkTcTypeKind, mkTcArrowKind, mkTcVarKind,
11 newKindVar, -- NF_TcM s (TcKind s)
12 newKindVars, -- Int -> NF_TcM s [TcKind s]
13 unifyKind, -- TcKind s -> TcKind s -> TcM s ()
15 kindToTcKind, -- Kind -> TcKind s
16 tcDefaultKind -- TcKind s -> NF_TcM s Kind
22 import TcMonad hiding ( rnMtoTcM )
24 import Unique ( Unique, pprUnique10 )
26 import Util ( nOfThem )
31 data TcKind s -- Used for kind inference
33 | TcArrowKind (TcKind s) (TcKind s)
34 | TcVarKind Unique (MutableVar s (Maybe (TcKind s)))
36 mkTcTypeKind = TcTypeKind
37 mkTcArrowKind = TcArrowKind
38 mkTcVarKind = TcVarKind
40 newKindVar :: NF_TcM s (TcKind s)
41 newKindVar = tcGetUnique `thenNF_Tc` \ uniq ->
42 tcNewMutVar Nothing `thenNF_Tc` \ box ->
43 returnNF_Tc (TcVarKind uniq box)
45 newKindVars :: Int -> NF_TcM s [TcKind s]
46 newKindVars n = mapNF_Tc (\ _ -> newKindVar) (nOfThem n ())
53 unifyKind :: TcKind s -> TcKind s -> TcM s ()
55 = tcAddErrCtxtM ctxt (unify_kind kind1 kind2)
57 ctxt = zonkTcKind kind1 `thenNF_Tc` \ kind1' ->
58 zonkTcKind kind2 `thenNF_Tc` \ kind2' ->
59 returnNF_Tc (unifyKindCtxt kind1' kind2')
62 unify_kind TcTypeKind TcTypeKind = returnTc ()
64 unify_kind (TcArrowKind fun1 arg1)
65 (TcArrowKind fun2 arg2)
67 = unify_kind fun1 fun2 `thenTc_`
70 unify_kind (TcVarKind uniq box) kind = unify_var uniq box kind
71 unify_kind kind (TcVarKind uniq box) = unify_var uniq box kind
73 unify_kind kind1 kind2
74 = failTc (kindMisMatchErr kind1 kind2)
77 We could probably do some "shorting out" in unifyVarKind, but
78 I'm not convinced it would save time, and it's a little tricky to get right.
81 unify_var uniq1 box1 kind2
82 = tcReadMutVar box1 `thenNF_Tc` \ maybe_kind1 ->
84 Just kind1 -> unify_kind kind1 kind2
85 Nothing -> unify_unbound_var uniq1 box1 kind2
87 unify_unbound_var uniq1 box1 kind2@(TcVarKind uniq2 box2)
88 | uniq1 == uniq2 -- Binding to self is a no-op
91 | otherwise -- Distinct variables
92 = tcReadMutVar box2 `thenNF_Tc` \ maybe_kind2 ->
94 Just kind2' -> unify_unbound_var uniq1 box1 kind2'
95 Nothing -> tcWriteMutVar box1 (Just kind2) `thenNF_Tc_`
96 -- No need for occurs check here
99 unify_unbound_var uniq1 box1 non_var_kind2
100 = occur_check non_var_kind2 `thenTc_`
101 tcWriteMutVar box1 (Just non_var_kind2) `thenNF_Tc_`
104 occur_check TcTypeKind = returnTc ()
105 occur_check (TcArrowKind fun arg) = occur_check fun `thenTc_` occur_check arg
106 occur_check kind1@(TcVarKind uniq' box)
108 = failTc (kindOccurCheck kind1 non_var_kind2)
110 | otherwise -- Different variable
111 = tcReadMutVar box `thenNF_Tc` \ maybe_kind ->
113 Nothing -> returnTc ()
114 Just kind -> occur_check kind
117 The "occurs check" is necessary to catch situation like
124 Coercions between TcKind and Kind
127 kindToTcKind :: Kind -> TcKind s
128 kindToTcKind TypeKind = TcTypeKind
129 kindToTcKind BoxedTypeKind = TcTypeKind
130 kindToTcKind UnboxedTypeKind = TcTypeKind
131 kindToTcKind (ArrowKind k1 k2) = TcArrowKind (kindToTcKind k1) (kindToTcKind k2)
134 -- Default all unbound kinds to TcTypeKind, and return the
135 -- corresponding Kind as well.
136 tcDefaultKind :: TcKind s -> NF_TcM s Kind
138 tcDefaultKind TcTypeKind
139 = returnNF_Tc BoxedTypeKind
141 tcDefaultKind (TcArrowKind kind1 kind2)
142 = tcDefaultKind kind1 `thenNF_Tc` \ k1 ->
143 tcDefaultKind kind2 `thenNF_Tc` \ k2 ->
144 returnNF_Tc (ArrowKind k1 k2)
146 -- Here's where we "default" unbound kinds to BoxedTypeKind
147 tcDefaultKind (TcVarKind uniq box)
148 = tcReadMutVar box `thenNF_Tc` \ maybe_kind ->
150 Just kind -> tcDefaultKind kind
152 Nothing -> -- Default unbound variables to kind Type
153 tcWriteMutVar box (Just TcTypeKind) `thenNF_Tc_`
154 returnNF_Tc BoxedTypeKind
156 zonkTcKind :: TcKind s -> NF_TcM s (TcKind s)
157 -- Removes variables that have now been bound.
158 -- Mainly used just before an error message is printed,
159 -- so that we don't need to follow through bound variables
160 -- during error message construction.
162 zonkTcKind TcTypeKind = returnNF_Tc TcTypeKind
164 zonkTcKind (TcArrowKind kind1 kind2)
165 = zonkTcKind kind1 `thenNF_Tc` \ k1 ->
166 zonkTcKind kind2 `thenNF_Tc` \ k2 ->
167 returnNF_Tc (TcArrowKind k1 k2)
169 zonkTcKind kind@(TcVarKind uniq box)
170 = tcReadMutVar box `thenNF_Tc` \ maybe_kind ->
172 Nothing -> returnNF_Tc kind
173 Just kind' -> zonkTcKind kind'
178 instance Outputable (TcKind s) where
179 ppr sty kind = ppr_kind sty kind
181 ppr_kind sty TcTypeKind
183 ppr_kind sty (TcArrowKind kind1 kind2)
184 = ppSep [ppr_parend sty kind1, ppStr "->", ppr_kind sty kind2]
185 ppr_kind sty (TcVarKind uniq box)
186 = ppBesides [ppStr "k", pprUnique10 uniq]
188 ppr_parend sty kind@(TcArrowKind _ _) = ppBesides [ppChar '(', ppr_kind sty kind, ppChar ')']
189 ppr_parend sty other_kind = ppr_kind sty other_kind
197 unifyKindCtxt kind1 kind2 sty
198 = ppHang (ppStr "When unifying two kinds") 4
199 (ppSep [ppr sty kind1, ppStr "and", ppr sty kind2])
201 kindOccurCheck kind1 kind2 sty
202 = ppHang (ppStr "Cannot construct the infinite kind:") 4
203 (ppSep [ppBesides [ppStr "`", ppr sty kind1, ppStr "'"],
205 ppBesides [ppStr "`", ppr sty kind1, ppStr "'"],
206 ppStr "(\"occurs check\")"])
208 kindMisMatchErr kind1 kind2 sty
209 = ppHang (ppStr "Couldn't match the kind") 4
210 (ppSep [ppBesides [ppStr "`", ppr sty kind1, ppStr "'"],
212 ppBesides [ppStr "`", ppr sty kind2, ppStr "'"]