Revert "Simplify 'ExtBits' in the lexer"
authorBen Gamari <ben@smart-cactus.org>
Fri, 23 Nov 2018 19:09:28 +0000 (14:09 -0500)
committerBen Gamari <ben@smart-cactus.org>
Fri, 23 Nov 2018 19:09:28 +0000 (14:09 -0500)
This reverts commit d2fbc33c4ff3074126ab71654af8bbf8a46e4e11.

compiler/parser/Lexer.x
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs

index 89ddfea..4572e6d 100644 (file)
@@ -55,7 +55,15 @@ module Lexer (
    popContext, pushModuleContext, setLastToken, setSrcLoc,
    activeContext, nextIsEOF,
    getLexState, popLexState, pushLexState,
-   ExtBits(..), getBit,
+   extension, bangPatEnabled, datatypeContextsEnabled,
+   traditionalRecordSyntaxEnabled,
+   explicitForallEnabled,
+   inRulePrag,
+   explicitNamespacesEnabled,
+   patternSynonymsEnabled,
+   starIsTypeEnabled, monadComprehensionsEnabled, doAndIfThenElseEnabled,
+   nPlusKPatternsEnabled, blockArgumentsEnabled, gadtSyntaxEnabled,
+   multiWayIfEnabled, thQuotesEnabled,
    addWarning,
    lexTokenStream,
    addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
@@ -228,7 +236,7 @@ $tab          { warnTab }
 
 -- Next, match Haddock comments if no -haddock flag
 
-"-- " $docsym .* / { alexNotPred (ifBit HaddockBit) } { lineCommentToken }
+"-- " $docsym .* / { ifExtension (not . haddockEnabled) } { lineCommentToken }
 
 -- Now, when we've matched comments that begin with 2 dashes and continue
 -- with a different character, we need to match comments that begin with three
@@ -354,41 +362,44 @@ $tab          { warnTab }
 -- Haddock comments
 
 <0,option_prags> {
-  "-- " $docsym      / { ifBit HaddockBit } { multiline_doc_comment }
-  "{-" \ ? $docsym   / { ifBit HaddockBit } { nested_doc_comment }
+  "-- " $docsym      / { ifExtension haddockEnabled } { multiline_doc_comment }
+  "{-" \ ? $docsym   / { ifExtension haddockEnabled } { nested_doc_comment }
 }
 
 -- "special" symbols
 
 <0> {
-  "[|"        / { ifBit ThQuotesBit } { token (ITopenExpQuote NoE NormalSyntax) }
-  "[||"       / { ifBit ThQuotesBit } { token (ITopenTExpQuote NoE) }
-  "[e|"       / { ifBit ThQuotesBit } { token (ITopenExpQuote HasE NormalSyntax) }
-  "[e||"      / { ifBit ThQuotesBit } { token (ITopenTExpQuote HasE) }
-  "[p|"       / { ifBit ThQuotesBit } { token ITopenPatQuote }
-  "[d|"       / { ifBit ThQuotesBit } { layout_token ITopenDecQuote }
-  "[t|"       / { ifBit ThQuotesBit } { token ITopenTypQuote }
-  "|]"        / { ifBit ThQuotesBit } { token (ITcloseQuote NormalSyntax) }
-  "||]"       / { ifBit ThQuotesBit } { token ITcloseTExpQuote }
-  \$ @varid   / { ifBit ThBit }       { skip_one_varid ITidEscape }
-  "$$" @varid / { ifBit ThBit }       { skip_two_varid ITidTyEscape }
-  "$("        / { ifBit ThBit }       { token ITparenEscape }
-  "$$("       / { ifBit ThBit }       { token ITparenTyEscape }
-
-  "[" @varid "|"  / { ifBit QqBit }   { lex_quasiquote_tok }
+  "[|"        / { ifExtension thQuotesEnabled } { token (ITopenExpQuote NoE
+                                                                NormalSyntax) }
+  "[||"       / { ifExtension thQuotesEnabled } { token (ITopenTExpQuote NoE) }
+  "[e|"       / { ifExtension thQuotesEnabled } { token (ITopenExpQuote HasE
+                                                                NormalSyntax) }
+  "[e||"      / { ifExtension thQuotesEnabled } { token (ITopenTExpQuote HasE) }
+  "[p|"       / { ifExtension thQuotesEnabled } { token ITopenPatQuote }
+  "[d|"       / { ifExtension thQuotesEnabled } { layout_token ITopenDecQuote }
+  "[t|"       / { ifExtension thQuotesEnabled } { token ITopenTypQuote }
+  "|]"        / { ifExtension thQuotesEnabled } { token (ITcloseQuote
+                                                                NormalSyntax) }
+  "||]"       / { ifExtension thQuotesEnabled } { token ITcloseTExpQuote }
+  \$ @varid   / { ifExtension thEnabled } { skip_one_varid ITidEscape }
+  "$$" @varid / { ifExtension thEnabled } { skip_two_varid ITidTyEscape }
+  "$("        / { ifExtension thEnabled } { token ITparenEscape }
+  "$$("       / { ifExtension thEnabled } { token ITparenTyEscape }
+
+  "[" @varid "|"  / { ifExtension qqEnabled }
+                     { lex_quasiquote_tok }
 
   -- qualified quasi-quote (#5555)
-  "[" @qvarid "|"  / { ifBit QqBit }  { lex_qquasiquote_tok }
+  "[" @qvarid "|"  / { ifExtension qqEnabled }
+                     { lex_qquasiquote_tok }
 
   $unigraphic -- ⟦
     / { ifCurrentChar '⟦' `alexAndPred`
-        ifBit UnicodeSyntaxBit `alexAndPred`
-        ifBit ThQuotesBit }
+        ifExtension (\i -> unicodeSyntaxEnabled i && thQuotesEnabled i) }
     { token (ITopenExpQuote NoE UnicodeSyntax) }
   $unigraphic -- ⟧
     / { ifCurrentChar '⟧' `alexAndPred`
-        ifBit UnicodeSyntaxBit `alexAndPred`
-        ifBit ThQuotesBit }
+        ifExtension (\i -> unicodeSyntaxEnabled i && thQuotesEnabled i) }
     { token (ITcloseQuote UnicodeSyntax) }
 }
 
@@ -396,45 +407,38 @@ $tab          { warnTab }
 <0> {
     [^ $idchar \) ] ^
   "@"
