Check for large tuples more thoroughlywip/T18723

This fixes #18723 by:

* Moving the existing `GHC.Tc.Gen.HsType.bigConstraintTuple` validity
  check to `GHC.Rename.Utils.checkCTupSize` for consistency with
  `GHC.Rename.Utils.checkTupSize`, and
* Using `check(C)TupSize` when checking tuple _types_, in addition
  to checking names, expressions, and patterns.

Note that I put as many of these checks as possible in the typechecker so
that GHC can properly distinguish between boxed and constraint tuples. The
exception to this rule is checking names, which I perform in the renamer
(in `GHC.Rename.Env`) so that we can rule out `(,, ... ,,)` and
`''(,, ... ,,)` alike in one fell swoop.

While I was in town, I also removed the `HsConstraintTuple` and
`HsBoxedTuple` constructors of `HsTupleSort`, which are functionally
unused. This requires a `haddock` submodule bump.

8 files changed, 43 insertions, 43 deletions

diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index a193eefa12..ed3b20a0ec 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -1060,20 +1060,19 @@ namely HsTupleTy, but keep track of the tuple kind (in the first argument to
 HsTupleTy, a HsTupleSort). We can tell if a tuple is unboxed while parsing,
 because of the #. However, with -XConstraintKinds we can only distinguish
 between constraint and boxed tuples during type checking, in general. Hence the
-four constructors of HsTupleSort:
+two constructors of HsTupleSort:
 
         HsUnboxedTuple                  -> Produced by the parser
-        HsBoxedTuple                    -> Certainly a boxed tuple
-        HsConstraintTuple               -> Certainly a constraint tuple
         HsBoxedOrConstraintTuple        -> Could be a boxed or a constraint
                                         tuple. Produced by the parser only,
                                         disappears after type checking
+
+After typechecking, we use TupleSort (which clearly distinguishes between
+constraint tuples and boxed tuples) rather than HsTupleSort.
 -}
 
 -- | Haskell Tuple Sort
 data HsTupleSort = HsUnboxedTuple
-                 | HsBoxedTuple
-                 | HsConstraintTuple
                  | HsBoxedOrConstraintTuple
                  deriving Data
 
@@ -1988,11 +1987,9 @@ hsTypeNeedsParens p = go_hs_ty
     -- Special-case unary boxed tuple applications so that they are
     -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612)
     -- See Note [One-tuples] in GHC.Builtin.Types
-    go_hs_ty (HsTupleTy _ con [L _ ty])
+    go_hs_ty (HsTupleTy _ con [_])
       = case con of
-          HsBoxedTuple               -> p >= appPrec
           HsBoxedOrConstraintTuple   -> p >= appPrec
-          HsConstraintTuple          -> go_hs_ty ty
           HsUnboxedTuple             -> False
     go_hs_ty (HsTupleTy{})            = False
     go_hs_ty (HsSumTy{})              = False
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index e0855f8c24..14218b01f6 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -282,7 +282,6 @@ rnExpr (ExplicitList x _  exps)
 
 rnExpr (ExplicitTuple x tup_args boxity)
   = do { checkTupleSection tup_args
-       ; checkTupSize (length tup_args)
        ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
        ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) }
   where
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 4a85c898ff..b0f15d3d19 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -37,8 +37,8 @@ module GHC.Rename.Pat (-- main entry points
               -- Literals
               rnLit, rnOverLit,
 
-             -- Pattern Error messages that are also used elsewhere
-             checkTupSize, patSigErr
+             -- Pattern Error message that is also used elsewhere
+             patSigErr
              ) where
 
 -- ENH: thin imports to only what is necessary for patterns
@@ -59,7 +59,7 @@ import GHC.Rename.Utils    ( HsDocContext(..), newLocalBndrRn, bindLocalNames
                            , warnUnusedMatches, newLocalBndrRn
                            , checkUnusedRecordWildcard
                            , checkDupNames, checkDupAndShadowedNames
-                           , checkTupSize , unknownSubordinateErr )
+                           , unknownSubordinateErr )
 import GHC.Rename.HsType
 import GHC.Builtin.Names
 import GHC.Types.Name
