Commit 469fe613 authored by Alec Theriault's avatar Alec Theriault Committed by Ben Gamari

'DynFlag'-free version of 'mkParserFlags'

Summary:
This is a fixed version of the reverted d2fbc33c
and  5aa29231.

Obtaining a `DynFlags` is difficult, making using the lexer/parser
for pure parsing/lexing unreasonably difficult, even with `mkPStatePure`.
This is despite the fact that we only really need

    * language extension flags
    * warning flags
    * a handful of boolean options

The new `mkParserFlags'` function makes is easier to directly construct a
`ParserFlags`. Furthermore, since `pExtsBitmap` is just a footgun, I've gone
ahead and made `ParserFlags` an abstract type.

Also, we now export `ExtBits` and `getBit` instead of defining/exporting a
bunch of boilerplate functions that test for a particular 'ExtBits'.
In the process, I also

  * cleaned up an unneeded special case for `ITstatic`
  * made `UsePosPrags` another variant of `ExtBits`
  * made the logic in `reservedSymsFM` match that of `reservedWordsFM`

Test Plan: make test

Reviewers: bgamari, alanz, tdammers

Subscribers: sjakobi, tdammers, rwbarton, mpickering, carter

GHC Trac Issues: #11301

Differential Revision: https://phabricator.haskell.org/D5405
parent d512b330
......@@ -48,21 +48,14 @@
module Lexer (
Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..),
P(..), ParseResult(..), mkParserFlags, ParserFlags(..), getRealSrcLoc,
getPState, extopt, withThisPackage,
P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags,
getRealSrcLoc, getPState, withThisPackage,
failLocMsgP, failSpanMsgP, srcParseFail,
getMessages,
popContext, pushModuleContext, setLastToken, setSrcLoc,
activeContext, nextIsEOF,
getLexState, popLexState, pushLexState,
extension, bangPatEnabled, datatypeContextsEnabled,
traditionalRecordSyntaxEnabled,
explicitForallEnabled,
inRulePrag,
explicitNamespacesEnabled,
patternSynonymsEnabled,
sccProfilingOn, hpcEnabled,
starIsTypeEnabled,
ExtBits(..), getBit,
addWarning,
lexTokenStream,
addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
......@@ -235,7 +228,7 @@ $tab { warnTab }
-- Next, match Haddock comments if no -haddock flag
"-- " $docsym .* / { ifExtension (not . haddockEnabled) } { lineCommentToken }
"-- " $docsym .* / { alexNotPred (ifExtension HaddockBit) } { 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
......@@ -361,44 +354,41 @@ $tab { warnTab }
-- Haddock comments
<0,option_prags> {
"-- " $docsym / { ifExtension haddockEnabled } { multiline_doc_comment }
"{-" \ ? $docsym / { ifExtension haddockEnabled } { nested_doc_comment }
"-- " $docsym / { ifExtension HaddockBit } { multiline_doc_comment }
"{-" \ ? $docsym / { ifExtension HaddockBit } { nested_doc_comment }
}
-- "special" symbols
<0> {
"[|" / { 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 }
"[|" / { ifExtension ThQuotesBit } { token (ITopenExpQuote NoE NormalSyntax) }
"[||" / { ifExtension ThQuotesBit } { token (ITopenTExpQuote NoE) }
"[e|" / { ifExtension ThQuotesBit } { token (ITopenExpQuote HasE NormalSyntax) }
"[e||" / { ifExtension ThQuotesBit } { token (ITopenTExpQuote HasE) }
"[p|" / { ifExtension ThQuotesBit } { token ITopenPatQuote }
"[d|" / { ifExtension ThQuotesBit } { layout_token ITopenDecQuote }
"[t|" / { ifExtension ThQuotesBit } { token ITopenTypQuote }
"|]" / { ifExtension ThQuotesBit } { token (ITcloseQuote NormalSyntax) }
"||]" / { ifExtension ThQuotesBit } { token ITcloseTExpQuote }
\$ @varid / { ifExtension ThBit } { skip_one_varid ITidEscape }
"$$" @varid / { ifExtension ThBit } { skip_two_varid ITidTyEscape }
"$(" / { ifExtension ThBit } { token ITparenEscape }
"$$(" / { ifExtension ThBit } { token ITparenTyEscape }
"[" @varid "|" / { ifExtension QqBit } { lex_quasiquote_tok }
-- qualified quasi-quote (#5555)
"[" @qvarid "|" / { ifExtension qqEnabled }
{ lex_qquasiquote_tok }
"[" @qvarid "|" / { ifExtension QqBit } { lex_qquasiquote_tok }
$unigraphic -- ⟦
/ { ifCurrentChar '⟦' `alexAndPred`
ifExtension (\i -> unicodeSyntaxEnabled i && thQuotesEnabled i) }
ifExtension UnicodeSyntaxBit `alexAndPred`
ifExtension ThQuotesBit }
{ token (ITopenExpQuote NoE UnicodeSyntax) }
$unigraphic -- ⟧
/ { ifCurrentChar '⟧' `alexAndPred`
ifExtension (\i -> unicodeSyntaxEnabled i && thQuotesEnabled i) }
ifExtension UnicodeSyntaxBit `alexAndPred`
ifExtension ThQuotesBit }
{ token (ITcloseQuote UnicodeSyntax) }
}
......@@ -406,38 +396,45 @@ $tab { warnTab }
<0> {
[^ $idchar \) ] ^
"@"
/ { ifExtension typeApplicationEnabled `alexAndPred` notFollowedBySymbol }
/ { ifExtension TypeApplicationsBit `alexAndPred` notFollowedBySymbol }
{ token ITtypeApp }
}
<0> {
"(|" / { ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol }
{ special (IToparenbar NormalSyntax) }
"|)" / { ifExtension arrowsEnabled } { special (ITcparenbar NormalSyntax) }
"(|"
/ { ifExtension ArrowsBit `alexAndPred`
notFollowedBySymbol }
{ special (IToparenbar NormalSyntax) }
"|)"
/ { ifExtension ArrowsBit }
{ special (ITcparenbar NormalSyntax) }
$unigraphic -- ⦇
/ { ifCurrentChar '⦇' `alexAndPred`
ifExtension (\i -> unicodeSyntaxEnabled i && arrowsEnabled i) }
ifExtension UnicodeSyntaxBit `alexAndPred`
ifExtension ArrowsBit }
{ special (IToparenbar UnicodeSyntax) }
$unigraphic -- ⦈
/ { ifCurrentChar '⦈' `alexAndPred`
ifExtension (\i -> unicodeSyntaxEnabled i && arrowsEnabled i) }
ifExtension UnicodeSyntaxBit `alexAndPred`
ifExtension ArrowsBit }
{ special (ITcparenbar UnicodeSyntax) }
}
<0> {
\? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
\? @varid / { ifExtension IpBit } { skip_one_varid ITdupipvarid }
}
<0> {
"#" @varid / { ifExtension overloadedLabelsEnabled }
{ skip_one_varid ITlabelvarid }
"#" @varid / { ifExtension OverloadedLabelsBit } { skip_one_varid ITlabelvarid }
}
<0> {
"(#" / { orExtensions unboxedTuplesEnabled unboxedSumsEnabled }
"(#" / { ifExtension UnboxedTuplesBit `alexOrPred`
ifExtension UnboxedSumsBit }
{ token IToubxparen }
"#)" / { orExtensions unboxedTuplesEnabled unboxedSumsEnabled }
"#)" / { ifExtension UnboxedTuplesBit `alexOrPred`
ifExtension UnboxedSumsBit }
{ token ITcubxparen }
}
......@@ -462,10 +459,10 @@ $tab { warnTab }
}
<0> {
@qvarid "#"+ / { ifExtension magicHashEnabled } { idtoken qvarid }
@qconid "#"+ / { ifExtension magicHashEnabled } { idtoken qconid }
@varid "#"+ / { ifExtension magicHashEnabled } { varid }
@conid "#"+ / { ifExtension magicHashEnabled } { idtoken conid }
@qvarid "#"+ / { ifExtension MagicHashBit } { idtoken qvarid }
@qconid "#"+ / { ifExtension MagicHashBit } { idtoken qconid }
@varid "#"+ / { ifExtension MagicHashBit } { varid }
@conid "#"+ / { ifExtension MagicHashBit } { idtoken conid }
}
-- ToDo: - move `var` and (sym) into lexical syntax?
......@@ -491,49 +488,51 @@ $tab { warnTab }
--
<0> {
-- Normal integral literals (:: Num a => a, from Integer)
@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 }
@decimal { tok_num positive 0 0 decimal }
0[bB] @numspc @binary / { ifExtension 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 / { ifExtension NegativeLiteralsBit } { tok_num negative 1 1 decimal }
@negative 0[bB] @numspc @binary / { ifExtension NegativeLiteralsBit `alexAndPred`
ifExtension BinaryLiteralsBit } { tok_num negative 3 3 binary }
@negative 0[oO] @numspc @octal / { ifExtension NegativeLiteralsBit } { tok_num negative 3 3 octal }
@negative 0[xX] @numspc @hexadecimal / { ifExtension NegativeLiteralsBit } { tok_num negative 3 3 hexadecimal }
-- Normal rational literals (:: Fractional a => a, from Rational)
@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 }
@floating_point { tok_frac 0 tok_float }
@negative @floating_point / { ifExtension NegativeLiteralsBit } { tok_frac 0 tok_float }
0[xX] @numspc @hex_floating_point / { ifExtension HexFloatLiteralsBit } { tok_frac 0 tok_hex_float }
@negative 0[xX] @numspc @hex_floating_point
/ { ifExtension HexFloatLiteralsBit `alexAndPred`
ifExtension NegativeLiteralsBit } { 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 \# / { 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 }
@decimal \# / { ifExtension MagicHashBit } { tok_primint positive 0 1 decimal }
0[bB] @numspc @binary \# / { ifExtension MagicHashBit `alexAndPred`
ifExtension BinaryLiteralsBit } { tok_primint positive 2 3 binary }
0[oO] @numspc @octal \# / { ifExtension MagicHashBit } { tok_primint positive 2 3 octal }
0[xX] @numspc @hexadecimal \# / { ifExtension MagicHashBit } { tok_primint positive 2 3 hexadecimal }
@negative @decimal \# / { ifExtension MagicHashBit } { tok_primint negative 1 2 decimal }
@negative 0[bB] @numspc @binary \# / { ifExtension MagicHashBit `alexAndPred`
ifExtension BinaryLiteralsBit } { tok_primint negative 3 4 binary }
@negative 0[oO] @numspc @octal \# / { ifExtension MagicHashBit } { tok_primint negative 3 4 octal }
@negative 0[xX] @numspc @hexadecimal \#
/ { ifExtension MagicHashBit } { tok_primint negative 3 4 hexadecimal }
@decimal \# \# / { ifExtension MagicHashBit } { tok_primword 0 2 decimal }
0[bB] @numspc @binary \# \# / { ifExtension MagicHashBit `alexAndPred`
ifExtension BinaryLiteralsBit } { tok_primword 2 4 binary }
0[oO] @numspc @octal \# \# / { ifExtension MagicHashBit } { tok_primword 2 4 octal }
0[xX] @numspc @hexadecimal \# \# / { ifExtension MagicHashBit } { tok_primword 2 4 hexadecimal }
-- Unboxed floats and doubles (:: Float#, :: Double#)
-- prim_{float,double} work with signed literals
@signed @floating_point \# / { ifExtension magicHashEnabled } { tok_frac 1 tok_primfloat }
@signed @floating_point \# \# / { ifExtension magicHashEnabled } { tok_frac 2 tok_primdouble }
@signed @floating_point \# / { ifExtension MagicHashBit } { tok_frac 1 tok_primfloat }
@signed @floating_point \# \# / { ifExtension MagicHashBit } { tok_frac 2 tok_primdouble }
}
-- Strings and chars are lexed by hand-written code. The reason is
......@@ -645,8 +644,8 @@ data Token
| ITrules_prag SourceText
| ITwarning_prag SourceText
| ITdeprecated_prag SourceText
| ITline_prag SourceText -- not usually produced, see 'use_pos_prags'
| ITcolumn_prag SourceText -- not usually produced, see 'use_pos_prags'
| ITline_prag SourceText -- not usually produced, see 'UsePosPragsBit'
| ITcolumn_prag SourceText -- not usually produced, see 'UsePosPragsBit'
| ITscc_prag SourceText
| ITgenerated_prag SourceText
| ITcore_prag SourceText -- hdaume: core annotations
......@@ -752,29 +751,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
......@@ -826,7 +825,7 @@ reservedWordsFM = listToUFM $
( "family", ITfamily, 0 ),
( "role", ITrole, 0 ),
( "pattern", ITpattern, xbit PatternSynonymsBit),
( "static", ITstatic, 0 ),
( "static", ITstatic, xbit StaticPointersBit ),
( "stock", ITstock, 0 ),
( "anyclass", ITanyclass, 0 ),
( "via", ITvia, 0 ),
......@@ -874,50 +873,46 @@ Also, note that these are included in the `varid` production in the parser --
a key detail to make all this work.
-------------------------------------}
reservedSymsFM :: UniqFM (Token, ExtsBitmap -> Bool)
reservedSymsFM :: UniqFM (Token, IsUnicodeSyntax, ExtsBitmap)
reservedSymsFM = listToUFM $
map (\ (x,y,z) -> (mkFastString x,(y,z)))
[ ("..", ITdotdot, always)
map (\ (x,w,y,z) -> (mkFastString x,(w,y,z)))
[ ("..", ITdotdot, NormalSyntax, 0 )
-- (:) is a reserved op, meaning only list cons
,(":", 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)
,(":", 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)
-- For 'forall a . t'
,(".", 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)
,(".", 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)
-- ToDo: ideally, → and ∷ should be "specials", so that they cannot
-- form part of a large operator. This would let us have a better
......@@ -960,21 +955,21 @@ pop _span _buf _len = do _ <- popLexState
-- See Note [Nested comment line pragmas]
failLinePrag1 :: Action
failLinePrag1 span _buf _len = do
b <- extension inNestedComment
b <- getBit InNestedCommentBit
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 <- extension inNestedComment
b <- getBit InNestedCommentBit
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 <- extension relaxedLayout
= do relaxed <- getBit RelaxedLayoutBit
ctx <- getContext
(AI l _) <- getInput
let offset = srcLocCol l
......@@ -1020,8 +1015,8 @@ ifCurrentChar char _ (AI _ buf) _ _
-- the non-layout states.
isNormalComment :: AlexAccPred ExtsBitmap
isNormalComment bits _ _ (AI _ buf)
| haddockEnabled bits = notFollowedByDocOrPragma
| otherwise = nextCharIsNot buf (== '#')
| HaddockBit `xtest` bits = notFollowedByDocOrPragma
| otherwise = nextCharIsNot buf (== '#')
where
notFollowedByDocOrPragma
= afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#"))
......@@ -1035,11 +1030,14 @@ afterOptionalSpace buf p
atEOL :: AlexAccPred ExtsBitmap
atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n'
ifExtension :: (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap
ifExtension pred bits _ _ _ = pred bits
ifExtension :: ExtBits -> AlexAccPred ExtsBitmap
ifExtension extBits bits _ _ _ = extBits `xtest` bits
alexNotPred p userState in1 len in2
= not (p userState in1 len in2)
orExtensions :: (ExtsBitmap -> Bool) -> (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap
orExtensions pred1 pred2 bits _ _ _ = pred1 bits || pred2 bits
alexOrPred p1 p2 userState in1 len in2
= p1 userState in1 len in2 || p2 userState in1 len in2
multiline_doc_comment :: Action
multiline_doc_comment span buf _len = withLexedDocType (worker "")
......@@ -1082,7 +1080,7 @@ multiline_doc_comment span buf _len = withLexedDocType (worker "")
lineCommentToken :: Action
lineCommentToken span buf len = do
b <- extension rawTokenStreamEnabled
b <- getBit RawTokenStreamBit
if b then strtoken ITlineComment span buf len else lexToken
{-
......@@ -1096,7 +1094,7 @@ nested_comment cont span buf len = do
where
go commentAcc 0 input = do
setInput input
b <- extension rawTokenStreamEnabled
b <- getBit RawTokenStreamBit
if b
then docCommentEnd input commentAcc ITblockComment buf span
else cont
......@@ -1215,23 +1213,23 @@ rulePrag span buf len = do
let !src = lexemeToString buf len
return (L span (ITrules_prag (SourceText src)))
-- When 'use_pos_prags' is not set, it is expected that we emit a token instead
-- When 'UsePosPragsBit' 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
ps <- getPState
if use_pos_prags ps
usePosPrags <- getBit UsePosPragsBit
if usePosPrags
then begin line_prag2 span buf len
else let !src = lexemeToString buf len
in return (L span (ITline_prag (SourceText src)))
-- When 'use_pos_prags' is not set, it is expected that we emit a token instead
-- When 'UsePosPragsBit' 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
ps <- getPState
usePosPrags <- getBit UsePosPragsBit
let !src = lexemeToString buf len
if use_pos_prags ps
if usePosPrags
then begin column_prag span buf len
else let !src = lexemeToString buf len
in return (L span (ITcolumn_prag (SourceText src)))
......@@ -1314,24 +1312,19 @@ varid span buf len =
lastTk <- getLastTk
keyword <- case lastTk of
Just ITlam -> do
lambdaCase <- extension lambdaCaseEnabled
lambdaCase <- getBit LambdaCaseBit
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, exts) -> do
extsEnabled <- extension $ \i -> exts .&. i /= 0
if extsEnabled
Just (keyword, i) -> do
exts <- getExts
if exts .&. i /= 0
then do
maybe_layout keyword
return $ L span keyword
......@@ -1356,11 +1349,23 @@ consym = sym ITconsym
sym :: (FastString -> Token) -> Action
sym con span buf len =
case lookupUFM reservedSymsFM fs of
Just (keyword, exts) -> do
extsEnabled <- extension exts
let !tk | extsEnabled = keyword
| otherwise = con fs
return $ L span tk
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, 0) -> do
exts <- getExts
if xtest UnicodeSyntaxBit exts
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)
Nothing ->
return $ L span $! con fs
where
......@@ -1373,7 +1378,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 <- extension numericUnderscoresEnabled -- #14473
numericUnderscores <- getBit NumericUnderscoresBit -- #14473
let src = lexemeToString buf len
if (not numericUnderscores) && ('_' `elem` src)
then failMsgP "Use NumericUnderscores to allow underscores in integer literals"
......@@ -1413,7 +1418,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 <- extension numericUnderscoresEnabled -- #14473
numericUnderscores <- getBit NumericUnderscoresBit -- #14473
let src = lexemeToString buf (len-drop)
if (not numericUnderscores) && ('_' `elem` src)
then failMsgP "Use NumericUnderscores to allow underscores in floating literals"
......@@ -1445,7 +1450,7 @@ readHexFractionalLit str =
do_bol :: Action
do_bol span _str _len = do
-- See Note [Nested comment line pragmas]
b <- extension inNestedComment
b <- getBit InNestedCommentBit
if b then return (L span ITcomment_line_prag) else do
(pos, gen_semic) <- getOffside
case pos of
......@@ -1472,7 +1477,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 <- extension alternativeLayoutRule
alr <- getBit AlternativeLayoutRuleBit
unless alr $ f t
where f ITdo = pushLexState layout_do
f ITmdo = pushLexState layout_do
......@@ -1498,7 +1503,7 @@ new_layout_context strict gen_semic tok span _buf len = do
(AI l _) <- getInput
let offset = srcLocCol l - len
ctx <- getContext
nondecreasing <- extension nondecreasingIndentation
nondecreasing <- getBit NondecreasingIndentationBit
let strict' = strict || not nondecreasing
case ctx of
Layout prev_off _ : _ |
......@@ -1614,7 +1619,7 @@ lex_string s = do
Just ('"',i) -> do
setInput i
magicHash <- extension magicHashEnabled
magicHash <- getBit MagicHashBit
if magicHash
then do
i <- getInput
......@@ -1701,7 +1706,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 <- extension magicHashEnabled
= do magicHash <- getBit MagicHashBit
i@(AI end bufEnd) <- getInput
let src = lexemeToString buf (cur bufEnd - cur buf)
if magicHash then do
......@@ -1935,14 +1940,10 @@ data ParseResult a
warnopt :: WarningFlag -> ParserFlags -> Bool
warnopt f options = f `EnumSet.member` pWarningFlags options
-- | Test whether a 'LangExt.Extension' is set
extopt :: LangExt.Extension -> ParserFlags -> Bool
extopt f options = f `EnumSet.member` pExtensionFlags options
-- | The subset of the 'DynFlags' used by the parser
-- | The subset of the 'DynFlags' used by the parser.
-- See 'mkParserFlags' or 'mkParserFlags'' for ways to construct this.
data ParserFlags = ParserFlags {
pWarningFlags :: EnumSet WarningFlag
, pExtensionFlags :: EnumSet LangExt.Extension
, pThisPackage :: UnitId -- ^ key of package currently being compiled
, pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions
}
......@@ -1981,10 +1982,6 @@ 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.
......@@ -2058,9 +2055,6 @@ 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)
......@@ -2245,10 +2239,6 @@ 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 = P $ \s@PState {options = o} ->
POk s (extopt LangExt.AlternativeLayoutRuleTransitional o)
getJustClosedExplicitLetBlock :: P Bool
getJustClosedExplicitLetBlock
= P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b
......@@ -2283,18 +2273,26 @@ 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, flags indicating language extensions (eg,
-- -fglasgow-exts or -XParallelArrays) are represented by a bitmap
-- stored in an unboxed Word64
-- | For reasons of efficiency, boolean parsing flags (eg, language extensions