Improve kind inference for tuple types
authorSimon Peyton Jones <simonpj@microsoft.com>
Mon, 26 Nov 2012 12:07:37 +0000 (12:07 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Mon, 26 Nov 2012 12:07:57 +0000 (12:07 +0000)
Trac #7410 pointed out a terrible error message, which is
much improved by this patch.

compiler/main/ErrUtils.lhs
compiler/typecheck/TcHsType.lhs

index 776382e..e0d6a96 100644 (file)
@@ -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.")
index 36762b9..f82382b 100644 (file)
@@ -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)`