Improve error reporting for kind errors (fix Trac #1633)

A long-standing improvement to the error message for kinds. Now instead of
    Expected kind `* -> *', but `Int' has kind `*'
we get
    The first argument of `T' should have kind `* -> *',
    but `Int' has kind `*'

Ha!

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 2482da2..b7cbc1e 100644 (file)
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -17,7 +17,7 @@ module TcHsType (
                -- Typechecking kinded types
        tcHsKindedContext, tcHsKindedType, tcHsBangType,
        tcTyVarBndrs, dsHsType, tcLHsConResTy,
-       tcDataKindSig,
+       tcDataKindSig, ExpKind(..), EkCtxt(..),
 
                -- Pattern type signatures
        tcHsPatSigType, tcPatSig
@@ -232,20 +232,20 @@ tcHsKindedContext hs_theta = addLocM (mapM dsHsLPred) hs_theta
 ---------------------------
 kcLiftedType :: LHsType Name -> TcM (LHsType Name)
 -- The type ty must be a *lifted* *type*
-kcLiftedType ty = kc_check_lhs_type ty liftedTypeKind
+kcLiftedType ty = kc_check_lhs_type ty ekLifted
     
 ---------------------------
 kcTypeType :: LHsType Name -> TcM (LHsType Name)
 -- The type ty must be a *type*, but it can be lifted or 
 -- unlifted or an unboxed tuple.
-kcTypeType ty = kc_check_lhs_type ty openTypeKind
+kcTypeType ty = kc_check_lhs_type ty ekOpen
 
 ---------------------------
-kcCheckLHsType :: LHsType Name -> TcKind -> TcM (LHsType Name)
+kcCheckLHsType :: LHsType Name -> ExpKind -> TcM (LHsType Name)
 kcCheckLHsType ty kind = addKcTypeCtxt ty $ kc_check_lhs_type ty kind
 
 
-kc_check_lhs_type :: LHsType Name -> TcKind -> TcM (LHsType Name)
+kc_check_lhs_type :: LHsType Name -> ExpKind -> TcM (LHsType Name)
 -- Check that the type has the specified kind
 -- Be sure to use checkExpectedKind, rather than simply unifying 
 -- with OpenTypeKind, because it gives better error messages
@@ -254,7 +254,7 @@ kc_check_lhs_type (L span ty) exp_kind
     do { ty' <- kc_check_hs_type ty exp_kind
        ; return (L span ty') }
 
-kc_check_lhs_types :: [(LHsType Name,TcKind)] -> TcM [LHsType Name]
+kc_check_lhs_types :: [(LHsType Name, ExpKind)] -> TcM [LHsType Name]
 kc_check_lhs_types tys_w_kinds
   = mapM kc_arg tys_w_kinds
   where
@@ -262,7 +262,7 @@ kc_check_lhs_types tys_w_kinds
 
 
 ---------------------------
-kc_check_hs_type :: HsType Name -> TcKind -> TcM (HsType Name)
+kc_check_hs_type :: HsType Name -> ExpKind -> TcM (HsType Name)
 
 -- First some special cases for better error messages 
 -- when we know the expected kind
@@ -345,7 +345,7 @@ kc_hs_type (HsNumTy n)
    = return (HsNumTy n, liftedTypeKind)
 
 kc_hs_type (HsKindSig ty k) = do
-    ty' <- kc_check_lhs_type ty k
+    ty' <- kc_check_lhs_type ty (EK k EkKindSig)
     return (HsKindSig ty' k, k)
 
 kc_hs_type (HsTupleTy Boxed tys) = do
@@ -357,7 +357,7 @@ kc_hs_type (HsTupleTy Unboxed tys) = do
     return (HsTupleTy Unboxed tys', ubxTupleKind)
 
 kc_hs_type (HsFunTy ty1 ty2) = do
-    ty1' <- kc_check_lhs_type ty1 argTypeKind
+    ty1' <- kc_check_lhs_type ty1 (EK argTypeKind EkUnk)
     ty2' <- kcTypeType ty2
     return (HsFunTy ty1' ty2', liftedTypeKind)
 
@@ -414,16 +414,16 @@ kcApps :: Outputable a
        -> [LHsType Name]               -- Arg types
        -> TcM ([LHsType Name], TcKind) -- Kind-checked args
 kcApps the_fun fun_kind args
-  = do { (args_w_kinds, res_kind) <- splitFunKind the_fun fun_kind args
+  = do { (args_w_kinds, res_kind) <- splitFunKind (ppr the_fun) 1 fun_kind args
        ; args' <- kc_check_lhs_types args_w_kinds
        ; return (args', res_kind) }
 
 kcCheckApps :: Outputable a => a -> TcKind -> [LHsType Name]
            -> HsType Name     -- The type being checked (for err messages only)
-           -> TcKind          -- Expected kind
+           -> ExpKind         -- Expected kind
            -> TcM [LHsType Name]
 kcCheckApps the_fun fun_kind args ty exp_kind
-  = do { (args_w_kinds, res_kind) <- splitFunKind the_fun fun_kind args
+  = do { (args_w_kinds, res_kind) <- splitFunKind (ppr the_fun) 1 fun_kind args
        ; checkExpectedKind ty res_kind exp_kind
                     -- Check the result kind *before* checking argument kinds
             -- This improves error message; Trac #2994
@@ -445,16 +445,16 @@ mkHsAppTys fun_ty (arg_ty:arg_tys)
                                                -- never used 
 
 ---------------------------
-splitFunKind :: Outputable a => a -> TcKind -> [b] -> TcM ([(b,TcKind)], TcKind)
-splitFunKind _       fk [] = return ([], fk)
-splitFunKind the_fun fk (arg:args)
+splitFunKind :: SDoc -> Int -> TcKind -> [b] -> TcM ([(b,ExpKind)], TcKind)
+splitFunKind _       _      fk [] = return ([], fk)
+splitFunKind the_fun arg_no fk (arg:args)
   = do { mb_fk <- unifyFunKind fk
        ; case mb_fk of
             Nothing       -> failWithTc too_many_args 
-            Just (ak,fk') -> do { (aks, rk) <- splitFunKind the_fun fk' args
-                                ; return ((arg,ak):aks, rk) } }
+            Just (ak,fk') -> do { (aks, rk) <- splitFunKind the_fun (arg_no+1) fk' args
+                                ; return ((arg, EK ak (EkArg the_fun arg_no)):aks, rk) } }
   where
-    too_many_args = quotes (ppr the_fun) <+>
+    too_many_args = quotes the_fun <+>
                    ptext (sLit "is applied to too many type arguments")
 
 ---------------------------
@@ -467,7 +467,7 @@ kcHsLPred = wrapLocM kcHsPred
 kcHsPred :: HsPred Name -> TcM (HsPred Name)
 kcHsPred pred = do     -- Checks that the result is of kind liftedType
     (pred', kind) <- kc_pred pred
-    checkExpectedKind pred kind liftedTypeKind
+    checkExpectedKind pred kind ekLifted
     return pred'
     
 ---------------------------
@@ -488,7 +488,7 @@ kc_pred (HsEqualP ty1 ty2)
 --       ; checkExpectedKind ty1 kind1 liftedTypeKind
        ; (ty2', kind2) <- kc_lhs_type ty2
 --       ; checkExpectedKind ty2 kind2 liftedTypeKind
-       ; checkExpectedKind ty2 kind2 kind1
+       ; checkExpectedKind ty2 kind2 (EK kind1 EkEqPred)
        ; return (HsEqualP ty1' ty2', liftedTypeKind)
        }
 
@@ -913,6 +913,94 @@ tcPatSig ctxt sig res_ty
 
 
 %************************************************************************
+%*                                                                      *
+        Checking kinds
+%*                                                                      *
+%************************************************************************
+
+We would like to get a decent error message from
+  (a) Under-applied type constructors
+             f :: (Maybe, Maybe)
+  (b) Over-applied type constructors
+             f :: Int x -> Int x
+
+\begin{code}
+-- The ExpKind datatype means "expected kind" and contains 
+-- some info about just why that kind is expected, to improve
+-- the error message on a mis-match
+data ExpKind = EK TcKind EkCtxt
+data EkCtxt  = EkUnk           -- Unknown context
+            | EkEqPred         -- Second argument of an equality predicate
+            | EkKindSig        -- Kind signature
+            | EkArg SDoc Int   -- Function, arg posn, expected kind
+
+
+ekLifted, ekOpen :: ExpKind
+ekLifted = EK liftedTypeKind EkUnk
+ekOpen   = EK openTypeKind   EkUnk
+
+checkExpectedKind :: Outputable a => a -> TcKind -> ExpKind -> TcM ()
+-- A fancy wrapper for 'unifyKind', which tries
+-- to give decent error messages.
+--      (checkExpectedKind ty act_kind exp_kind)
+-- checks that the actual kind act_kind is compatible
+--      with the expected kind exp_kind
+-- The first argument, ty, is used only in the error message generation
+checkExpectedKind ty act_kind (EK exp_kind ek_ctxt)
+  | act_kind `isSubKind` exp_kind -- Short cut for a very common case
+  = return ()
+  | otherwise = do
+    (_errs, mb_r) <- tryTc (unifyKind exp_kind act_kind)
+    case mb_r of
+        Just _  -> return ()  -- Unification succeeded
+        Nothing -> do
+
+        -- So there's definitely an error
+        -- Now to find out what sort
+           exp_kind <- zonkTcKind exp_kind
+           act_kind <- zonkTcKind act_kind
+
+           env0 <- tcInitTidyEnv
+           let (exp_as, _) = splitKindFunTys exp_kind
+               (act_as, _) = splitKindFunTys act_kind
+               n_exp_as = length exp_as
+               n_act_as = length act_as
+
+               (env1, tidy_exp_kind) = tidyKind env0 exp_kind
+               (env2, tidy_act_kind) = tidyKind env1 act_kind
+
+               err | n_exp_as < n_act_as     -- E.g. [Maybe]
+                   = quotes (ppr ty) <+> ptext (sLit "is not applied to enough type arguments")
+
+                     -- Now n_exp_as >= n_act_as. In the next two cases,
+                     -- n_exp_as == 0, and hence so is n_act_as
+                   | isLiftedTypeKind exp_kind && isUnliftedTypeKind act_kind
+                   = ptext (sLit "Expecting a lifted type, but") <+> quotes (ppr ty)
+                       <+> ptext (sLit "is unlifted")
+
+                   | isUnliftedTypeKind exp_kind && isLiftedTypeKind act_kind
+                   = ptext (sLit "Expecting an unlifted type, but") <+> quotes (ppr ty)
+                       <+> ptext (sLit "is lifted")
+
+                   | otherwise               -- E.g. Monad [Int]
+                   = ptext (sLit "Kind mis-match")
+
+               more_info = sep [ expected_herald ek_ctxt <+> ptext (sLit "kind") 
+                                    <+> quotes (pprKind tidy_exp_kind) <> comma,
+                                 ptext (sLit "but") <+> quotes (ppr ty) <+>
+                                     ptext (sLit "has kind") <+> quotes (pprKind tidy_act_kind)]
+
+               expected_herald EkUnk     = ptext (sLit "Expected")
+               expected_herald EkKindSig = ptext (sLit "An enclosing kind signature specified")
+               expected_herald EkEqPred  = ptext (sLit "The left argument of the equality predicate had")
+               expected_herald (EkArg fun arg_no)
+                = ptext (sLit "The") <+> speakNth arg_no <+> ptext (sLit "argument of")
+                  <+> quotes fun <+> ptext (sLit ("should have"))
+
+           failWithTcM (env2, err $$ more_info)
+\end{code}
+
+%************************************************************************
 %*                                                                     *
                Scoped type variables
 %*                                                                     *

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 3177b66..71e8659 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -275,7 +275,8 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
        ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
 
        ; -- (1) kind check the right-hand side of the type equation
-       ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) resKind
+       ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
+                         -- ToDo: the ExpKind could be better
 
          -- we need the exact same number of type parameters as the family
          -- declaration 
@@ -378,7 +379,8 @@ kcIdxTyPats :: TyClDecl Name
            -> TcM a
 kcIdxTyPats decl thing_inside
   = kcHsTyVars (tcdTyVars decl) $ \tvs -> 
-    do { fam_tycon <- tcLookupLocatedTyCon (tcdLName decl)
+    do { let tc_name = tcdLName decl
+       ; fam_tycon <- tcLookupLocatedTyCon tc_name
        ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
             ; hs_typats        = fromJust $ tcdTyPats decl }
 
@@ -388,10 +390,11 @@ kcIdxTyPats decl thing_inside
 
          -- type functions can have a higher-kinded result
        ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
-       ; typats <- zipWithM kcCheckLHsType hs_typats kinds
+       ; typats <- zipWithM kcCheckLHsType hs_typats 
+                                   [ EK kind (EkArg (ppr tc_name) n) 
+                            | (kind,n) <- kinds `zip` [1..]]
        ; thing_inside tvs typats resultKind fam_tycon
        }
-  where
 \end{code}
 
 

diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index 56652c7..e5e16fc 100644 (file)
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -14,7 +14,6 @@ module TcUnify (
         -- Various unifications
   unifyType, unifyTypeList, unifyTheta,
   unifyKind, unifyKinds, unifyFunKind,
-  checkExpectedKind,
   preSubType, boxyMatchTypes,
 
   --------------------------------
@@ -1921,75 +1920,6 @@ unifyFunKind _                         = return Nothing
 
 %************************************************************************
 %*                                                                      *
-        Checking kinds
-%*                                                                      *
-%************************************************************************
-
----------------------------
--- We would like to get a decent error message from
---   (a) Under-applied type constructors
---              f :: (Maybe, Maybe)
---   (b) Over-applied type constructors
---              f :: Int x -> Int x
---
-
-\begin{code}
-checkExpectedKind :: Outputable a => a -> TcKind -> TcKind -> TcM ()
--- A fancy wrapper for 'unifyKind', which tries
--- to give decent error messages.
---      (checkExpectedKind ty act_kind exp_kind)
--- checks that the actual kind act_kind is compatible
---      with the expected kind exp_kind
--- The first argument, ty, is used only in the error message generation
-checkExpectedKind ty act_kind exp_kind
-  | act_kind `isSubKind` exp_kind -- Short cut for a very common case
-  = return ()
-  | otherwise = do
-    (_errs, mb_r) <- tryTc (unifyKind exp_kind act_kind)
-    case mb_r of
-        Just _  -> return ()  -- Unification succeeded
-        Nothing -> do
-
-        -- So there's definitely an error
-        -- Now to find out what sort
-           exp_kind <- zonkTcKind exp_kind
-           act_kind <- zonkTcKind act_kind
-
-           env0 <- tcInitTidyEnv
-           let (exp_as, _) = splitKindFunTys exp_kind
-               (act_as, _) = splitKindFunTys act_kind
-               n_exp_as = length exp_as
-               n_act_as = length act_as
-
-               (env1, tidy_exp_kind) = tidyKind env0 exp_kind
-               (env2, tidy_act_kind) = tidyKind env1 act_kind
-
-               err | n_exp_as < n_act_as     -- E.g. [Maybe]
-                   = quotes (ppr ty) <+> ptext (sLit "is not applied to enough type arguments")
-
-                     -- Now n_exp_as >= n_act_as. In the next two cases,
-                     -- n_exp_as == 0, and hence so is n_act_as
-                   | isLiftedTypeKind exp_kind && isUnliftedTypeKind act_kind
-                   = ptext (sLit "Expecting a lifted type, but") <+> quotes (ppr ty)
-                       <+> ptext (sLit "is unlifted")
-
-                   | isUnliftedTypeKind exp_kind && isLiftedTypeKind act_kind
-                   = ptext (sLit "Expecting an unlifted type, but") <+> quotes (ppr ty)
-                       <+> ptext (sLit "is lifted")
-
-                   | otherwise               -- E.g. Monad [Int]
-                   = ptext (sLit "Kind mis-match")
-
-               more_info = sep [ ptext (sLit "Expected kind") <+>
-                                     quotes (pprKind tidy_exp_kind) <> comma,
-                                 ptext (sLit "but") <+> quotes (ppr ty) <+>
-                                     ptext (sLit "has kind") <+> quotes (pprKind tidy_act_kind)]
-
-           failWithTcM (env2, err $$ more_info)
-\end{code}
-
-%************************************************************************
-%*                                                                      *
 \subsection{Checking signature type variables}
 %*                                                                      *
 %************************************************************************