summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Hs/Type.hs13
-rw-r--r--compiler/GHC/Rename/Expr.hs1
-rw-r--r--compiler/GHC/Rename/Pat.hs9
-rw-r--r--compiler/GHC/Rename/Utils.hs18
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs5
-rw-r--r--compiler/GHC/Tc/Gen/HsType.hs35
-rw-r--r--compiler/GHC/Tc/Gen/Pat.hs2
-rw-r--r--compiler/GHC/Tc/TyCl.hs3
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 }
View Lorry Controller Status