[commit: ghc] ghc-7.6: Improve kind inference for tuple types (c9c8b40)

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 <[email protected]>
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)`