[commit: ghc] master: Improve constraint tuples (Trac #10451) (b095c97)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/b095c97d6e8e5841c28464eb5db67d3c1ca055b8/ghc

>---------------------------------------------------------------

commit b095c97d6e8e5841c28464eb5db67d3c1ca055b8
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Jun 2 00:40:44 2015 +0100

    Improve constraint tuples (Trac #10451)
    
    * Increase max constraint tuple size to 16
    * Produce a civilised error message if the max
      size is exceeded


>---------------------------------------------------------------

b095c97d6e8e5841c28464eb5db67d3c1ca055b8
 compiler/main/Constants.hs     |  2 +-
 compiler/typecheck/TcHsType.hs | 21 ++++++++++++++++-----
 2 files changed, 17 insertions(+), 6 deletions(-)

diff --git a/compiler/main/Constants.hs b/compiler/main/Constants.hs
index 22bd4e6..229e007 100644
--- a/compiler/main/Constants.hs
+++ b/compiler/main/Constants.hs
@@ -18,7 +18,7 @@ mAX_TUPLE_SIZE = 62 -- Should really match the number
                     -- of decls in Data.Tuple
 
 mAX_CTUPLE_SIZE :: Int   -- Constraint tuples
-mAX_CTUPLE_SIZE = 8      -- Should match the number of decls in GHC.Classes
+mAX_CTUPLE_SIZE = 16     -- Should match the number of decls in GHC.Classes
 
 -- | Default maximum depth for both class instance search and type family
 -- reduction. See also Trac #5395.
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 785dce7..15d647b 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -61,6 +61,8 @@ import TysWiredIn
 import BasicTypes
 import SrcLoc
 import DynFlags ( ExtensionFlag( Opt_DataKinds ), getDynFlags )
+import Constants ( mAX_CTUPLE_SIZE )
+import ErrUtils( MsgDoc )
 import Unique
 import UniqSupply
 import Outputable
@@ -569,11 +571,14 @@ finish_tuple hs_ty tup_sort tau_tys exp_kind
   = do { traceTc "finish_tuple" (ppr res_kind $$ ppr exp_kind $$ ppr exp_kind)
        ; checkExpectedKind hs_ty res_kind exp_kind
        ; tycon <- case tup_sort of
-           ConstraintTuple -> tcLookupTyCon (cTupleTyConName arity)
-           BoxedTuple      -> do { let tc = tupleTyCon Boxed arity
-                                 ; checkWiredInTyCon tc
-                                 ; return tc }
-           UnboxedTuple    -> return (tupleTyCon Unboxed arity)
+           ConstraintTuple
+             | arity > mAX_CTUPLE_SIZE
+                         -> failWith (bigConstraintTuple arity)
+             | otherwise -> tcLookupTyCon (cTupleTyConName arity)
+           BoxedTuple    -> do { let tc = tupleTyCon Boxed arity
+                               ; checkWiredInTyCon tc
+                               ; return tc }
+           UnboxedTuple  -> return (tupleTyCon Unboxed arity)
        ; return (mkTyConApp tycon tau_tys) }
   where
     arity = length tau_tys
@@ -582,6 +587,12 @@ finish_tuple hs_ty tup_sort tau_tys exp_kind
                  BoxedTuple      -> liftedTypeKind
                  ConstraintTuple -> constraintKind
 
+bigConstraintTuple :: Arity -> MsgDoc
+bigConstraintTuple arity
+  = hang (ptext (sLit "Constraint tuple arity too large:") <+> int arity
+          <+> parens (ptext (sLit "max arity =") <+> int mAX_CTUPLE_SIZE))
+       2 (ptext (sLit "Instead, use a nested tuple"))
+
 ---------------------------
 tcInferApps :: Outputable a
        => a