[commit: ghc] master: Make sure type literals aren't negative (#8306) (3ee4700)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/3ee47002dd483e0daa604d37ec45dc33133ff04b/ghc

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

commit 3ee47002dd483e0daa604d37ec45dc33133ff04b
Author: Austin Seipp <austin at well-typed.com>
Date:   Mon Sep 16 10:05:44 2013 -0500

    Make sure type literals aren't negative (#8306)
    
    As Krzysztof pointed out in #8306, with NegativeLiterals and DataKinds,
    definitions such as:
    
      type T = -1
    
    were accepted, although type literals must be greater than zero.
    
    Signed-off-by: Austin Seipp <austin at well-typed.com>


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

3ee47002dd483e0daa604d37ec45dc33133ff04b
 compiler/parser/RdrHsSyn.lhs |   24 +++++++++++++++---------
 1 file changed, 15 insertions(+), 9 deletions(-)

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 1f32749..e925881 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -215,17 +215,23 @@ mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr
 mkTopSpliceDecl other_expr                          = SpliceD (SpliceDecl other_expr Implicit)
 
 
-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)
-
+-- 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)
 \end{code}
 
 %************************************************************************