Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : ghc-7.6
http://hackage.haskell.org/trac/ghc/changeset/c9c8b4059aeb2e20ddb4000194dbd44db0c3559d >--------------------------------------------------------------- commit c9c8b4059aeb2e20ddb4000194dbd44db0c3559d Author: Simon Peyton Jones <simo...@microsoft.com> Date: Mon Nov 26 12:07:37 2012 +0000 Improve kind inference for tuple types Trac #7410 pointed out a terrible error message, which is much improved by this patch. Conflicts: compiler/typecheck/TcHsType.lhs >--------------------------------------------------------------- compiler/main/ErrUtils.lhs | 5 ++++- compiler/typecheck/TcHsType.lhs | 32 ++++++++++++++++++++++---------- 2 files changed, 26 insertions(+), 11 deletions(-) diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 1643128..300bad8 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -12,7 +12,7 @@ module ErrUtils ( MsgDoc, mkLocMessage, pprMessageBag, pprErrMsgBag, pprErrMsgBagWithLoc, pprLocErrMsg, makeIntoWarning, - errorsFound, emptyMessages, + errorsFound, emptyMessages, isEmptyMessages, mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg, printBagOfErrors, warnIsErrorMsg, mkLongWarnMsg, @@ -133,6 +133,9 @@ mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn emptyMessages :: Messages emptyMessages = (emptyBag, emptyBag) +isEmptyMessages :: Messages -> Bool +isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs + warnIsErrorMsg :: DynFlags -> ErrMsg warnIsErrorMsg dflags = mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.") diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index bacb02c..c050694 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -68,7 +68,8 @@ import NameEnv import TysWiredIn import BasicTypes import SrcLoc -import DynFlags ( ExtensionFlag( Opt_DataKinds ) ) +import ErrUtils +import DynFlags import Unique import UniqSupply import Outputable @@ -404,15 +405,26 @@ tc_hs_type hs_ty@(HsTupleTy HsBoxedOrConstraintTuple tys) exp_kind@(EK exp_k _ct | isLiftedTypeKind exp_k = tc_tuple hs_ty HsBoxedTuple tys exp_kind | otherwise = do { k <- newMetaKindVar - ; tau_tys <- tc_hs_arg_tys (ptext (sLit "a tuple")) tys (repeat k) - ; k' <- zonkTcKind k - ; if isConstraintKind k' then - finish_tuple hs_ty HsConstraintTuple tau_tys exp_kind - else if isLiftedTypeKind k' then - finish_tuple hs_ty HsBoxedTuple tau_tys exp_kind - else - tc_tuple hs_ty HsBoxedTuple tys exp_kind } - -- It's not clear what the kind is, so assume *, and + ; (msgs, mb_tau_tys) <- tryTc (tc_hs_arg_tys (ptext (sLit "a tuple")) tys (repeat k)) + ; k <- zonkTcKind k + -- Do the experiment inside a 'tryTc' because errors can be + -- confusing. Eg Trac #7410 (Either Int, Int), we do not want to get + -- an error saying "the second argument of a tuple should have kind *->*" + + ; case mb_tau_tys of + Just tau_tys + | not (isEmptyMessages msgs) -> try_again k + | isConstraintKind k -> go_for HsConstraintTuple tau_tys + | isLiftedTypeKind k -> go_for HsBoxedTuple tau_tys + | otherwise -> try_again k + Nothing -> try_again k } + where + go_for sort tau_tys = finish_tuple hs_ty sort tau_tys exp_kind + + try_again k + | isConstraintKind k = tc_tuple hs_ty HsConstraintTuple tys exp_kind + | otherwise = tc_tuple hs_ty HsBoxedTuple tys exp_kind + -- It's not clear what the kind is, so make best guess and -- check the arguments again to give good error messages -- in eg. `(Maybe, Maybe)` _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
