Reject negative type-level integers created via TH (#8412)

This commit moves the check from parser to renamer.

compiler/parser/RdrHsSyn.lhs

@@ -228,23 +228,14 @@ mkSpliceDecl other_expr                 = SpliceD (SpliceDecl (L (getLoc other_e
   where
     HsSpliceE splice = mkHsSpliceE other_expr
 
--- Ensure a type literal is used correctly; notably, we need the proper extension enabled,
--- and if it's an integer literal, the literal must be >= 0. This can occur with
--- -XNegativeLiterals enabled (see #8306)
-mkTyLit :: Located HsTyLit -> P (LHsType RdrName)
-mkTyLit lit = extension typeLiteralsEnabled >>= check
-  where
-    negLit (L _ (HsStrTy _)) = False
-    negLit (L _ (HsNumTy i)) = i < 0
-
-    check False =
-      parseErrorSDoc (getLoc lit)
-        (text "Illegal literal in type (use DataKinds to enable):" <+> ppr lit)
-    check True  =
-      if not (negLit lit) then return (HsTyLit `fmap` lit)
-       else parseErrorSDoc (getLoc lit)
-              (text "Illegal literal in type (type literals must not be negative):" <+> ppr lit)
-
+mkTyLit :: Located (HsTyLit) -> P (LHsType RdrName)
+mkTyLit l =
+  do allowed <- extension typeLiteralsEnabled
+     if allowed
+       then return (HsTyLit `fmap` l)
+       else parseErrorSDoc (getLoc l)
+              (text "Illegal literal in type (use DataKinds to enable):" <+>
+              ppr l)
 
 mkRoleAnnotDecl :: SrcSpan
                 -> Located RdrName                   -- type being annotated

compiler/rename/RnTypes.lhs

@@ -223,12 +223,17 @@ rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys)
        ; (tys', fvs) <- mapFvRn (rnLHsTyKi isType doc) tys
        ; return (HsTupleTy tup_con tys', fvs) }
 
--- 1. Perhaps we should use a separate extension here?
--- 2. Check that the integer is positive?
+-- Perhaps we should use a separate extension here?
+-- Ensure that a type-level integer is nonnegative (#8306, #8412)
 rnHsTyKi isType _ tyLit@(HsTyLit t)
   = do { data_kinds <- xoptM Opt_DataKinds
        ; unless (data_kinds || isType) (addErr (dataKindsErr isType tyLit))
+       ; when (negLit t) (addErr negLitErr)
        ; return (HsTyLit t, emptyFVs) }
+  where
+    negLit (HsStrTy _) = False
+    negLit (HsNumTy i) = i < 0
+    negLitErr = ptext (sLit "Illegal literal in type (type literals must not be negative):") <+> ppr tyLit
 
 rnHsTyKi isType doc (HsAppTy ty1 ty2)
   = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1