Adding tick boxes to the interface syntax; fixes #1510

[ghc-hetmet.git] / compiler / parser / Lexer.x

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index ad56090..c4cd0aa 100644 (file)
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -308,9 +308,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 }
 }
@@ -613,7 +618,7 @@ reservedWordsFM = listToUFM $
        ( "where",      ITwhere,        0 ),
        ( "_scc_",      ITscc,          0 ),            -- ToDo: remove
 
-       ( "forall",     ITforall,        bit tvBit),
+       ( "forall",     ITforall,        bit explicitForallBit),
        ( "mdo",        ITmdo,           bit recursiveDoBit),
        ( "family",     ITfamily,        bit tyFamBit),
 
@@ -655,7 +660,7 @@ reservedSymsFM = listToUFM $
                             kindSigsEnabled i ||
                             tyFamEnabled i)
         -- For 'forall a . t'
-       ,(".", ITdot, tvEnabled)
+       ,(".", ITdot, explicitForallEnabled)
 
        ,("-<",  ITlarrowtail, arrowsEnabled)
        ,(">-",  ITrarrowtail, arrowsEnabled)
@@ -665,7 +670,8 @@ reservedSymsFM = listToUFM $
 #if __GLASGOW_HASKELL__ >= 605
        ,("∷",   ITdcolon, unicodeSyntaxEnabled)
        ,("⇒",   ITdarrow, unicodeSyntaxEnabled)
-       ,("∀",   ITforall, \i -> unicodeSyntaxEnabled i && tvEnabled i)
+       ,("∀",   ITforall, \i -> unicodeSyntaxEnabled i &&
+                                explicitForallEnabled i)
        ,("→",   ITrarrow, unicodeSyntaxEnabled)
        ,("←",   ITlarrow, unicodeSyntaxEnabled)
        ,("⋯",   ITdotdot, unicodeSyntaxEnabled)
@@ -1515,7 +1521,7 @@ parrBit      = 2
 arrowsBit  = 4
 thBit     = 5
 ipBit      = 6
-tvBit     = 7  -- Scoped type variables enables 'forall' keyword
+explicitForallBit = 7 -- the 'forall' keyword and '.' symbol
 bangPatBit = 8 -- Tells the parser to understand bang-patterns
                -- (doesn't affect the lexer)
 tyFamBit   = 9 -- indexed type families: 'family' keyword and kind sigs
@@ -1524,6 +1530,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
@@ -1533,7 +1540,7 @@ parrEnabled      flags = testBit flags parrBit
 arrowsEnabled    flags = testBit flags arrowsBit
 thEnabled        flags = testBit flags thBit
 ipEnabled        flags = testBit flags ipBit
-tvEnabled        flags = testBit flags tvBit
+explicitForallEnabled flags = testBit flags explicitForallBit
 bangPatEnabled   flags = testBit flags bangPatBit
 tyFamEnabled     flags = testBit flags tyFamBit
 haddockEnabled   flags = testBit flags haddockBit
@@ -1541,6 +1548,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
 --
@@ -1588,7 +1596,9 @@ mkPState buf loc flags  =
               .|. arrowsBit    `setBitIf` dopt Opt_Arrows       flags
               .|. thBit        `setBitIf` dopt Opt_TH           flags
               .|. ipBit        `setBitIf` dopt Opt_ImplicitParams flags
-              .|. tvBit        `setBitIf` dopt Opt_ScopedTypeVariables flags
+              .|. explicitForallBit `setBitIf` dopt Opt_ScopedTypeVariables flags
+              .|. explicitForallBit `setBitIf` dopt Opt_PolymorphicComponents flags
+              .|. explicitForallBit `setBitIf` dopt Opt_ExistentialQuantification flags
               .|. bangPatBit   `setBitIf` dopt Opt_BangPatterns flags
               .|. tyFamBit     `setBitIf` dopt Opt_TypeFamilies flags
               .|. haddockBit   `setBitIf` dopt Opt_Haddock      flags
@@ -1596,6 +1606,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