Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/1135c8439e606b2b0cebd138afbb4c5716f3abcc >--------------------------------------------------------------- commit 1135c8439e606b2b0cebd138afbb4c5716f3abcc 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. >--------------------------------------------------------------- compiler/main/ErrUtils.lhs | 5 ++++- compiler/typecheck/TcHsType.lhs | 30 +++++++++++++++++++++--------- 2 files changed, 25 insertions(+), 10 deletions(-) diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 776382e..e0d6a96 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, @@ -136,6 +136,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 36762b9..f82382b 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -67,6 +67,7 @@ import NameEnv import TysWiredIn import BasicTypes import SrcLoc +import ErrUtils ( isEmptyMessages ) import DynFlags ( ExtensionFlag( Opt_DataKinds ), getDynFlags ) import Unique import UniqSupply @@ -403,15 +404,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
