From bd0bd647062bad646dd8b2d0f85cce67c2079907 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 4 Feb 2009 15:07:36 +0000 Subject: [PATCH] Improve error reports for kind checking (Trac #2994) I followed the suggestion in Trac #2994, which took longer than I expected. As usual I did a bit of tidying up at the same time, and improved a few other error reports. --- compiler/typecheck/TcHsType.lhs | 175 ++++++++++++++++++++++++----------- compiler/typecheck/TcRnDriver.lhs | 2 +- compiler/typecheck/TcSplice.lhs | 2 +- compiler/typecheck/TcTyClsDecls.lhs | 23 ++--- 4 files changed, 133 insertions(+), 69 deletions(-) diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index e158763..2482da2 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -12,7 +12,7 @@ module TcHsType ( -- Kind checking kcHsTyVars, kcHsSigType, kcHsLiftedSigType, - kcCheckHsType, kcHsContext, kcHsType, + kcLHsType, kcCheckLHsType, kcHsContext, -- Typechecking kinded types tcHsKindedContext, tcHsKindedType, tcHsBangType, @@ -175,7 +175,7 @@ tc_hs_deriv :: [LHsTyVarBndr Name] -> HsType Name tc_hs_deriv tv_names (HsPredTy (HsClassP cls_name hs_tys)) = kcHsTyVars tv_names $ \ tv_names' -> do { cls_kind <- kcClass cls_name - ; (tys, _res_kind) <- kcApps cls_kind (ppr cls_name) hs_tys + ; (tys, _res_kind) <- kcApps cls_name cls_kind hs_tys ; tcTyVarBndrs tv_names' $ \ tyvars -> do { arg_tys <- dsHsTypes tys ; cls <- tcLookupClass cls_name @@ -198,8 +198,8 @@ tc_hs_deriv _ other \begin{code} kcHsSigType, kcHsLiftedSigType :: LHsType Name -> TcM (LHsType Name) -- Used for type signatures -kcHsSigType ty = kcTypeType ty -kcHsLiftedSigType ty = kcLiftedType ty +kcHsSigType ty = addKcTypeCtxt ty $ kcTypeType ty +kcHsLiftedSigType ty = addKcTypeCtxt ty $ kcLiftedType ty tcHsKindedType :: LHsType Name -> TcM Type -- Don't do kind checking, nor validity checking. @@ -232,39 +232,64 @@ tcHsKindedContext hs_theta = addLocM (mapM dsHsLPred) hs_theta --------------------------- kcLiftedType :: LHsType Name -> TcM (LHsType Name) -- The type ty must be a *lifted* *type* -kcLiftedType ty = kcCheckHsType ty liftedTypeKind +kcLiftedType ty = kc_check_lhs_type ty liftedTypeKind --------------------------- 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 = kcCheckHsType ty openTypeKind +kcTypeType ty = kc_check_lhs_type ty openTypeKind --------------------------- -kcCheckHsType :: LHsType Name -> TcKind -> TcM (LHsType Name) +kcCheckLHsType :: LHsType Name -> TcKind -> TcM (LHsType Name) +kcCheckLHsType ty kind = addKcTypeCtxt ty $ kc_check_lhs_type ty kind + + +kc_check_lhs_type :: LHsType Name -> TcKind -> 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 -kcCheckHsType (L span ty) exp_kind - = setSrcSpan span $ - do { (ty', act_kind) <- add_ctxt ty (kc_hs_type ty) +kc_check_lhs_type (L span ty) exp_kind + = setSrcSpan span $ + 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 tys_w_kinds + = mapM kc_arg tys_w_kinds + where + kc_arg (arg, arg_kind) = kc_check_lhs_type arg arg_kind + + +--------------------------- +kc_check_hs_type :: HsType Name -> TcKind -> TcM (HsType Name) + +-- First some special cases for better error messages +-- when we know the expected kind +kc_check_hs_type (HsParTy ty) exp_kind + = do { ty' <- kc_check_lhs_type ty exp_kind; return (HsParTy ty') } + +kc_check_hs_type ty@(HsAppTy ty1 ty2) exp_kind + = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 ty2 + ; (fun_ty', fun_kind) <- kc_lhs_type fun_ty + ; arg_tys' <- kcCheckApps fun_ty fun_kind arg_tys ty exp_kind + ; return (mkHsAppTys fun_ty' arg_tys') } + +kc_check_hs_type ty@(HsPredTy (HsClassP cls tys)) exp_kind + = do { cls_kind <- kcClass cls + ; tys' <- kcCheckApps cls cls_kind tys ty exp_kind + ; return (HsPredTy (HsClassP cls tys')) } + +-- This is the general case: infer the kind and compare +kc_check_hs_type ty exp_kind + = do { (ty', act_kind) <- kc_hs_type ty -- Add the context round the inner check only -- because checkExpectedKind already mentions -- 'ty' by name in any error message ; checkExpectedKind (strip ty) act_kind exp_kind - ; return (L span ty') } + ; return ty' } where - -- Wrap a context around only if we want to show that contexts. - add_ctxt (HsPredTy _) thing = thing - -- Omit invisble ones and ones user's won't grok (HsPred p). - add_ctxt (HsForAllTy _ _ (L _ []) _) thing = thing - -- Omit wrapping if the theta-part is empty - -- Reason: the recursive call to kcLiftedType, in the ForAllTy - -- case of kc_hs_type, will do the wrapping instead - -- and we don't want to duplicate - add_ctxt other_ty thing = addErrCtxt (typeCtxt other_ty) thing - -- We infer the kind of the type, and then complain if it's -- not right. But we don't want to complain about -- (ty) or !(ty) or forall a. ty @@ -273,14 +298,23 @@ kcCheckHsType (L span ty) exp_kind strip (HsBangTy _ (L _ ty)) = strip ty strip (HsForAllTy _ _ _ (L _ ty)) = strip ty strip ty = ty + \end{code} Here comes the main function \begin{code} -kcHsType :: LHsType Name -> TcM (LHsType Name, TcKind) -kcHsType ty = wrapLocFstM kc_hs_type ty --- kcHsType *returns* the kind of the type, rather than taking an expected +kcLHsType :: LHsType Name -> TcM (LHsType Name, TcKind) +-- Called from outside: set the context +kcLHsType ty = addKcTypeCtxt ty (kc_lhs_type ty) + +kc_lhs_type :: LHsType Name -> TcM (LHsType Name, TcKind) +kc_lhs_type (L span ty) + = setSrcSpan span $ + do { (ty', kind) <- kc_hs_type ty + ; return (L span ty', kind) } + +-- kc_hs_type *returns* the kind of the type, rather than taking an expected -- kind as argument as tcExpr does. -- Reasons: -- (a) the kind of (->) is @@ -292,7 +326,7 @@ kcHsType ty = wrapLocFstM kc_hs_type ty kc_hs_type :: HsType Name -> TcM (HsType Name, TcKind) kc_hs_type (HsParTy ty) = do - (ty', kind) <- kcHsType ty + (ty', kind) <- kc_lhs_type ty return (HsParTy ty', kind) kc_hs_type (HsTyVar name) = do @@ -311,7 +345,7 @@ kc_hs_type (HsNumTy n) = return (HsNumTy n, liftedTypeKind) kc_hs_type (HsKindSig ty k) = do - ty' <- kcCheckHsType ty k + ty' <- kc_check_lhs_type ty k return (HsKindSig ty' k, k) kc_hs_type (HsTupleTy Boxed tys) = do @@ -323,26 +357,21 @@ kc_hs_type (HsTupleTy Unboxed tys) = do return (HsTupleTy Unboxed tys', ubxTupleKind) kc_hs_type (HsFunTy ty1 ty2) = do - ty1' <- kcCheckHsType ty1 argTypeKind + ty1' <- kc_check_lhs_type ty1 argTypeKind ty2' <- kcTypeType ty2 return (HsFunTy ty1' ty2', liftedTypeKind) kc_hs_type (HsOpTy ty1 op ty2) = do op_kind <- addLocM kcTyVar op - ([ty1',ty2'], res_kind) <- kcApps op_kind (ppr op) [ty1,ty2] + ([ty1',ty2'], res_kind) <- kcApps op op_kind [ty1,ty2] return (HsOpTy ty1' op ty2', res_kind) kc_hs_type (HsAppTy ty1 ty2) = do - (fun_ty', fun_kind) <- kcHsType fun_ty - ((arg_ty':arg_tys'), res_kind) <- kcApps fun_kind (ppr fun_ty) arg_tys - return (foldl mk_app (HsAppTy fun_ty' arg_ty') arg_tys', res_kind) + (fun_ty', fun_kind) <- kc_lhs_type fun_ty + (arg_tys', res_kind) <- kcApps fun_ty fun_kind arg_tys + return (mkHsAppTys fun_ty' arg_tys', res_kind) where - (fun_ty, arg_tys) = split ty1 [ty2] - split (L _ (HsAppTy f a)) as = split f (a:as) - split f as = (f,as) - mk_app fun arg = HsAppTy (noLoc fun) arg -- Add noLocs for inner nodes of - -- the application; they are - -- never used + (fun_ty, arg_tys) = splitHsAppTys ty1 ty2 kc_hs_type (HsPredTy (HsEqualP _ _)) = wrongEqualityErr @@ -367,7 +396,7 @@ kc_hs_type (HsForAllTy exp tv_names context ty) ; return (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind) } kc_hs_type (HsBangTy b ty) = do - (ty', kind) <- kcHsType ty + (ty', kind) <- kc_lhs_type ty return (HsBangTy b ty', kind) kc_hs_type ty@(HsSpliceTy _) @@ -379,25 +408,53 @@ kc_hs_type (HsDocTy ty _) = kc_hs_type (unLoc ty) --------------------------- -kcApps :: TcKind -- Function kind - -> SDoc -- Function +kcApps :: Outputable a + => a + -> TcKind -- Function kind -> [LHsType Name] -- Arg types -> TcM ([LHsType Name], TcKind) -- Kind-checked args -kcApps fun_kind ppr_fun args = do - (arg_kinds, res_kind) <- split_fk fun_kind (length args) - args' <- zipWithM kc_arg args arg_kinds - return (args', res_kind) +kcApps the_fun fun_kind args + = do { (args_w_kinds, res_kind) <- splitFunKind the_fun 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 + -> TcM [LHsType Name] +kcCheckApps the_fun fun_kind args ty exp_kind + = do { (args_w_kinds, res_kind) <- splitFunKind the_fun fun_kind args + ; checkExpectedKind ty res_kind exp_kind + -- Check the result kind *before* checking argument kinds + -- This improves error message; Trac #2994 + ; kc_check_lhs_types args_w_kinds } + +splitHsAppTys :: LHsType Name -> LHsType Name -> (LHsType Name, [LHsType Name]) +splitHsAppTys fun_ty arg_ty = split fun_ty [arg_ty] where - split_fk fk 0 = return ([], fk) - split_fk fk n = do mb_fk <- unifyFunKind fk - case mb_fk of - Nothing -> failWithTc too_many_args - Just (ak,fk') -> do (aks, rk) <- split_fk fk' (n-1) - return (ak:aks, rk) + split (L _ (HsAppTy f a)) as = split f (a:as) + split f as = (f,as) - kc_arg arg arg_kind = kcCheckHsType arg arg_kind +mkHsAppTys :: LHsType Name -> [LHsType Name] -> HsType Name +mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty) +mkHsAppTys fun_ty (arg_ty:arg_tys) + = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys + where + mk_app fun arg = HsAppTy (noLoc fun) arg -- Add noLocs for inner nodes of + -- the application; they are + -- never used - too_many_args = ptext (sLit "Kind error:") <+> quotes ppr_fun <+> +--------------------------- +splitFunKind :: Outputable a => a -> TcKind -> [b] -> TcM ([(b,TcKind)], TcKind) +splitFunKind _ fk [] = return ([], fk) +splitFunKind the_fun 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) } } + where + too_many_args = quotes (ppr the_fun) <+> ptext (sLit "is applied to too many type arguments") --------------------------- @@ -418,18 +475,18 @@ kc_pred :: HsPred Name -> TcM (HsPred Name, TcKind) -- Does *not* check for a saturated -- application (reason: used from TcDeriv) kc_pred (HsIParam name ty) - = do { (ty', kind) <- kcHsType ty + = do { (ty', kind) <- kc_lhs_type ty ; return (HsIParam name ty', kind) } kc_pred (HsClassP cls tys) = do { kind <- kcClass cls - ; (tys', res_kind) <- kcApps kind (ppr cls) tys + ; (tys', res_kind) <- kcApps cls kind tys ; return (HsClassP cls tys', res_kind) } kc_pred (HsEqualP ty1 ty2) - = do { (ty1', kind1) <- kcHsType ty1 + = do { (ty1', kind1) <- kc_lhs_type ty1 -- ; checkExpectedKind ty1 kind1 liftedTypeKind - ; (ty2', kind2) <- kcHsType ty2 + ; (ty2', kind2) <- kc_lhs_type ty2 -- ; checkExpectedKind ty2 kind2 liftedTypeKind ; checkExpectedKind ty2 kind2 kind1 ; return (HsEqualP ty1' ty2', liftedTypeKind) @@ -623,6 +680,12 @@ badGadtDecl ty = hang (ptext (sLit "Malformed constructor result type:")) 2 (ppr ty) +addKcTypeCtxt :: LHsType Name -> TcM a -> TcM a + -- Wrap a context around only if we want to show that contexts. +addKcTypeCtxt (L _ (HsPredTy _)) thing = thing + -- Omit invisble ones and ones user's won't grok (HsPred p). +addKcTypeCtxt (L _ other_ty) thing = addErrCtxt (typeCtxt other_ty) thing + typeCtxt :: HsType Name -> SDoc typeCtxt ty = ptext (sLit "In the type") <+> quotes (ppr ty) \end{code} diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index cc7d63d..98279c4 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1266,7 +1266,7 @@ tcRnType hsc_env ictxt rdr_type failIfErrsM ; -- Now kind-check the type - (ty', kind) <- kcHsType rn_type ; + (ty', kind) <- kcLHsType rn_type ; return kind } where diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index af4d320..309874b 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -565,7 +565,7 @@ kcTopSpliceType expr ; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2) - ; kcHsType hs_ty3 } + ; kcLHsType hs_ty3 } \end{code} %************************************************************************ diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 9bfba3f..4f6e7bd 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -276,7 +276,7 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) addErr (wrongKindOfFamily family) ; -- (1) kind check the right-hand side of the type equation - ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind + ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) resKind -- we need the exact same number of type parameters as the family -- declaration @@ -385,7 +385,7 @@ kcIdxTyPats decl thing_inside -- type functions can have a higher-kinded result ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind - ; typats <- zipWithM kcCheckHsType hs_typats kinds + ; typats <- zipWithM kcCheckLHsType hs_typats kinds ; thing_inside tvs typats resultKind fam_tycon } where @@ -508,7 +508,7 @@ kcSynDecl (AcyclicSCC (L loc decl)) kcHsTyVars (tcdTyVars decl) (\ k_tvs -> do { traceTc (text "kcd1" <+> ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl)) <+> brackets (ppr k_tvs)) - ; (k_rhs, rhs_kind) <- kcHsType (tcdSynRhs decl) + ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl) ; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl))) ; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }), @@ -584,14 +584,15 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) ; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) } where -- doc comments are typechecked to Nothing here - kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res _) = do - kcHsTyVars ex_tvs $ \ex_tvs' -> do - ex_ctxt' <- kcHsContext ex_ctxt - details' <- kc_con_details details - res' <- case res of - ResTyH98 -> return ResTyH98 - ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') } - return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing) + kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res _) + = addErrCtxt (dataConCtxt name) $ + kcHsTyVars ex_tvs $ \ex_tvs' -> do + do { ex_ctxt' <- kcHsContext ex_ctxt + ; details' <- kc_con_details details + ; res' <- case res of + ResTyH98 -> return ResTyH98 + ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') } + ; return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing) } kc_con_details (PrefixCon btys) = do { btys' <- mapM kc_larg_ty btys -- 1.7.10.4