[commit: ghc] master: Reject negative type-level integers created via TH (#8412) (2216b4d)

[git at git.haskell.org]

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

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

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

commit 2216b4d37fa12f7e9d16d8942d3ec9d0ad5376e6
Author: Krzysztof Gogolewski <krz.gogolewski at gmail.com>
Date:   Sat Oct 5 17:21:44 2013 +0200

    Reject negative type-level integers created via TH (#8412)
    
    This commit moves the check from parser to renamer.


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

2216b4d37fa12f7e9d16d8942d3ec9d0ad5376e6
 compiler/parser/RdrHsSyn.lhs |   25 ++++++++-----------------
 compiler/rename/RnTypes.lhs  |    9 +++++++--
 2 files changed, 15 insertions(+), 19 deletions(-)

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index f024d5c..47abe3a 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/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
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 9aeae7e..0db92e8 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/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