@@ -498,8 +498,7 @@ rnPatAndThen mk (ListPat _ pats)
           False -> return (ListPat Nothing pats') }
 
 rnPatAndThen mk (TuplePat x pats boxed)
-  = do { liftCps $ checkTupSize (length pats)
-       ; pats' <- rnLPatsAndThen mk pats
+  = do { pats' <- rnLPatsAndThen mk pats
        ; return (TuplePat x pats' boxed) }
 
 rnPatAndThen mk (SumPat x pat alt arity)
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index 85dd2566ea..a29a8b6602 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -11,7 +11,7 @@ This module contains miscellaneous functions related to renaming.
 module GHC.Rename.Utils (
         checkDupRdrNames, checkShadowedRdrNames,
         checkDupNames, checkDupAndShadowedNames, dupNamesErr,
-        checkTupSize,
+        checkTupSize, checkCTupSize,
         addFvRn, mapFvRn, mapMaybeFvRn,
         warnUnusedMatches, warnUnusedTypePatterns,
         warnUnusedTopBinds, warnUnusedLocalBinds,
@@ -57,7 +57,7 @@ import GHC.Driver.Session
 import GHC.Data.FastString
 import Control.Monad
 import Data.List
-import GHC.Settings.Constants ( mAX_TUPLE_SIZE )
+import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE )
 import qualified Data.List.NonEmpty as NE
 import qualified GHC.LanguageExtensions as LangExt
 
@@ -572,7 +572,9 @@ typeAppErr what (L _ k)
             <+> quotes (char '@' <> ppr k))
        2 (text "Perhaps you intended to use TypeApplications")
 
-checkTupSize :: Int -> RnM ()
+-- | Ensure that a boxed or unboxed tuple has arity no larger than
+-- 'mAX_TUPLE_SIZE'.
+checkTupSize :: Int -> TcM ()
 checkTupSize tup_size
   | tup_size <= mAX_TUPLE_SIZE
   = return ()
@@ -581,6 +583,16 @@ checkTupSize tup_size
                  nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),
                  nest 2 (text "Workaround: use nested tuples or define a data type")])
 
+-- | Ensure that a constraint tuple has arity no larger than 'mAX_CTUPLE_SIZE'.
+checkCTupSize :: Int -> TcM ()
+checkCTupSize tup_size
+  | tup_size <= mAX_CTUPLE_SIZE
+  = return ()
+  | otherwise
+  = addErr (hang (text "Constraint tuple arity too large:" <+> int tup_size
+                  <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))
+               2 (text "Instead, use a nested tuple"))
+
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 564ad46660..5d919280f0 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -32,6 +32,7 @@ import GHC.Prelude
 import {-# SOURCE #-}   GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
 
 import GHC.Hs
+import GHC.Rename.Utils
 import GHC.Tc.Utils.Zonk
 import GHC.Tc.Utils.Monad
 import GHC.Tc.Utils.Unify
@@ -1036,7 +1037,9 @@ arithSeqEltType (Just fl) res_ty
 ----------------
 tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTc]
 tcTupArgs args tys
-  = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
+  = do MASSERT( equalLength args tys )
+       checkTupSize (length args)
+       mapM go (args `zip` tys)
   where
     go (L l (Missing {}),     arg_ty) = do { mult <- newFlexiTyVarTy multiplicityTy
                                            ; return (L l (Missing (Scaled mult arg_ty))) }
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index e599ad56f8..9c67345b7f 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -71,6 +71,7 @@ module GHC.Tc.Gen.HsType (
 import GHC.Prelude
 
 import GHC.Hs
+import GHC.Rename.Utils
 import GHC.Tc.Utils.Monad
 import GHC.Tc.Types.Origin
 import GHC.Core.Predicate
@@ -103,8 +104,6 @@ import GHC.Types.Var.Env
 import GHC.Builtin.Types
 import GHC.Types.Basic
 import GHC.Types.SrcLoc
-import GHC.Settings.Constants ( mAX_CTUPLE_SIZE )
-import GHC.Utils.Error( MsgDoc )
 import GHC.Types.Unique
 import GHC.Types.Unique.FM
 import GHC.Types.Unique.Set
@@ -1133,16 +1132,8 @@ tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind
        ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind }
 
 