-    / { ifBit TypeApplicationsBit `alexAndPred` notFollowedBySymbol }
+    / { ifExtension typeApplicationEnabled `alexAndPred` notFollowedBySymbol }
     { token ITtypeApp }
 }
 
 <0> {
-  "(|"
-    / { ifBit ArrowsBit `alexAndPred`
-        notFollowedBySymbol }
-    { special (IToparenbar NormalSyntax) }
-  "|)"
-    / { ifBit ArrowsBit }
-    { special (ITcparenbar NormalSyntax) }
+  "(|" / { ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol }
+                                        { special (IToparenbar NormalSyntax) }
+  "|)" / { ifExtension arrowsEnabled }  { special (ITcparenbar NormalSyntax) }
 
   $unigraphic -- ⦇
     / { ifCurrentChar '⦇' `alexAndPred`
-        ifBit UnicodeSyntaxBit `alexAndPred`
-        ifBit ArrowsBit }
+        ifExtension (\i -> unicodeSyntaxEnabled i && arrowsEnabled i) }
     { special (IToparenbar UnicodeSyntax) }
   $unigraphic -- ⦈
     / { ifCurrentChar '⦈' `alexAndPred`
-        ifBit UnicodeSyntaxBit `alexAndPred`
-        ifBit ArrowsBit }
+        ifExtension (\i -> unicodeSyntaxEnabled i && arrowsEnabled i) }
     { special (ITcparenbar UnicodeSyntax) }
 }
 
 <0> {
-  \? @varid / { ifBit IpBit } { skip_one_varid ITdupipvarid }
+  \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
 }
 
 <0> {
-  "#" @varid / { ifBit OverloadedLabelsBit } { skip_one_varid ITlabelvarid }
+  "#" @varid / { ifExtension overloadedLabelsEnabled }
+               { skip_one_varid ITlabelvarid }
 }
 
 <0> {
-  "(#" / { ifBit UnboxedTuplesBit `alexOrPred`
-           ifBit UnboxedSumsBit }
+  "(#" / { orExtensions unboxedTuplesEnabled unboxedSumsEnabled }
          { token IToubxparen }
-  "#)" / { ifBit UnboxedTuplesBit `alexOrPred`
-           ifBit UnboxedSumsBit }
+  "#)" / { orExtensions unboxedTuplesEnabled unboxedSumsEnabled }
          { token ITcubxparen }
 }
 
@@ -459,10 +463,10 @@ $tab          { warnTab }
 }
 
 <0> {
-  @qvarid "#"+      / { ifBit MagicHashBit } { idtoken qvarid }
-  @qconid "#"+      / { ifBit MagicHashBit } { idtoken qconid }
-  @varid "#"+       / { ifBit MagicHashBit } { varid }
-  @conid "#"+       / { ifBit MagicHashBit } { idtoken conid }
+  @qvarid "#"+      / { ifExtension magicHashEnabled } { idtoken qvarid }
+  @qconid "#"+      / { ifExtension magicHashEnabled } { idtoken qconid }
+  @varid "#"+       / { ifExtension magicHashEnabled } { varid }
+  @conid "#"+       / { ifExtension magicHashEnabled } { idtoken conid }
 }
 
 -- ToDo: - move `var` and (sym) into lexical syntax?
@@ -488,51 +492,49 @@ $tab          { warnTab }
 --
 <0> {
   -- Normal integral literals (:: Num a => a, from Integer)
-  @decimal                                                             { tok_num positive 0 0 decimal }
-  0[bB] @numspc @binary                / { ifBit BinaryLiteralsBit }   { tok_num positive 2 2 binary }
-  0[oO] @numspc @octal                                                 { tok_num positive 2 2 octal }
-  0[xX] @numspc @hexadecimal                                           { tok_num positive 2 2 hexadecimal }
-  @negative @decimal                   / { ifBit NegativeLiteralsBit } { tok_num negative 1 1 decimal }
-  @negative 0[bB] @numspc @binary      / { ifBit NegativeLiteralsBit `alexAndPred`
-                                           ifBit BinaryLiteralsBit }   { tok_num negative 3 3 binary }
-  @negative 0[oO] @numspc @octal       / { ifBit NegativeLiteralsBit } { tok_num negative 3 3 octal }
-  @negative 0[xX] @numspc @hexadecimal / { ifBit NegativeLiteralsBit } { tok_num negative 3 3 hexadecimal }
+  @decimal                                                               { tok_num positive 0 0 decimal }
+  0[bB] @numspc @binary        / { ifExtension binaryLiteralsEnabled }   { tok_num positive 2 2 binary }
+  0[oO] @numspc @octal                                                   { tok_num positive 2 2 octal }
+  0[xX] @numspc @hexadecimal                                             { tok_num positive 2 2 hexadecimal }
+  @negative @decimal           / { ifExtension negativeLiteralsEnabled } { tok_num negative 1 1 decimal }
+  @negative 0[bB] @numspc @binary  / { ifExtension negativeLiteralsEnabled `alexAndPred`
+                                       ifExtension binaryLiteralsEnabled }   { tok_num negative 3 3 binary }
+  @negative 0[oO] @numspc @octal   / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 octal }
+  @negative 0[xX] @numspc @hexadecimal / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 hexadecimal }
 
   -- Normal rational literals (:: Fractional a => a, from Rational)
