X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FLexer.x;h=0a8c4104a76460aac29c54883cd53462a29445fc;hb=6517f499c5b7a7b9dd217e5394a159ba9df5dd8c;hp=753a9728ea3b51a352cad5285e5d9cc3c9584731;hpb=f109a0b2d927a8c7fe5cc9881f0dfdae3e34f399;p=ghc-hetmet.git

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 753a972..0a8c410 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -220,13 +220,14 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
    -- NOTE: accept -} at the end of a LINE pragma, for compatibility
    -- with older versions of GHC which generated these.
 
--- We only want RULES pragmas to be picked up when -fglasgow-exts
--- is on, because the contents of the pragma is always written using
--- glasgow-exts syntax (using forall etc.), so if glasgow exts are not
--- enabled, we're sure to get a parse error.
+-- We only want RULES pragmas to be picked up when explicit forall
+-- syntax is enabled is on, because the contents of the pragma always
+-- uses it. If it's not on then we're sure to get a parse error.
 -- (ToDo: we should really emit a warning when ignoring pragmas)
-<glaexts>
-  "{-#" $whitechar* (RULES|rules)	{ token ITrules_prag }
+-- XXX Now that we can enable this without the -fglasgow-exts hammer,
+-- is it better just to let the parse error happen?
+<0,glaexts>
+  "{-#" $whitechar* (RULES|rules) / { ifExtension explicitForallEnabled } { token ITrules_prag }
 
 <0,option_prags,glaexts> {
   "{-#" $whitechar* (INLINE|inline)	{ token (ITinline_prag True) }
@@ -308,9 +309,14 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
   \? @varid / { ifExtension ipEnabled }	{ skip_one_varid ITdupipvarid }
 }
 
+<0,glaexts> {
+  "(#" / { ifExtension unboxedTuplesEnabled `alexAndPred` notFollowedBySymbol }
+         { token IToubxparen }
+  "#)" / { ifExtension unboxedTuplesEnabled }
+         { token ITcubxparen }
+}
+
 <glaexts> {
-  "(#" / { notFollowedBySymbol }	{ token IToubxparen }
-  "#)"					{ token ITcubxparen }
   "{|"					{ token ITocurlybar }
   "|}"					{ token ITccurlybar }
 }
@@ -1525,6 +1531,7 @@ magicHashBit = 11 -- # in both functions and operators
 kindSigsBit = 12 -- Kind signatures on type variables
 recursiveDoBit = 13 -- mdo
 unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
+unboxedTuplesBit = 15 -- (# and #)
 
 glaExtsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
 always           _     = True
@@ -1542,6 +1549,7 @@ magicHashEnabled flags = testBit flags magicHashBit
 kindSigsEnabled  flags = testBit flags kindSigsBit
 recursiveDoEnabled flags = testBit flags recursiveDoBit
 unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit
+unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit
 
 -- PState for parsing options pragmas
 --
@@ -1591,6 +1599,9 @@ mkPState buf loc flags  =
 	       .|. ipBit        `setBitIf` dopt Opt_ImplicitParams flags
 	       .|. explicitForallBit `setBitIf` dopt Opt_ScopedTypeVariables flags
 	       .|. explicitForallBit `setBitIf` dopt Opt_PolymorphicComponents flags
+	       .|. explicitForallBit `setBitIf` dopt Opt_ExistentialQuantification flags
+	       .|. explicitForallBit `setBitIf` dopt Opt_Rank2Types flags
+	       .|. explicitForallBit `setBitIf` dopt Opt_RankNTypes flags
 	       .|. bangPatBit   `setBitIf` dopt Opt_BangPatterns flags
 	       .|. tyFamBit     `setBitIf` dopt Opt_TypeFamilies flags
 	       .|. haddockBit   `setBitIf` dopt Opt_Haddock      flags
@@ -1598,6 +1609,7 @@ mkPState buf loc flags  =
 	       .|. kindSigsBit  `setBitIf` dopt Opt_KindSignatures flags
 	       .|. recursiveDoBit `setBitIf` dopt Opt_RecursiveDo flags
 	       .|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags
+	       .|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags
       --
       setBitIf :: Int -> Bool -> Int
       b `setBitIf` cond | cond      = bit b