summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Tc')
-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
4 files changed, 19 insertions, 26 deletions
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