From c9c8b4059aeb2e20ddb4000194dbd44db0c3559d Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Mon, 26 Nov 2012 12:07:37 +0000
Subject: [PATCH] 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 1643128eb7ed..300bad85bf00 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 bacb02c34ae9..c050694d5e20 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)`
--
GitLab