Only parse type literals when using `DataKinds`.
authorIavor S. Diatchki <iavor.diatchki@gmail.com>
Sun, 18 Mar 2012 21:42:06 +0000 (14:42 -0700)
committerIavor S. Diatchki <iavor.diatchki@gmail.com>
Sun, 18 Mar 2012 21:42:06 +0000 (14:42 -0700)
compiler/parser/Lexer.x
compiler/parser/Parser.y.pp
compiler/parser/RdrHsSyn.lhs

index 74da99a..2b04294 100644 (file)
@@ -56,6 +56,7 @@ module Lexer (
    getLexState, popLexState, pushLexState,
    extension, bangPatEnabled, datatypeContextsEnabled,
    traditionalRecordSyntaxEnabled,
+   typeLiteralsEnabled,
    addWarning,
    lexTokenStream
   ) where
@@ -1806,6 +1807,8 @@ safeHaskellBit :: Int
 safeHaskellBit = 26
 traditionalRecordSyntaxBit :: Int
 traditionalRecordSyntaxBit = 27
+typeLiteralsBit :: Int
+typeLiteralsBit = 28
 
 always :: Int -> Bool
 always           _     = True
@@ -1849,6 +1852,8 @@ nondecreasingIndentation :: Int -> Bool
 nondecreasingIndentation flags = testBit flags nondecreasingIndentationBit
 traditionalRecordSyntaxEnabled :: Int -> Bool
 traditionalRecordSyntaxEnabled flags = testBit flags traditionalRecordSyntaxBit
+typeLiteralsEnabled :: Int -> Bool
+typeLiteralsEnabled flags = testBit flags typeLiteralsBit
 
 -- PState for parsing options pragmas
 --
@@ -1908,6 +1913,7 @@ mkPState flags buf loc =
                .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
                .|. safeHaskellBit              `setBitIf` safeImportsOn                     flags
                .|. traditionalRecordSyntaxBit  `setBitIf` xopt Opt_TraditionalRecordSyntax  flags
+               .|. typeLiteralsBit             `setBitIf` xopt Opt_DataKinds flags
       --
       setBitIf :: Int -> Bool -> Int
       b `setBitIf` cond | cond      = bit b
index 35f8e48..0dd90f5 100644 (file)
@@ -1080,8 +1080,8 @@ atype :: { LHsType RdrName }
         | SIMPLEQUOTE  '(' ctype ',' comma_types1 ')' { LL $ HsExplicitTupleTy [] ($3 : $5) }
         | SIMPLEQUOTE  '[' comma_types0 ']'           { LL $ HsExplicitListTy placeHolderKind $3 }
         | '[' ctype ',' comma_types1 ']'              { LL $ HsExplicitListTy placeHolderKind ($2 : $4) }
-        | INTEGER            { LL $ HsTyLit $ HsNumTy $ getINTEGER $1 }
-        | STRING             { LL $ HsTyLit $ HsStrTy $ getSTRING  $1 }
+        | INTEGER            {% mkTyLit $ LL $ HsNumTy $ getINTEGER $1 }
+        | STRING             {% mkTyLit $ LL $ HsStrTy $ getSTRING  $1 }
 
 -- An inst_type is what occurs in the head of an instance decl
 --      e.g.  (Foo a, Gaz b) => Wibble a b
index 9c000ee..1bb7695 100644 (file)
@@ -14,6 +14,7 @@ module RdrHsSyn (
         mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
         splitCon, mkInlinePragma,
         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
+        mkTyLit,
 
         cvBindGroup,
         cvBindsAndSigs,
@@ -250,6 +251,19 @@ mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
 mkTopSpliceDecl (L _ (HsQuasiQuoteE qq))            = QuasiQuoteD qq
 mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr       Explicit)
 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 -XDataKinds to enable):" <+>
+              ppr l)
+
+
+
 \end{code}
 
 %************************************************************************