[project @ 2003-11-13 15:02:53 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcHsType.lhs

diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs
index 9a73ff3..473166d 100644 (file)
--- a/ghc/compiler/typecheck/TcHsType.lhs
+++ b/ghc/compiler/typecheck/TcHsType.lhs
@@ -32,26 +32,23 @@ import TcEnv                ( tcExtendTyVarEnv, tcExtendTyVarKindEnv,
                          TyThing(..), TcTyThing(..), 
                          getInLocalScope
                        )
-import TcMType         ( newKindVar, tcInstType, newMutTyVar,
+import TcMType         ( newKindVar, newOpenTypeKind, tcInstType, newMutTyVar, 
                          zonkTcType, zonkTcKindToKind,
                          checkValidType, UserTypeCtxt(..), pprHsSigCtxt
                        )
-import TcUnify         ( unifyKind, unifyFunKind, unifyTypeKind )
+import TcUnify         ( unifyKind, unifyFunKind )
 import TcType          ( Type, PredType(..), ThetaType, TyVarDetails(..),
                          TcTyVar, TcKind, TcThetaType, TcTauType,
-                         mkTyVarTy, mkTyVarTys, mkFunTy, 
+                         mkTyVarTy, mkTyVarTys, mkFunTy, isTypeKind,
                          mkForAllTys, mkFunTys, tcEqType, isPredTy,
                          mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys, 
                          liftedTypeKind, unliftedTypeKind, eqKind,
-                         tcSplitFunTy_maybe, tcSplitForAllTys, tcSplitSigmaTy
-                       )
-import PprType         ( pprKind, pprThetaArrow )
+                         tcSplitFunTy_maybe, tcSplitForAllTys, pprKind )
 import qualified Type  ( splitFunTys )
 import Inst            ( Inst, InstOrigin(..), newMethod, instToId )
 
 import Id              ( mkLocalId, idName, idType )
 import Var             ( TyVar, mkTyVar, tyVarKind )
-import ErrUtils                ( Message )
 import TyCon           ( TyCon, tyConKind )
 import Class           ( classTyCon )
 import Name            ( Name )
@@ -204,15 +201,22 @@ tcHsKindedContext hs_theta = mappM dsHsPred hs_theta
 \begin{code}
 ---------------------------
 kcLiftedType :: HsType Name -> TcM (HsType Name)
-       -- The type ty must be a *lifted* *type*
+-- The type ty must be a *lifted* *type*
 kcLiftedType ty = kcCheckHsType ty liftedTypeKind
     
 ---------------------------
 kcTypeType :: HsType Name -> TcM (HsType Name)
-       -- The type ty must be a *type*, but it can be lifted or unlifted
+-- The type ty must be a *type*, but it can be lifted or unlifted
+-- Be sure to use checkExpectedKind, rather than simply unifying 
+-- with (Type bx), because it gives better error messages
 kcTypeType ty
   = kcHsType ty                        `thenM` \ (ty', kind) ->
-    unifyTypeKind kind         `thenM_`
+    if isTypeKind kind then
+       return ty'
+    else
+    newOpenTypeKind                            `thenM` \ type_kind ->
+    traceTc (text "kcTypeType" $$ nest 2 (ppr ty $$ ppr ty' $$ ppr kind $$ ppr type_kind)) `thenM_`
+    checkExpectedKind (ppr ty) kind type_kind  `thenM_`
     returnM ty'
 
 ---------------------------
@@ -292,14 +296,21 @@ kcHsType (HsPredTy pred)
   = kcHsPred pred              `thenM` \ pred' ->
     returnM (HsPredTy pred', liftedTypeKind)
 
-kcHsType (HsForAllTy (Just tv_names) context ty)
+kcHsType (HsForAllTy exp tv_names context ty)
   = kcHsTyVars tv_names                $ \ tv_names' ->
     kcHsContext context                `thenM` \ ctxt' ->
     kcLiftedType ty            `thenM` \ ty' ->
-       -- The body of a forall must be of kind *
-       -- In principle, I suppose, we could allow unlifted types,
-       -- but it seems simpler to stick to lifted types for now.
-    returnM (HsForAllTy (Just tv_names') ctxt' ty', liftedTypeKind)
+       -- The body of a forall must be a type, but in principle
+       -- there's no reason to prohibit *unlifted* types.
+       -- In fact, GHC can itself construct a function with an
+       -- unboxed tuple inside a for-all (via CPR analyis; see 
+       -- typecheck/should_compile/tc170)
+       --
+       -- Still, that's only for internal interfaces, which aren't
+       -- kind-checked, and it's a bit inconvenient to use kcTypeType
+       -- here (because it doesn't return the result kind), so I'm 
+       -- leaving it as lifted types for now.
+    returnM (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind)
 
 ---------------------------
 kcApps :: TcKind               -- Function kind
@@ -483,7 +494,7 @@ dsHsType (HsPredTy pred)
   = dsHsPred pred      `thenM` \ pred' ->
     returnM (mkPredTy pred')
 
-dsHsType full_ty@(HsForAllTy (Just tv_names) ctxt ty)
+dsHsType full_ty@(HsForAllTy exp tv_names ctxt ty)
   = tcTyVarBndrs tv_names              $ \ tyvars ->
     mappM dsHsPred ctxt                        `thenM` \ theta ->
     dsHsType ty                                `thenM` \ tau ->