-  @floating_point                                                      { tok_frac 0 tok_float }
-  @negative @floating_point            / { ifBit NegativeLiteralsBit } { tok_frac 0 tok_float }
-  0[xX] @numspc @hex_floating_point    / { ifBit HexFloatLiteralsBit } { tok_frac 0 tok_hex_float }
-  @negative 0[xX] @numspc @hex_floating_point
-                                       / { ifBit HexFloatLiteralsBit `alexAndPred`
-                                           ifBit NegativeLiteralsBit } { tok_frac 0 tok_hex_float }
+  @floating_point                                                        { tok_frac 0 tok_float }
+  @negative @floating_point    / { ifExtension negativeLiteralsEnabled } { tok_frac 0 tok_float }
+  0[xX] @numspc @hex_floating_point     / { ifExtension hexFloatLiteralsEnabled } { tok_frac 0 tok_hex_float }
+  @negative 0[xX] @numspc @hex_floating_point / { ifExtension hexFloatLiteralsEnabled `alexAndPred`
+                                                  ifExtension negativeLiteralsEnabled } { tok_frac 0 tok_hex_float }
 }
 
 <0> {
   -- Unboxed ints (:: Int#) and words (:: Word#)
   -- It's simpler (and faster?) to give separate cases to the negatives,
   -- especially considering octal/hexadecimal prefixes.
-  @decimal                          \# / { ifBit MagicHashBit }        { tok_primint positive 0 1 decimal }
-  0[bB] @numspc @binary             \# / { ifBit MagicHashBit `alexAndPred`
-                                           ifBit BinaryLiteralsBit }   { tok_primint positive 2 3 binary }
-  0[oO] @numspc @octal              \# / { ifBit MagicHashBit }        { tok_primint positive 2 3 octal }
-  0[xX] @numspc @hexadecimal        \# / { ifBit MagicHashBit }        { tok_primint positive 2 3 hexadecimal }
-  @negative @decimal                \# / { ifBit MagicHashBit }        { tok_primint negative 1 2 decimal }
-  @negative 0[bB] @numspc @binary   \# / { ifBit MagicHashBit `alexAndPred`
-                                           ifBit BinaryLiteralsBit }   { tok_primint negative 3 4 binary }
-  @negative 0[oO] @numspc @octal    \# / { ifBit MagicHashBit }        { tok_primint negative 3 4 octal }
-  @negative 0[xX] @numspc @hexadecimal \#
-                                       / { ifBit MagicHashBit }        { tok_primint negative 3 4 hexadecimal }
-
-  @decimal                       \# \# / { ifBit MagicHashBit }        { tok_primword 0 2 decimal }
-  0[bB] @numspc @binary          \# \# / { ifBit MagicHashBit `alexAndPred`
-                                           ifBit BinaryLiteralsBit }   { tok_primword 2 4 binary }
-  0[oO] @numspc @octal           \# \# / { ifBit MagicHashBit }        { tok_primword 2 4 octal }
-  0[xX] @numspc @hexadecimal     \# \# / { ifBit MagicHashBit }        { tok_primword 2 4 hexadecimal }
+  @decimal                     \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal }
+  0[bB] @numspc @binary        \# / { ifExtension magicHashEnabled `alexAndPred`
+                                      ifExtension binaryLiteralsEnabled } { tok_primint positive 2 3 binary }
+  0[oO] @numspc @octal         \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal }
+  0[xX] @numspc @hexadecimal   \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal }
+  @negative @decimal           \# / { ifExtension magicHashEnabled } { tok_primint negative 1 2 decimal }
+  @negative 0[bB] @numspc @binary  \# / { ifExtension magicHashEnabled `alexAndPred`
+                                          ifExtension binaryLiteralsEnabled } { tok_primint negative 3 4 binary }
+  @negative 0[oO] @numspc @octal   \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal }
+  @negative 0[xX] @numspc @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal }
+
+  @decimal                     \# \# / { ifExtension magicHashEnabled } { tok_primword 0 2 decimal }
+  0[bB] @numspc @binary        \# \# / { ifExtension magicHashEnabled `alexAndPred`
+                                         ifExtension binaryLiteralsEnabled } { tok_primword 2 4 binary }
+  0[oO] @numspc @octal         \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 octal }
+  0[xX] @numspc @hexadecimal   \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 hexadecimal }
 
   -- Unboxed floats and doubles (:: Float#, :: Double#)
   -- prim_{float,double} work with signed literals
-  @signed @floating_point           \# / { ifBit MagicHashBit }        { tok_frac 1 tok_primfloat }
-  @signed @floating_point        \# \# / { ifBit MagicHashBit }        { tok_frac 2 tok_primdouble }
+  @signed @floating_point \# / { ifExtension magicHashEnabled } { tok_frac 1 tok_primfloat }
+  @signed @floating_point \# \# / { ifExtension magicHashEnabled } { tok_frac 2 tok_primdouble }
 }
 
 -- Strings and chars are lexed by hand-written code.  The reason is
@@ -644,8 +646,8 @@ data Token
   | ITrules_prag        SourceText
   | ITwarning_prag      SourceText
   | ITdeprecated_prag   SourceText
-  | ITline_prag         SourceText  -- not usually produced, see 'UsePosPragsBit'
-  | ITcolumn_prag       SourceText  -- not usually produced, see 'UsePosPragsBit'
+  | ITline_prag         SourceText  -- not usually produced, see 'use_pos_prags'
+  | ITcolumn_prag       SourceText  -- not usually produced, see 'use_pos_prags'
   | ITscc_prag          SourceText
   | ITgenerated_prag    SourceText
   | ITcore_prag         SourceText         -- hdaume: core annotations
@@ -751,29 +753,29 @@ data Token
   -- Arrow notation extension
   | ITproc
   | ITrec
-  | IToparenbar  IsUnicodeSyntax -- ^ @(|@
-  | ITcparenbar  IsUnicodeSyntax -- ^ @|)@
-  | ITlarrowtail IsUnicodeSyntax -- ^ @-<@
-  | ITrarrowtail IsUnicodeSyntax -- ^ @>-@
-  | ITLarrowtail IsUnicodeSyntax -- ^ @-<<@
-  | ITRarrowtail IsUnicodeSyntax -- ^ @>>-@
-
-  -- | Type application '@' (lexed differently than as-pattern '@',
+  | IToparenbar  IsUnicodeSyntax --  (|
+  | ITcparenbar  IsUnicodeSyntax --  |)
+  | ITlarrowtail IsUnicodeSyntax --  -<
+  | ITrarrowtail IsUnicodeSyntax --  >-
+  | ITLarrowtail IsUnicodeSyntax --  -<<
+  | ITRarrowtail IsUnicodeSyntax --  >>-
+
+  -- type application '@' (lexed differently than as-pattern '@',
   -- due to checking for preceding whitespace)
   | ITtypeApp
 
 
-  | ITunknown String             -- ^ Used when the lexer can't make sense of it
-  | ITeof                        -- ^ end of file token
+  | ITunknown String            -- Used when the lexer can't make sense of it
+  | ITeof                       -- end of file token
 
   -- Documentation annotations
-  | ITdocCommentNext  String     -- ^ something beginning @-- |@
-  | ITdocCommentPrev  String     -- ^ something beginning @-- ^@
-  | ITdocCommentNamed String     -- ^ something beginning @-- $@
-  | ITdocSection      Int String -- a section heading
-  | ITdocOptions      String     -- doc options (prune, ignore-exports, etc)
-  | ITlineComment     String     -- comment starting by "--"
-  | ITblockComment    String     -- comment in {- -}
+  | ITdocCommentNext  String     -- something beginning '-- |'
+  | ITdocCommentPrev  String     -- something beginning '-- ^'
+  | ITdocCommentNamed String     -- something beginning '-- $'
+  | ITdocSection      Int String -- a section heading
+  | ITdocOptions      String     -- doc options (prune, ignore-exports, etc)
+  | ITlineComment     String     -- comment starting by "--"
+  | ITblockComment    String     -- comment in {- -}
 
   deriving Show
 
@@ -825,7 +827,7 @@ reservedWordsFM = listToUFM $
          ( "family",         ITfamily,        0 ),
          ( "role",           ITrole,          0 ),
          ( "pattern",        ITpattern,       xbit PatternSynonymsBit),
-         ( "static",         ITstatic,        xbit StaticPointersBit ),
+         ( "static",         ITstatic,        0 ),
          ( "stock",          ITstock,         0 ),
          ( "anyclass",       ITanyclass,      0 ),
          ( "via",            ITvia,           0 ),
@@ -873,46 +875,50 @@ Also, note that these are included in the `varid` production in the parser --
 a key detail to make all this work.
 -------------------------------------}
 
-reservedSymsFM :: UniqFM (Token, IsUnicodeSyntax, ExtsBitmap)
+reservedSymsFM :: UniqFM (Token, ExtsBitmap -> Bool)
 reservedSymsFM = listToUFM $
