summaryrefslogtreecommitdiff
path: root/compiler/parser
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2018-11-23 14:09:28 -0500
committerBen Gamari <ben@smart-cactus.org>2018-11-23 14:09:28 -0500
commitf61f71c48e2f1aec8999b632bc5722391a42d036 (patch)
tree0ce3cfbe0ff0c3d68ccf8d4094378630b26395ae /compiler/parser
parentc2be6d5e9a7137aa480874fe0929f12264860c6e (diff)
downloadhaskell-f61f71c48e2f1aec8999b632bc5722391a42d036.tar.gz
Revert "Simplify 'ExtBits' in the lexer"
This reverts commit d2fbc33c4ff3074126ab71654af8bbf8a46e4e11.
Diffstat (limited to 'compiler/parser')
-rw-r--r--compiler/parser/Lexer.x498
-rw-r--r--compiler/parser/Parser.y14
-rw-r--r--compiler/parser/RdrHsSyn.hs32
3 files changed, 306 insertions, 238 deletions
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 89ddfea3ce..4572e6d9af 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -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
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 4821e28421..4c2e3e7660 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -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 `''`"
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index ef8b10eea2..b95b117419 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -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)