[commit: ghc] master: Better error messages during sort checking of kind signatures (a40ee02)

[Simon Peyton Jones]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/a40ee020b53d3b397d24f4addeda78945e72292a

>---------------------------------------------------------------

commit a40ee020b53d3b397d24f4addeda78945e72292a
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Apr 25 09:37:53 2012 +0100

    Better error messages during sort checking of kind signatures
    
    Fixes Trac #6039, where we have a bogus kind signature
       data T (a :: j k) = MkT

>---------------------------------------------------------------

 compiler/typecheck/TcHsType.lhs     |   63 ++++++++++++++++++----------------
 compiler/typecheck/TcTyClsDecls.lhs |    2 +
 2 files changed, 35 insertions(+), 30 deletions(-)

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 3ba9fbb..2f8d743 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -1345,9 +1345,8 @@ tc_hs_kind k = panic ("tc_hs_kind: " ++ showPpr k)
 -- Special case for kind application
 tc_app :: HsKind Name -> [LHsKind Name] -> TcM Kind
 tc_app (HsAppTy ki1 ki2) kis = tc_app (unLoc ki1) (ki2:kis)
-tc_app (HsTyVar tc)      kis =
-  do arg_kis <- mapM tc_lhs_kind kis
-     tc_var_app tc arg_kis
+tc_app (HsTyVar tc)      kis = do { arg_kis <- mapM tc_lhs_kind kis
+                                  ; tc_var_app tc arg_kis }
 tc_app ki                _   = failWithTc (quotes (ppr ki) <+> 
                                     ptext (sLit "is not a kind constructor"))
 
@@ -1365,36 +1364,40 @@ tc_var_app name arg_kis
            _                   -> panic "tc_var_app 1" }
 
 -- General case
-tc_var_app name arg_kis = do
-  (_errs, mb_thing) <- tryTc (tcLookup name)
-  case mb_thing of
-    Just (AGlobal (ATyCon tc))
-      | isAlgTyCon tc || isTupleTyCon tc -> do
-      data_kinds <- xoptM Opt_DataKinds
-      unless data_kinds $ addErr (dataKindsErr name)
-      case isPromotableTyCon tc of
-        Just n | n == length arg_kis ->
-          return (mkTyConApp (buildPromotedTyCon tc) arg_kis)
-        Just _  -> err tc "is not fully applied"
-        Nothing -> err tc "is not promotable"
-
-    -- A lexically scoped kind variable
-    Just (ATyVar _ kind_var) -> return (mkAppTys (mkTyVarTy kind_var) arg_kis)
-
-    -- It is in scope, but not what we expected
-    Just thing -> wrongThingErr "promoted type" thing name
-
-    -- It is not in scope, but it passed the renamer: staging error
-    Nothing    -> -- ASSERT2 ( isTyConName name, ppr name )
-              do  env <- getLclEnv
-                  traceTc "tc_var_app" (ppr name $$ ppr (tcl_env env))
-                  failWithTc (ptext (sLit "Promoted kind") <+> 
-                              quotes (ppr name) <+>
-                              ptext (sLit "used in a mutually recursive group"))
+tc_var_app name arg_kis
+  = do { (_errs, mb_thing) <- tryTc (tcLookup name)
+       ;  case mb_thing of
+  	   Just (AGlobal (ATyCon tc))
+  	     | isAlgTyCon tc || isTupleTyCon tc
+  	     -> do { data_kinds <- xoptM Opt_DataKinds
+  	           ; unless data_kinds $ addErr (dataKindsErr name)
+  	     	   ; case isPromotableTyCon tc of
+  	     	       Just n | n == length arg_kis ->
+  	     	         return (mkTyConApp (buildPromotedTyCon tc) arg_kis)
+  	     	       Just _  -> err tc "is not fully applied"
+  	     	       Nothing -> err tc "is not promotable" }
+
+  	   -- A lexically scoped kind variable
+           -- Kind variables always have kind BOX, so cannot be applied to anything
+  	   Just (ATyVar _ kind_var) 
+             | null arg_kis -> return (mkAppTys (mkTyVarTy kind_var) arg_kis)
+             | otherwise    -> failWithTc (ptext (sLit "Kind variable") <+> quotes (ppr name)
+                                           <+> ptext (sLit "cannot appear in a function position"))
+
+  	   -- It is in scope, but not what we expected
+  	   Just thing -> wrongThingErr "promoted type" thing name
+
+  	   -- It is not in scope, but it passed the renamer: staging error
+  	   Nothing    
+             -> -- ASSERT2 ( isTyConName name, ppr name )
+  	        do { env <- getLclEnv
+  	           ; traceTc "tc_var_app" (ppr name $$ ppr (tcl_env env))
+  	           ; failWithTc (ptext (sLit "Promoted kind") <+> 
+  	                          quotes (ppr name) <+>
+  	                          ptext (sLit "used in a mutually recursive group")) } }
   where 
    err tc msg = failWithTc (quotes (ppr tc) <+> ptext (sLit "of kind")
                         <+> quotes (ppr (tyConKind tc)) <+> ptext (sLit msg))
-
 \end{code}
 
 %************************************************************************
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 6807fc8..93981f3 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -1234,6 +1234,7 @@ checkValidTyCon tc
   = case synTyConRhs tc of
       SynFamilyTyCon {} -> return ()
       SynonymTyCon ty   -> checkValidType syn_ctxt ty
+
   | otherwise
   = do { -- Check the context on the data decl
        ; traceTc "cvtc1" (ppr tc)
@@ -1309,6 +1310,7 @@ checkValidDataCon tc con
         ; let tc_tvs = tyConTyVars tc
 	      res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
 	      actual_res_ty = dataConOrigResTy con
+        ; traceTc "checkValidDataCon" (ppr con $$ ppr tc $$ ppr tc_tvs $$ ppr res_ty_tmpl)
 	; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs)
 				res_ty_tmpl
 				actual_res_ty))