-    map (\ (x,w,y,z) -> (mkFastString x,(w,y,z)))
-      [ ("..",  ITdotdot,                   NormalSyntax,  0 )
+    map (\ (x,y,z) -> (mkFastString x,(y,z)))
+      [ ("..",  ITdotdot,              always)
         -- (:) is a reserved op, meaning only list cons
-       ,(":",   ITcolon,                    NormalSyntax,  0 )
-       ,("::",  ITdcolon NormalSyntax,      NormalSyntax,  0 )
-       ,("=",   ITequal,                    NormalSyntax,  0 )
-       ,("\\",  ITlam,                      NormalSyntax,  0 )
-       ,("|",   ITvbar,                     NormalSyntax,  0 )
-       ,("<-",  ITlarrow NormalSyntax,      NormalSyntax,  0 )
-       ,("->",  ITrarrow NormalSyntax,      NormalSyntax,  0 )
-       ,("@",   ITat,                       NormalSyntax,  0 )
-       ,("~",   ITtilde,                    NormalSyntax,  0 )
-       ,("=>",  ITdarrow NormalSyntax,      NormalSyntax,  0 )
-       ,("-",   ITminus,                    NormalSyntax,  0 )
-       ,("!",   ITbang,                     NormalSyntax,  0 )
-
-       ,("*",   ITstar NormalSyntax,        NormalSyntax,  xbit StarIsTypeBit)
+       ,(":",   ITcolon,               always)
+       ,("::",  ITdcolon NormalSyntax, always)
+       ,("=",   ITequal,               always)
+       ,("\\",  ITlam,                 always)
+       ,("|",   ITvbar,                always)
+       ,("<-",  ITlarrow NormalSyntax, always)
+       ,("->",  ITrarrow NormalSyntax, always)
+       ,("@",   ITat,                  always)
+       ,("~",   ITtilde,               always)
+       ,("=>",  ITdarrow NormalSyntax, always)
+       ,("-",   ITminus,               always)
+       ,("!",   ITbang,                always)
+
+       ,("*", ITstar NormalSyntax, starIsTypeEnabled)
 
         -- For 'forall a . t'
-       ,(".",   ITdot,                      NormalSyntax,  0 )
-
-       ,("-<",  ITlarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)
-       ,(">-",  ITrarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)
-       ,("-<<", ITLarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)
-       ,(">>-", ITRarrowtail NormalSyntax,  NormalSyntax,  xbit ArrowsBit)
-
-       ,("∷",   ITdcolon UnicodeSyntax,     UnicodeSyntax, 0 )
-       ,("⇒",   ITdarrow UnicodeSyntax,     UnicodeSyntax, 0 )
-       ,("∀",   ITforall UnicodeSyntax,     UnicodeSyntax, 0 )
-       ,("→",   ITrarrow UnicodeSyntax,     UnicodeSyntax, 0 )
-       ,("←",   ITlarrow UnicodeSyntax,     UnicodeSyntax, 0 )
-
-       ,("⤙",   ITlarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)
-       ,("⤚",   ITrarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)
-       ,("⤛",   ITLarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)
-       ,("⤜",   ITRarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit)
-
-       ,("★",   ITstar UnicodeSyntax,       UnicodeSyntax, xbit StarIsTypeBit)
+       ,(".", ITdot,  always) -- \i -> explicitForallEnabled i || inRulePrag i)
+
+       ,("-<",  ITlarrowtail NormalSyntax, arrowsEnabled)
+       ,(">-",  ITrarrowtail NormalSyntax, arrowsEnabled)
+       ,("-<<", ITLarrowtail NormalSyntax, arrowsEnabled)
+       ,(">>-", ITRarrowtail NormalSyntax, arrowsEnabled)
+
+       ,("∷",   ITdcolon UnicodeSyntax, unicodeSyntaxEnabled)
+       ,("⇒",   ITdarrow UnicodeSyntax, unicodeSyntaxEnabled)
+       ,("∀",   ITforall UnicodeSyntax, unicodeSyntaxEnabled)
+       ,("→",   ITrarrow UnicodeSyntax, unicodeSyntaxEnabled)
+       ,("←",   ITlarrow UnicodeSyntax, unicodeSyntaxEnabled)
+
+       ,("⤙",   ITlarrowtail UnicodeSyntax,
+                                \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
+       ,("⤚",   ITrarrowtail UnicodeSyntax,
+                                \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
+       ,("⤛",   ITLarrowtail UnicodeSyntax,
+                                \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
+       ,("⤜",   ITRarrowtail UnicodeSyntax,
+                                \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
+       ,("★",   ITstar UnicodeSyntax,
+                  \i -> unicodeSyntaxEnabled i && starIsTypeEnabled i)
 
         -- ToDo: ideally, → and ∷ should be "specials", so that they cannot
         -- form part of a large operator.  This would let us have a better
@@ -955,21 +961,21 @@ pop _span _buf _len = do _ <- popLexState
 -- See Note [Nested comment line pragmas]
 failLinePrag1 :: Action
 failLinePrag1 span _buf _len = do
-  b <- getBit InNestedCommentBit
+  b <- extension inNestedComment
   if b then return (L span ITcomment_line_prag)
        else lexError "lexical error in pragma"
 
 -- See Note [Nested comment line pragmas]
 popLinePrag1 :: Action
 popLinePrag1 span _buf _len = do
-  b <- getBit InNestedCommentBit
+  b <- extension inNestedComment
   if b then return (L span ITcomment_line_prag) else do
     _ <- popLexState
     lexToken
 
 hopefully_open_brace :: Action
 hopefully_open_brace span buf len
- = do relaxed <- getBit RelaxedLayoutBit
+ = do relaxed <- extension relaxedLayout
       ctx <- getContext
       (AI l _) <- getInput
       let offset = srcLocCol l
@@ -1015,8 +1021,8 @@ ifCurrentChar char _ (AI _ buf) _ _
 -- the non-layout states.
 isNormalComment :: AlexAccPred ExtsBitmap
 isNormalComment bits _ _ (AI _ buf)
-  | HaddockBit `xtest` bits = notFollowedByDocOrPragma
-  | otherwise               = nextCharIsNot buf (== '#')
+  | haddockEnabled bits = notFollowedByDocOrPragma
+  | otherwise           = nextCharIsNot buf (== '#')
   where
     notFollowedByDocOrPragma
        = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#"))
@@ -1030,14 +1036,11 @@ afterOptionalSpace buf p
 atEOL :: AlexAccPred ExtsBitmap
 atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n'
 
-ifBit :: ExtBits -> AlexAccPred ExtsBitmap
-ifBit extBits bits _ _ _ = extBits `xtest` bits
-
-alexNotPred p userState in1 len in2
-  = not (p userState in1 len in2)
+ifExtension :: (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap
+ifExtension pred bits _ _ _ = pred bits
 
-alexOrPred p1 p2 userState in1 len in2
-  = p1 userState in1 len in2 || p2 userState in1 len in2
+orExtensions :: (ExtsBitmap -> Bool) -> (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap
+orExtensions pred1 pred2 bits _ _ _ = pred1 bits || pred2 bits
 
 multiline_doc_comment :: Action
 multiline_doc_comment span buf _len = withLexedDocType (worker "")
@@ -1080,7 +1083,7 @@ multiline_doc_comment span buf _len = withLexedDocType (worker "")
 
 lineCommentToken :: Action
 lineCommentToken span buf len = do
-  b <- getBit RawTokenStreamBit
+  b <- extension rawTokenStreamEnabled
   if b then strtoken ITlineComment span buf len else lexToken
 
 {-
@@ -1094,7 +1097,7 @@ nested_comment cont span buf len = do
   where
     go commentAcc 0 input = do
       setInput input
-      b <- getBit RawTokenStreamBit
+      b <- extension rawTokenStreamEnabled
       if b
         then docCommentEnd input commentAcc ITblockComment buf span
         else cont
@@ -1213,23 +1216,23 @@ rulePrag span buf len = do
   let !src = lexemeToString buf len
   return (L span (ITrules_prag (SourceText src)))
 
--- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead
+-- When 'use_pos_prags' is not set, it is expected that we emit a token instead
 -- of updating the position in 'PState'
 linePrag :: Action
 linePrag span buf len = do
-  usePosPrags <- getBit UsePosPragsBit
-  if usePosPrags
+  ps <- getPState
+  if use_pos_prags ps
     then begin line_prag2 span buf len
     else let !src = lexemeToString buf len
          in return (L span (ITline_prag (SourceText src)))
 
--- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead
+-- When 'use_pos_prags' is not set, it is expected that we emit a token instead
 -- of updating the position in 'PState'
 columnPrag :: Action
 columnPrag span buf len = do
-  usePosPrags <- getBit UsePosPragsBit
+  ps <- getPState
   let !src = lexemeToString buf len
-  if usePosPrags
+  if use_pos_prags ps
     then begin column_prag span buf len
     else let !src = lexemeToString buf len
          in return (L span (ITcolumn_prag (SourceText src)))
@@ -1312,19 +1315,24 @@ varid span buf len =
       lastTk <- getLastTk
       keyword <- case lastTk of
         Just ITlam -> do
-          lambdaCase <- getBit LambdaCaseBit
+          lambdaCase <- extension lambdaCaseEnabled
           if lambdaCase
             then return ITlcase
             else failMsgP "Illegal lambda-case (use -XLambdaCase)"
         _ -> return ITcase
       maybe_layout keyword
       return $ L span keyword
+    Just (ITstatic, _) -> do
+      staticPointers <- extension staticPointersEnabled
+      if staticPointers
+        then return $ L span ITstatic
+        else return $ L span $ ITvarid fs
     Just (keyword, 0) -> do
       maybe_layout keyword
       return $ L span keyword
-    Just (keyword, i) -> do
-      exts <- getExts
-      if exts .&. i /= 0
+    Just (keyword, exts) -> do
+      extsEnabled <- extension $ \i -> exts .&. i /= 0
+      if extsEnabled
         then do
           maybe_layout keyword
           return $ L span keyword
@@ -1349,18 +1357,11 @@ consym = sym ITconsym
 sym :: (FastString -> Token) -> Action
 sym con span buf len =
   case lookupUFM reservedSymsFM fs of
-    Just (keyword, NormalSyntax, 0) ->
-      return $ L span keyword
-    Just (keyword, NormalSyntax, i) -> do
-      exts <- getExts
-      if exts .&. i /= 0
-        then return $ L span keyword
-        else return $ L span (con fs)
-    Just (keyword, UnicodeSyntax, i) -> do
-      exts <- getExts
-      if exts .&. i /= 0 && xtest UnicodeSyntaxBit exts
-        then return $ L span keyword
-        else return $ L span (con fs)
+    Just (keyword, exts) -> do
+      extsEnabled <- extension exts
+      let !tk | extsEnabled = keyword
+              | otherwise   = con fs
+      return $ L span tk
     Nothing ->
       return $ L span $! con fs
   where
@@ -1373,7 +1374,7 @@ tok_integral :: (SourceText -> Integer -> Token)
              -> (Integer, (Char -> Int))
              -> Action
 tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = do
-  numericUnderscores <- getBit NumericUnderscoresBit  -- #14473
+  numericUnderscores <- extension numericUnderscoresEnabled  -- #14473
   let src = lexemeToString buf len
   if (not numericUnderscores) && ('_' `elem` src)
     then failMsgP "Use NumericUnderscores to allow underscores in integer literals"
@@ -1413,7 +1414,7 @@ hexadecimal = (16,hexDigit)
 -- readRational can understand negative rationals, exponents, everything.
 tok_frac :: Int -> (String -> Token) -> Action
 tok_frac drop f span buf len = do
-  numericUnderscores <- getBit NumericUnderscoresBit  -- #14473
+  numericUnderscores <- extension numericUnderscoresEnabled  -- #14473
   let src = lexemeToString buf (len-drop)
   if (not numericUnderscores) && ('_' `elem` src)
     then failMsgP "Use NumericUnderscores to allow underscores in floating literals"
@@ -1445,7 +1446,7 @@ readHexFractionalLit str =
 do_bol :: Action
 do_bol span _str _len = do
         -- See Note [Nested comment line pragmas]
-        b <- getBit InNestedCommentBit
+        b <- extension inNestedComment
         if b then return (L span ITcomment_line_prag) else do
           (pos, gen_semic) <- getOffside
           case pos of
@@ -1472,7 +1473,7 @@ maybe_layout t = do -- If the alternative layout rule is enabled then
                     -- inserting implicit semi-colons, is therefore
                     -- irrelevant as it only applies in an implicit
                     -- context.
-                    alr <- getBit AlternativeLayoutRuleBit
+                    alr <- extension alternativeLayoutRule
                     unless alr $ f t
     where f ITdo    = pushLexState layout_do
           f ITmdo   = pushLexState layout_do
@@ -1498,7 +1499,7 @@ new_layout_context strict gen_semic tok span _buf len = do
     (AI l _) <- getInput
     let offset = srcLocCol l - len
     ctx <- getContext
-    nondecreasing <- getBit NondecreasingIndentationBit
+    nondecreasing <- extension nondecreasingIndentation
     let strict' = strict || not nondecreasing
     case ctx of
         Layout prev_off _ : _  |
@@ -1614,7 +1615,7 @@ lex_string s = do
 
     Just ('"',i)  -> do
         setInput i
-        magicHash <- getBit MagicHashBit
+        magicHash <- extension magicHashEnabled
         if magicHash
           then do
             i <- getInput
@@ -1701,7 +1702,7 @@ lex_char_tok span buf _len = do        -- We've seen '
 finish_char_tok :: StringBuffer -> RealSrcLoc -> Char -> P (RealLocated Token)
 finish_char_tok buf loc ch  -- We've already seen the closing quote
                         -- Just need to check for trailing #
-  = do  magicHash <- getBit MagicHashBit
+  = do  magicHash <- extension magicHashEnabled
         i@(AI end bufEnd) <- getInput
         let src = lexemeToString buf (cur bufEnd - cur buf)
         if magicHash then do
@@ -1977,6 +1978,10 @@ data PState = PState {
         -- token doesn't need to close anything:
         alr_justClosedExplicitLetBlock :: Bool,
 
+        -- If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}'
+        -- update the 'loc' field. Otherwise, those pragmas are lexed as tokens.
+        use_pos_prags :: Bool,
+
         -- The next three are used to implement Annotations giving the
         -- locations of 'noise' tokens in the source, so that users of
         -- the GHC API can do source to source conversions.
@@ -2050,6 +2055,9 @@ getPState = P $ \s -> POk s s
 withThisPackage :: (UnitId -> a) -> P a
 withThisPackage f = P $ \s@(PState{options = o}) -> POk s (f (pThisPackage o))
 
+extension :: (ExtsBitmap -> Bool) -> P Bool
+extension p = P $ \s -> POk s (p $! (pExtsBitmap . options) s)
+
 getExts :: P ExtsBitmap
 getExts = P $ \s -> POk s (pExtsBitmap . options $ s)
 
@@ -2234,6 +2242,9 @@ getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs
 setALRContext :: [ALRContext] -> P ()
 setALRContext cs = P $ \s -> POk (s {alr_context = cs}) ()
 
+getALRTransitional :: P Bool
+getALRTransitional = extension alternativeLayoutTransitionalRule
+
 getJustClosedExplicitLetBlock :: P Bool
 getJustClosedExplicitLetBlock
  = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b
@@ -2268,26 +2279,19 @@ getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b
 setAlrExpectingOCurly :: Maybe ALRLayout -> P ()
 setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
 
--- | For reasons of efficiency, boolean parsing flags (eg, language extensions
--- or whether we are currently in a @RULE@ pragma) are represented by a bitmap
--- stored in a @Word64@.
+-- for reasons of efficiency, flags indicating language extensions (eg,
+-- -fglasgow-exts or -XParallelArrays) are represented by a bitmap
+-- stored in an unboxed Word64
 type ExtsBitmap = Word64
 
--- | Check if a given flag is currently set in the bitmap.
-getBit :: ExtBits -> P Bool
-getBit ext = P $ \s -> let b =  ext `xtest` pExtsBitmap (options s)
-                       in b `seq` POk s b
-
 xbit :: ExtBits -> ExtsBitmap
 xbit = bit . fromEnum
 
 xtest :: ExtBits -> ExtsBitmap -> Bool
 xtest ext xmap = testBit xmap (fromEnum ext)
 
--- | Various boolean flags, mostly language extensions, that impact lexing and
--- parsing. Note that a handful of these can change during lexing/parsing.
+-- | Subset of the language extensions that impact lexing and parsing.
 data ExtBits
-  -- Flags that are constant once parsing starts
   = FfiBit
   | InterruptibleFfiBit
   | CApiFfiBit
@@ -2309,6 +2313,8 @@ data ExtBits
   | DatatypeContextsBit
   | TransformComprehensionsBit
   | QqBit -- enable quasiquoting
+  | InRulePragBit
+  | InNestedCommentBit -- See Note [Nested comment line pragmas]
   | RawTokenStreamBit -- producing a token stream with all comments included
   | AlternativeLayoutRuleBit
   | ALRTransitionalBit
@@ -2330,17 +2336,87 @@ data ExtBits
   | DoAndIfThenElseBit
   | MultiWayIfBit
   | GadtSyntaxBit
-
-  -- Flags that are updated once parsing starts
-  | InRulePragBit
-  | InNestedCommentBit -- See Note [Nested comment line pragmas]
-  | UsePosPragsBit
-    -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}'
-    -- update the internal position. Otherwise, those pragmas are lexed as
-    -- tokens of their own.
   deriving Enum
 
-
+always :: ExtsBitmap -> Bool
+always           _     = True
+arrowsEnabled :: ExtsBitmap -> Bool
+arrowsEnabled = xtest ArrowsBit
+thEnabled :: ExtsBitmap -> Bool
+thEnabled = xtest ThBit
+thQuotesEnabled :: ExtsBitmap -> Bool
+thQuotesEnabled = xtest ThQuotesBit
+ipEnabled :: ExtsBitmap -> Bool
+ipEnabled = xtest IpBit
+overloadedLabelsEnabled :: ExtsBitmap -> Bool
+overloadedLabelsEnabled = xtest OverloadedLabelsBit
+explicitForallEnabled :: ExtsBitmap -> Bool
+explicitForallEnabled = xtest ExplicitForallBit
+bangPatEnabled :: ExtsBitmap -> Bool
+bangPatEnabled = xtest BangPatBit
+haddockEnabled :: ExtsBitmap -> Bool
+haddockEnabled = xtest HaddockBit
+magicHashEnabled :: ExtsBitmap -> Bool
+magicHashEnabled = xtest MagicHashBit
+unicodeSyntaxEnabled :: ExtsBitmap -> Bool
+unicodeSyntaxEnabled = xtest UnicodeSyntaxBit
+unboxedTuplesEnabled :: ExtsBitmap -> Bool
+unboxedTuplesEnabled = xtest UnboxedTuplesBit
+unboxedSumsEnabled :: ExtsBitmap -> Bool
+unboxedSumsEnabled = xtest UnboxedSumsBit
+datatypeContextsEnabled :: ExtsBitmap -> Bool
+datatypeContextsEnabled = xtest DatatypeContextsBit
+monadComprehensionsEnabled :: ExtsBitmap -> Bool
+monadComprehensionsEnabled = xtest TransformComprehensionsBit
+qqEnabled :: ExtsBitmap -> Bool
+qqEnabled = xtest QqBit
+inRulePrag :: ExtsBitmap -> Bool
+inRulePrag = xtest InRulePragBit
+inNestedComment :: ExtsBitmap -> Bool
+inNestedComment = xtest InNestedCommentBit
+rawTokenStreamEnabled :: ExtsBitmap -> Bool
+rawTokenStreamEnabled = xtest RawTokenStreamBit
+alternativeLayoutRule :: ExtsBitmap -> Bool
+alternativeLayoutRule = xtest AlternativeLayoutRuleBit
+alternativeLayoutTransitionalRule :: ExtsBitmap -> Bool
+alternativeLayoutTransitionalRule = xtest ALRTransitionalBit
+relaxedLayout :: ExtsBitmap -> Bool
+relaxedLayout = xtest RelaxedLayoutBit
+nondecreasingIndentation :: ExtsBitmap -> Bool
+nondecreasingIndentation = xtest NondecreasingIndentationBit
+traditionalRecordSyntaxEnabled :: ExtsBitmap -> Bool
+traditionalRecordSyntaxEnabled = xtest TraditionalRecordSyntaxBit
+
+explicitNamespacesEnabled :: ExtsBitmap -> Bool
+explicitNamespacesEnabled = xtest ExplicitNamespacesBit
+lambdaCaseEnabled :: ExtsBitmap -> Bool
+lambdaCaseEnabled = xtest LambdaCaseBit
+binaryLiteralsEnabled :: ExtsBitmap -> Bool
+binaryLiteralsEnabled = xtest BinaryLiteralsBit
+negativeLiteralsEnabled :: ExtsBitmap -> Bool
+negativeLiteralsEnabled = xtest NegativeLiteralsBit
+hexFloatLiteralsEnabled :: ExtsBitmap -> Bool
+hexFloatLiteralsEnabled = xtest HexFloatLiteralsBit
+patternSynonymsEnabled :: ExtsBitmap -> Bool
+patternSynonymsEnabled = xtest PatternSynonymsBit
+typeApplicationEnabled :: ExtsBitmap -> Bool
+typeApplicationEnabled = xtest TypeApplicationsBit
+staticPointersEnabled :: ExtsBitmap -> Bool
+staticPointersEnabled = xtest StaticPointersBit
+numericUnderscoresEnabled :: ExtsBitmap -> Bool
+numericUnderscoresEnabled = xtest NumericUnderscoresBit
+starIsTypeEnabled :: ExtsBitmap -> Bool
+starIsTypeEnabled = xtest StarIsTypeBit
+blockArgumentsEnabled :: ExtsBitmap -> Bool
+blockArgumentsEnabled = xtest BlockArgumentsBit
+nPlusKPatternsEnabled :: ExtsBitmap -> Bool
+nPlusKPatternsEnabled = xtest NPlusKPatternsBit
+doAndIfThenElseEnabled :: ExtsBitmap -> Bool
+doAndIfThenElseEnabled = xtest DoAndIfThenElseBit
+multiWayIfEnabled :: ExtsBitmap -> Bool
+multiWayIfEnabled = xtest MultiWayIfBit
+gadtSyntaxEnabled :: ExtsBitmap -> Bool
+gadtSyntaxEnabled = xtest GadtSyntaxBit
 
 
 
@@ -2359,16 +2435,10 @@ mkParserFlags'
   -> Bool                       -- ^ are safe imports on?
   -> Bool                       -- ^ keeping Haddock comment tokens
   -> Bool                       -- ^ keep regular comment tokens
-
-  -> Bool
-  -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' update
-  -- the internal position kept by the parser. Otherwise, those pragmas are
-  -- lexed as 'ITline_prag' and 'ITcolumn_prag' tokens.
-
   -> ParserFlags
 -- ^ Given exactly the information needed, set up the 'ParserFlags'
 mkParserFlags' warningFlags extensionFlags thisPackage
-  safeImports isHaddock rawTokStream usePosPrags =
+  safeImports isHaddock rawTokStream =
     ParserFlags {
       pWarningFlags = warningFlags
     , pThisPackage = thisPackage
@@ -2419,7 +2489,6 @@ mkParserFlags' warningFlags extensionFlags thisPackage
     optBits =
           HaddockBit        `setBitIf` isHaddock
       .|. RawTokenStreamBit `setBitIf` rawTokStream
-      .|. UsePosPragsBit    `setBitIf` usePosPrags
 
     xoptBit bit ext = bit `setBitIf` EnumSet.member ext extensionFlags
 
@@ -2437,7 +2506,6 @@ mkParserFlags =
     <*> safeImportsOn
     <*> gopt Opt_Haddock
     <*> gopt Opt_KeepRawTokenStream
-    <*> const True
 
 -- | Creates a parse state from a 'DynFlags' value
 mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
@@ -2465,6 +2533,7 @@ mkPStatePure options buf loc =
       alr_context = [],
       alr_expecting_ocurly = Nothing,
       alr_justClosedExplicitLetBlock = False,
+      use_pos_prags = True,
       annotations = [],
       comment_q = [],
       annotations_comments = []
@@ -2574,8 +2643,8 @@ srcParseErr options buf len
         pattern = decodePrevNChars 8 buf
         last100 = decodePrevNChars 100 buf
         mdoInLast100 = "mdo" `isInfixOf` last100
-        th_enabled = ThBit `xtest` pExtsBitmap options
-        ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options
+        th_enabled = thEnabled (pExtsBitmap options)
+        ps_enabled = patternSynonymsEnabled (pExtsBitmap options)
 
 -- Report a parse failure, giving the span of the previous token as
 -- the location of the error.  This is the entry point for errors
@@ -2599,7 +2668,7 @@ lexError str = do
 
 lexer :: Bool -> (Located Token -> P a) -> P a
 lexer queueComments cont = do
-  alr <- getBit AlternativeLayoutRuleBit
+  alr <- extension alternativeLayoutRule
   let lexTokenFun = if alr then lexTokenAlr else lexToken
   (L span tok) <- lexTokenFun
   --trace ("token: " ++ show tok) $ do
@@ -2644,7 +2713,7 @@ alternativeLayoutRuleToken t
     = do context <- getALRContext
          lastLoc <- getAlrLastLoc
          mExpectingOCurly <- getAlrExpectingOCurly
-         transitional <- getBit ALRTransitionalBit
+         transitional <- getALRTransitional
          justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock
          setJustClosedExplicitLetBlock False
          let thisLoc = getLoc t
@@ -2875,10 +2944,9 @@ reportLexError loc1 loc2 buf str
      else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
 
 lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
-lexTokenStream buf loc dflags = unP go initState{ options = opts' }
+lexTokenStream buf loc dflags = unP go initState
     where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
-          initState@PState{ options = opts } = mkPState dflags' buf loc
-          opts' = opts{ pExtsBitmap = xbit UsePosPragsBit .|. pExtsBitmap opts }
+          initState = (mkPState dflags' buf loc) { use_pos_prags = False }
           go = do
             ltok <- lexer False return
             case ltok of
index 4821e28..4c2e3e7 100644 (file)
@@ -3744,14 +3744,14 @@ fileSrcSpan = do
 -- Hint about the MultiWayIf extension
 hintMultiWayIf :: SrcSpan -> P ()
 hintMultiWayIf span = do
-  mwiEnabled <- getBit MultiWayIfBit
+  mwiEnabled <- extension multiWayIfEnabled
   unless mwiEnabled $ parseErrorSDoc span $
     text "Multi-way if-expressions need MultiWayIf turned on"
 
 -- Hint about if usage for beginners
 hintIf :: SrcSpan -> String -> P (LHsExpr GhcPs)
 hintIf span msg = do
-  mwiEnabled <- getBit MultiWayIfBit
+  mwiEnabled <- extension multiWayIfEnabled
   if mwiEnabled
     then parseErrorSDoc span $ text $ "parse error in if statement"
     else parseErrorSDoc span $ text $ "parse error in if statement: "++msg
@@ -3759,8 +3759,8 @@ hintIf span msg = do
 -- Hint about explicit-forall, assuming UnicodeSyntax is on
 hintExplicitForall :: SrcSpan -> P ()
 hintExplicitForall span = do
-    forall   <- getBit ExplicitForallBit
-    rulePrag <- getBit InRulePragBit
+    forall      <- extension explicitForallEnabled
+    rulePrag    <- extension inRulePrag
     unless (forall || rulePrag) $ parseErrorSDoc span $ vcat
       [ text "Illegal symbol '\x2200' in type" -- U+2200 FOR ALL
       , text "Perhaps you intended to use RankNTypes or a similar language"
@@ -3770,7 +3770,7 @@ hintExplicitForall span = do
 -- Hint about explicit-forall, assuming UnicodeSyntax is off
 hintExplicitForall' :: SrcSpan -> P (GenLocated SrcSpan RdrName)
 hintExplicitForall' span = do
-    forall <- getBit ExplicitForallBit
+    forall    <- extension explicitForallEnabled
     let illegalDot = "Illegal symbol '.' in type"
     if forall
       then parseErrorSDoc span $ vcat
@@ -3790,7 +3790,7 @@ checkIfBang _ = False
 -- | Warn about missing space after bang
 warnSpaceAfterBang :: SrcSpan -> P ()
 warnSpaceAfterBang span = do
-    bang_on <- getBit BangPatBit
+    bang_on <- extension bangPatEnabled
     unless bang_on $
       addWarning Opt_WarnSpaceAfterBang span msg
     where
@@ -3803,7 +3803,7 @@ warnSpaceAfterBang span = do
 -- variable or constructor. See Trac #13450.
 reportEmptyDoubleQuotes :: SrcSpan -> P (GenLocated SrcSpan (HsExpr GhcPs))
 reportEmptyDoubleQuotes span = do
-    thQuotes <- getBit ThQuotesBit
+    thQuotes <- extension thQuotesEnabled
     if thQuotes
       then parseErrorSDoc span $ vcat
         [ text "Parser error on `''`"
index ef8b10e..b95b117 100644 (file)
@@ -844,7 +844,7 @@ equalsDots = text "= ..."
 checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
 checkDatatypeContext Nothing = return ()
 checkDatatypeContext (Just (L loc c))
-    = do allowed <- getBit DatatypeContextsBit
+    = do allowed <- extension datatypeContextsEnabled
          unless allowed $
              parseErrorSDoc loc
                  (text "Illegal datatype context (use DatatypeContexts):" <+>
@@ -879,7 +879,7 @@ checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
 
 checkRecordSyntax :: Outputable a => Located a -> P (Located a)
 checkRecordSyntax lr@(L loc r)
-    = do allowed <- getBit TraditionalRecordSyntaxBit
+    = do allowed <- extension traditionalRecordSyntaxEnabled
          if allowed
              then return lr
              else parseErrorSDoc loc
@@ -891,7 +891,7 @@ checkRecordSyntax lr@(L loc r)
 checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
                 -> P (Located ([AddAnn], [LConDecl GhcPs]))
 checkEmptyGADTs gadts@(L span (_, []))               -- Empty GADT declaration.
-    = do gadtSyntax <- getBit GadtSyntaxBit   -- GADTs implies GADTSyntax
+    = do gadtSyntax <- extension gadtSyntaxEnabled   -- GADTs implies GADTSyntax
          if gadtSyntax
             then return gadts
             else parseErrorSDoc span $ vcat
@@ -956,7 +956,7 @@ checkBlockArguments expr = case unLoc expr of
     _ -> return ()
   where
     check element = do
-      blockArguments <- getBit BlockArgumentsBit
+      blockArguments <- extension blockArgumentsEnabled
       unless blockArguments $
         parseErrorSDoc (getLoc expr) $
           text "Unexpected " <> text element <> text " in function application:"
@@ -1042,7 +1042,7 @@ checkPat msg loc e _
 
 checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (Pat GhcPs)
 checkAPat msg loc e0 = do
- nPlusKPatterns <- getBit NPlusKPatternsBit
+ nPlusKPatterns <- extension nPlusKPatternsEnabled
  case e0 of
    EWildPat _ -> return (WildPat noExt)
    HsVar _ x  -> return (VarPat noExt x)
@@ -1239,7 +1239,7 @@ checkDoAndIfThenElse :: LHsExpr GhcPs
                      -> P ()
 checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
  | semiThen || semiElse
-    = do doAndIfThenElse <- getBit DoAndIfThenElseBit
+    = do doAndIfThenElse <- extension doAndIfThenElseEnabled
          unless doAndIfThenElse $ do
              parseErrorSDoc (combineLocs guardExpr elseExpr)
                             (text "Unexpected semi-colons in conditional:"
@@ -1310,7 +1310,7 @@ isFunLhs e = go e [] []
 
    go e@(L loc (OpApp _ l (L loc' (HsVar _ (L _ op))) r)) es ann
         | Just (e',es') <- splitBang e
-        = do { bang_on <- getBit BangPatBit
+        = do { bang_on <- extension bangPatEnabled
              ; if bang_on then go e' (es' ++ es) ann
                else return (Just (L loc' op, Infix, (l:r:es), ann)) }
                 -- No bangs; behave just like the next case
@@ -1740,14 +1740,14 @@ mergeDataCon all_xs =
             nest 2 (hsep . reverse $ map ppr all_xs'))
 
 ---------------------------------------------------------------------------
--- Check for monad comprehensions
+-- Check for monad comprehensions
 --
--- If the flag MonadComprehensions is set, return a 'MonadComp' context,
--- otherwise use the usual 'ListComp' context
+-- If the flag MonadComprehensions is set, return a `MonadComp' context,
+-- otherwise use the usual `ListComp' context
 
 checkMonadComp :: P (HsStmtContext Name)
 checkMonadComp = do
-    monadComprehensions <- getBit TransformComprehensionsBit
+    monadComprehensions <- extension monadComprehensionsEnabled
     return $ if monadComprehensions
                 then MonadComp
                 else ListComp
@@ -2065,8 +2065,8 @@ mkModuleImpExp (L l specname) subs =
     ImpExpList xs        ->
       (\newName -> IEThingWith noExt (L l newName) NoIEWildcard (wrapped xs) [])
         <$> nameT
-    ImpExpAllWith xs     ->
-      do allowed <- getBit PatternSynonymsBit
+    ImpExpAllWith xs                       ->
+      do allowed <- extension patternSynonymsEnabled
          if allowed
           then
             let withs = map unLoc xs
@@ -2103,7 +2103,7 @@ mkModuleImpExp (L l specname) subs =
 mkTypeImpExp :: Located RdrName   -- TcCls or Var name space
              -> P (Located RdrName)
 mkTypeImpExp name =
-  do allowed <- getBit ExplicitNamespacesBit
+  do allowed <- extension explicitNamespacesEnabled
      if allowed
        then return (fmap (`setRdrNameSpace` tcClsName) name)
        else parseErrorSDoc (getLoc name)
@@ -2159,7 +2159,7 @@ warnStarBndr span = addWarning Opt_WarnStarBinder span msg
 
 failOpFewArgs :: Located RdrName -> P a
 failOpFewArgs (L loc op) =
-  do { star_is_type <- getBit StarIsTypeBit
+  do { star_is_type <- extension starIsTypeEnabled
      ; let msg = too_few $$ starInfo star_is_type op
      ; parseErrorSDoc loc msg }
   where
@@ -2191,7 +2191,7 @@ parseErrorSDoc span s = failSpanMsgP span s
 -- | Hint about bang patterns, assuming @BangPatterns@ is off.
 hintBangPat :: SrcSpan -> HsExpr GhcPs -> P ()
 hintBangPat span e = do
-    bang_on <- getBit BangPatBit
+    bang_on <- extension bangPatEnabled
     unless bang_on $
       parseErrorSDoc span
         (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)