diff options
author | Ben Gamari <ben@smart-cactus.org> | 2018-11-23 14:09:28 -0500 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2018-11-23 14:09:28 -0500 |
commit | f61f71c48e2f1aec8999b632bc5722391a42d036 (patch) | |
tree | 0ce3cfbe0ff0c3d68ccf8d4094378630b26395ae /compiler/parser | |
parent | c2be6d5e9a7137aa480874fe0929f12264860c6e (diff) | |
download | haskell-f61f71c48e2f1aec8999b632bc5722391a42d036.tar.gz |
Revert "Simplify 'ExtBits' in the lexer"
This reverts commit d2fbc33c4ff3074126ab71654af8bbf8a46e4e11.
Diffstat (limited to 'compiler/parser')
-rw-r--r-- | compiler/parser/Lexer.x | 498 | ||||
-rw-r--r-- | compiler/parser/Parser.y | 14 | ||||
-rw-r--r-- | compiler/parser/RdrHsSyn.hs | 32 |
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) |