-tc_hs_type mode rn_ty@(HsTupleTy _ hs_tup_sort tys) exp_kind
-  = tc_tuple rn_ty mode tup_sort tys exp_kind
-  where
-    tup_sort = case hs_tup_sort of  -- Fourth case dealt with above
-                  HsUnboxedTuple    -> UnboxedTuple
-                  HsBoxedTuple      -> BoxedTuple
-                  HsConstraintTuple -> ConstraintTuple
-#if __GLASGOW_HASKELL__ <= 810
-                  _                 -> panic "tc_hs_type HsTupleTy"
-#endif
+tc_hs_type mode rn_ty@(HsTupleTy _ HsUnboxedTuple tys) exp_kind
+  = tc_tuple rn_ty mode UnboxedTuple tys exp_kind
 
 tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind
   = do { let arity = length hs_tys
@@ -1173,6 +1164,7 @@ tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind
        ; let kind_con   = tupleTyCon           Boxed arity
              ty_con     = promotedTupleDataCon Boxed arity
              tup_k      = mkTyConApp kind_con ks
+       ; checkTupSize arity
        ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }
   where
     arity = length tys
@@ -1327,33 +1319,28 @@ finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do
          -- Drop any uses of 1-tuple constraints here.
          -- See Note [Ignore unary constraint tuples]
       -> check_expected_kind tau_ty constraintKind
-      |  arity > mAX_CTUPLE_SIZE
-      -> failWith (bigConstraintTuple arity)
       |  otherwise
-      -> let tycon = cTupleTyCon arity in
-         check_expected_kind (mkTyConApp tycon tau_tys) constraintKind
+      -> do let tycon = cTupleTyCon arity
+            checkCTupSize arity
+            check_expected_kind (mkTyConApp tycon tau_tys) constraintKind
     BoxedTuple -> do
       let tycon = tupleTyCon Boxed arity
+      checkTupSize arity
       checkWiredInTyCon tycon
       check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind
-    UnboxedTuple ->
+    UnboxedTuple -> do
       let tycon    = tupleTyCon Unboxed arity
           tau_reps = map kindRep tau_kinds
           -- See also Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
           arg_tys  = tau_reps ++ tau_tys
-          res_kind = unboxedTupleKind tau_reps in
+          res_kind = unboxedTupleKind tau_reps
+      checkTupSize arity
       check_expected_kind (mkTyConApp tycon arg_tys) res_kind
   where
     arity = length tau_tys
     check_expected_kind ty act_kind =
       checkExpectedKind rn_ty ty act_kind exp_kind
 
-bigConstraintTuple :: Arity -> MsgDoc
-bigConstraintTuple arity
-  = hang (text "Constraint tuple arity too large:" <+> int arity
-          <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))
-       2 (text "Instead, use a nested tuple")
-
 {-
 Note [Ignore unary constraint tuples]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 4ee4480c60..dba5bf5874 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -32,6 +32,7 @@ import GHC.Prelude
 import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferRho )
 
 import GHC.Hs
+import GHC.Rename.Utils
 import GHC.Tc.Utils.Zonk
 import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags )
 import GHC.Tc.Utils.Monad
@@ -509,6 +510,7 @@ Fortunately that's what matchExpectedFunTySigma returns anyway.
               tc = tupleTyCon boxity arity
               -- NB: tupleTyCon does not flatten 1-tuples
               -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
+        ; checkTupSize arity
         ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
                                                penv (scaledThing pat_ty)
                      -- Unboxed tuples have RuntimeRep vars, which we discard:
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index ae30b9d870..971a4442a5 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -678,7 +678,8 @@ kcTyClGroup kisig_env decls
                     -- NB: the environment extension overrides the tycon
                     --     promotion-errors bindings
                     --     See Note [Type environment evolution]
-                  ; tcExtendKindEnvWithTyCons mono_tcs $
+                  ; checkNoErrs $
+                    tcExtendKindEnvWithTyCons mono_tcs $
                     mapM_ kcLTyClDecl kindless_decls
 
                   ; return mono_tcs }