From: simonpj@microsoft.com Date: Wed, 13 May 2009 15:11:30 +0000 (+0000) Subject: Improve error reporting for kind errors (fix Trac #1633) X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=9a4ef343a46e823bcf949af8501c13cc8ca98fb1;hp=80d071f68134bf3ad89d4de0d83807e2f0ec32c0 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 --- 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 --- 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 --- 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} %* * %************************************************************************