\begin{code}
+#include "HsVersions.h"
+
module TcKind (
Kind, mkTypeKind, mkBoxedTypeKind, mkUnboxedTypeKind, mkArrowKind,
- isSubKindOf, -- Kind -> Kind -> Bool
- resultKind, -- Kind -> Kind
+ hasMoreBoxityInfo, -- Kind -> Kind -> Bool
+ resultKind, -- Kind -> Kind
TcKind, mkTcTypeKind, mkTcArrowKind, mkTcVarKind,
newKindVar, -- NF_TcM s (TcKind s)
unifyKind, -- TcKind s -> TcKind s -> TcM s ()
kindToTcKind, -- Kind -> TcKind s
- tcKindToKind -- TcKind s -> NF_TcM s Kind
+ tcDefaultKind -- TcKind s -> NF_TcM s Kind
) where
+IMP_Ubiq(){-uitous-}
+
import Kind
import TcMonad
-import Ubiq
import Unique ( Unique, pprUnique10 )
import Pretty
+import Util ( nOfThem )
\end{code}
returnNF_Tc (TcVarKind uniq box)
newKindVars :: Int -> NF_TcM s [TcKind s]
-newKindVars n = mapNF_Tc (\_->newKindVar) (take n (repeat ()))
+newKindVars n = mapNF_Tc (\ _ -> newKindVar) (nOfThem n ())
\end{code}
unify_var uniq1 box1 kind2
= tcReadMutVar box1 `thenNF_Tc` \ maybe_kind1 ->
case maybe_kind1 of
- Just kind1 -> unify_kind kind1 kind1
+ Just kind1 -> unify_kind kind1 kind2
Nothing -> unify_unbound_var uniq1 box1 kind2
unify_unbound_var uniq1 box1 kind2@(TcVarKind uniq2 box2)
kindToTcKind (ArrowKind k1 k2) = TcArrowKind (kindToTcKind k1) (kindToTcKind k2)
-tcKindToKind :: TcKind s -> NF_TcM s Kind
+-- Default all unbound kinds to TcTypeKind, and return the
+-- corresponding Kind as well.
+tcDefaultKind :: TcKind s -> NF_TcM s Kind
-tcKindToKind TcTypeKind
- = returnNF_Tc TypeKind
+tcDefaultKind TcTypeKind
+ = returnNF_Tc BoxedTypeKind
-tcKindToKind (TcArrowKind kind1 kind2)
- = tcKindToKind kind1 `thenNF_Tc` \ k1 ->
- tcKindToKind kind2 `thenNF_Tc` \ k2 ->
+tcDefaultKind (TcArrowKind kind1 kind2)
+ = tcDefaultKind kind1 `thenNF_Tc` \ k1 ->
+ tcDefaultKind kind2 `thenNF_Tc` \ k2 ->
returnNF_Tc (ArrowKind k1 k2)
-- Here's where we "default" unbound kinds to BoxedTypeKind
-tcKindToKind (TcVarKind uniq box)
+tcDefaultKind (TcVarKind uniq box)
= tcReadMutVar box `thenNF_Tc` \ maybe_kind ->
case maybe_kind of
- Nothing -> returnNF_Tc BoxedTypeKind -- Default is kind Type for unbound
- Just kind -> tcKindToKind kind
+ Just kind -> tcDefaultKind kind
+
+ Nothing -> -- Default unbound variables to kind Type
+ tcWriteMutVar box (Just TcTypeKind) `thenNF_Tc_`
+ returnNF_Tc BoxedTypeKind
zonkTcKind :: TcKind s -> NF_TcM s (TcKind s)
-- Removes variables that have now been bound.
ppr sty kind = ppr_kind sty kind
ppr_kind sty TcTypeKind
- = ppStr "*"
+ = ppChar '*'
ppr_kind sty (TcArrowKind kind1 kind2)
- = ppSep [ppr_parend sty kind1, ppStr "->", ppr_kind sty kind2]
+ = ppSep [ppr_parend sty kind1, ppPStr SLIT("->"), ppr_kind sty kind2]
ppr_kind sty (TcVarKind uniq box)
- = ppBesides [ppStr "k", pprUnique10 uniq]
+ = ppBesides [ppChar 'k', pprUnique10 uniq]
ppr_parend sty kind@(TcArrowKind _ _) = ppBesides [ppChar '(', ppr_kind sty kind, ppChar ')']
ppr_parend sty other_kind = ppr_kind sty other_kind
~~~~~~~~~~~~~~~~~~~
\begin{code}
unifyKindCtxt kind1 kind2 sty
- = ppHang (ppStr "When unifying two kinds") 4
- (ppSep [ppr sty kind1, ppStr "and", ppr sty kind2])
+ = ppHang (ppPStr SLIT("When unifying two kinds")) 4
+ (ppSep [ppr sty kind1, ppPStr SLIT("and"), ppr sty kind2])
kindOccurCheck kind1 kind2 sty
- = ppHang (ppStr "Cannot construct the infinite kind:") 4
- (ppSep [ppBesides [ppStr "`", ppr sty kind1, ppStr "'"],
- ppStr "=",
- ppBesides [ppStr "`", ppr sty kind1, ppStr "'"],
- ppStr "(\"occurs check\")"])
+ = ppHang (ppPStr SLIT("Cannot construct the infinite kind:")) 4
+ (ppSep [ppBesides [ppChar '`', ppr sty kind1, ppChar '\''],
+ ppChar '=',
+ ppBesides [ppChar '`', ppr sty kind1, ppChar '\''],
+ ppPStr SLIT("(\"occurs check\")")])
kindMisMatchErr kind1 kind2 sty
- = ppHang (ppStr "Couldn't match the kind") 4
- (ppSep [ppBesides [ppStr "`", ppr sty kind1, ppStr "'"],
- ppStr "against",
- ppBesides [ppStr "`", ppr sty kind1, ppStr "'"]
+ = ppHang (ppPStr SLIT("Couldn't match the kind")) 4
+ (ppSep [ppBesides [ppChar '`', ppr sty kind1, ppChar '\''],
+ ppPStr SLIT("against"),
+ ppBesides [ppChar '`', ppr sty kind2, ppChar '\'']
])
\end{code}