Revert "'DynFlag'-free version of 'mkParserFlags'"

This reverts commit 5aa29231ab7603537284eff5e4caff3a73dba6d2.

3 files changed, 55 insertions, 83 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 4572e6d9af..9597f10b0a 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -48,8 +48,8 @@
 
 module Lexer (
    Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..),
-   P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags,
-   getSrcLoc, getPState, withThisPackage,
+   P(..), ParseResult(..), mkParserFlags, ParserFlags(..), getSrcLoc,
+   getPState, extopt, withThisPackage,
    failLocMsgP, failSpanMsgP, srcParseFail,
    getMessages,
    popContext, pushModuleContext, setLastToken, setSrcLoc,
@@ -61,9 +61,8 @@ module Lexer (
    inRulePrag,
    explicitNamespacesEnabled,
    patternSynonymsEnabled,
-   starIsTypeEnabled, monadComprehensionsEnabled, doAndIfThenElseEnabled,
-   nPlusKPatternsEnabled, blockArgumentsEnabled, gadtSyntaxEnabled,
-   multiWayIfEnabled, thQuotesEnabled,
+   sccProfilingOn, hpcEnabled,
+   starIsTypeEnabled,
    addWarning,
    lexTokenStream,
    addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
@@ -1936,10 +1935,14 @@ data ParseResult a
 warnopt :: WarningFlag -> ParserFlags -> Bool
 warnopt f options = f `EnumSet.member` pWarningFlags options
 
--- | The subset of the 'DynFlags' used by the parser.
--- See 'mkParserFlags' or 'mkParserFlags'' for ways to construct this.
+-- | 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
 data ParserFlags = ParserFlags {
     pWarningFlags   :: EnumSet WarningFlag
+  , pExtensionFlags :: EnumSet LangExt.Extension
   , pThisPackage    :: UnitId      -- ^ key of package currently being compiled
   , pExtsBitmap     :: !ExtsBitmap -- ^ bitmap of permitted extensions
   }
@@ -2243,7 +2246,8 @@ setALRContext :: [ALRContext] -> P ()
 setALRContext cs = P $ \s -> POk (s {alr_context = cs}) ()
 
 getALRTransitional :: P Bool
-getALRTransitional = extension alternativeLayoutTransitionalRule
+getALRTransitional = P $ \s@PState {options = o} ->
+  POk s (extopt LangExt.AlternativeLayoutRuleTransitional o)
 
 getJustClosedExplicitLetBlock :: P Bool
 getJustClosedExplicitLetBlock
@@ -2290,7 +2294,6 @@ xbit = bit . fromEnum
 xtest :: ExtBits -> ExtsBitmap -> Bool
 xtest ext xmap = testBit xmap (fromEnum ext)
 
--- | Subset of the language extensions that impact lexing and parsing.
 data ExtBits
   = FfiBit
   | InterruptibleFfiBit
@@ -2316,8 +2319,9 @@ data ExtBits
   | InRulePragBit
   | InNestedCommentBit -- See Note [Nested comment line pragmas]
   | RawTokenStreamBit -- producing a token stream with all comments included
+  | SccProfilingOnBit
+  | HpcBit
   | AlternativeLayoutRuleBit
-  | ALRTransitionalBit
   | RelaxedLayoutBit
   | NondecreasingIndentationBit
   | SafeHaskellBit
@@ -2331,13 +2335,9 @@ data ExtBits
   | StaticPointersBit
   | NumericUnderscoresBit
   | StarIsTypeBit
-  | BlockArgumentsBit
-  | NPlusKPatternsBit
-  | DoAndIfThenElseBit
-  | MultiWayIfBit
-  | GadtSyntaxBit
   deriving Enum
 
+
 always :: ExtsBitmap -> Bool
 always           _     = True
 arrowsEnabled :: ExtsBitmap -> Bool
@@ -2366,8 +2366,6 @@ 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
@@ -2378,12 +2376,14 @@ rawTokenStreamEnabled :: ExtsBitmap -> Bool
 rawTokenStreamEnabled = xtest RawTokenStreamBit
 alternativeLayoutRule :: ExtsBitmap -> Bool
 alternativeLayoutRule = xtest AlternativeLayoutRuleBit
-alternativeLayoutTransitionalRule :: ExtsBitmap -> Bool
-alternativeLayoutTransitionalRule = xtest ALRTransitionalBit
+hpcEnabled :: ExtsBitmap -> Bool
+hpcEnabled = xtest HpcBit
 relaxedLayout :: ExtsBitmap -> Bool
 relaxedLayout = xtest RelaxedLayoutBit
 nondecreasingIndentation :: ExtsBitmap -> Bool
 nondecreasingIndentation = xtest NondecreasingIndentationBit
+sccProfilingOn :: ExtsBitmap -> Bool
+sccProfilingOn = xtest SccProfilingOnBit
 traditionalRecordSyntaxEnabled :: ExtsBitmap -> Bool
 traditionalRecordSyntaxEnabled = xtest TraditionalRecordSyntaxBit
 
@@ -2407,18 +2407,6 @@ 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
-
-
 
 -- PState for parsing options pragmas
 --
@@ -2427,25 +2415,19 @@ pragState dynflags buf loc = (mkPState dynflags buf loc) {
                                  lex_state = [bol, option_prags, 0]
                              }
 
-{-# INLINE mkParserFlags' #-}
-mkParserFlags'
-  :: EnumSet WarningFlag        -- ^ warnings flags enabled
-  -> EnumSet LangExt.Extension  -- ^ permitted language extensions enabled
-  -> UnitId                     -- ^ key of package currently being compiled
-  -> Bool                       -- ^ are safe imports on?
-  -> Bool                       -- ^ keeping Haddock comment tokens
-  -> Bool                       -- ^ keep regular comment tokens
-  -> ParserFlags
--- ^ Given exactly the information needed, set up the 'ParserFlags'
-mkParserFlags' warningFlags extensionFlags thisPackage
-  safeImports isHaddock rawTokStream =
+-- | Extracts the flag information needed for parsing
+mkParserFlags :: DynFlags -> ParserFlags
+mkParserFlags flags =
     ParserFlags {
-      pWarningFlags = warningFlags
-    , pThisPackage = thisPackage
-    , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits
+      pWarningFlags = DynFlags.warningFlags flags
+    , pExtensionFlags = DynFlags.extensionFlags flags
+    , pThisPackage = DynFlags.thisPackage flags
+    , pExtsBitmap = bitmap
     }
   where
-    safeHaskellBit = SafeHaskellBit `setBitIf` safeImports
+    bitmap = safeHaskellBit .|. langExtBits .|. optBits
+    safeHaskellBit =
+          SafeHaskellBit `setBitIf` safeImportsOn flags
     langExtBits =
           FfiBit                      `xoptBit` LangExt.ForeignFunctionInterface
       .|. InterruptibleFfiBit         `xoptBit` LangExt.InterruptibleFFI
@@ -2467,7 +2449,6 @@ mkParserFlags' warningFlags extensionFlags thisPackage
       .|. TransformComprehensionsBit  `xoptBit` LangExt.TransformListComp
       .|. TransformComprehensionsBit  `xoptBit` LangExt.MonadComprehensions
       .|. AlternativeLayoutRuleBit    `xoptBit` LangExt.AlternativeLayoutRule
-      .|. ALRTransitionalBit          `xoptBit` LangExt.AlternativeLayoutRuleTransitional
       .|. RelaxedLayoutBit            `xoptBit` LangExt.RelaxedLayout
       .|. NondecreasingIndentationBit `xoptBit` LangExt.NondecreasingIndentation
       .|. TraditionalRecordSyntaxBit  `xoptBit` LangExt.TraditionalRecordSyntax
@@ -2481,32 +2462,19 @@ mkParserFlags' warningFlags extensionFlags thisPackage
       .|. StaticPointersBit           `xoptBit` LangExt.StaticPointers
       .|. NumericUnderscoresBit       `xoptBit` LangExt.NumericUnderscores
       .|. StarIsTypeBit               `xoptBit` LangExt.StarIsType
-      .|. BlockArgumentsBit           `xoptBit` LangExt.BlockArguments
-      .|. NPlusKPatternsBit           `xoptBit` LangExt.NPlusKPatterns
-      .|. DoAndIfThenElseBit          `xoptBit` LangExt.DoAndIfThenElse
-      .|. MultiWayIfBit               `xoptBit` LangExt.MultiWayIf
-      .|. GadtSyntaxBit               `xoptBit` LangExt.GADTSyntax
     optBits =
-          HaddockBit        `setBitIf` isHaddock
-      .|. RawTokenStreamBit `setBitIf` rawTokStream
+          HaddockBit        `goptBit` Opt_Haddock
+      .|. RawTokenStreamBit `goptBit` Opt_KeepRawTokenStream
+      .|. HpcBit            `goptBit` Opt_Hpc
+      .|. SccProfilingOnBit `goptBit` Opt_SccProfilingOn
 
-    xoptBit bit ext = bit `setBitIf` EnumSet.member ext extensionFlags
+    xoptBit bit ext = bit `setBitIf` xopt ext flags
+    goptBit bit opt = bit `setBitIf` gopt opt flags
 
     setBitIf :: ExtBits -> Bool -> ExtsBitmap
     b `setBitIf` cond | cond      = xbit b
                       | otherwise = 0
 
--- | Extracts the flag information needed for parsing
-mkParserFlags :: DynFlags -> ParserFlags
-mkParserFlags =
-  mkParserFlags'
-    <$> DynFlags.warningFlags
-    <*> DynFlags.extensionFlags
-    <*> DynFlags.thisPackage
-    <*> safeImportsOn
-    <*> gopt Opt_Haddock
-    <*> gopt Opt_KeepRawTokenStream
-
 -- | Creates a parse state from a 'DynFlags' value
 mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
 mkPState flags = mkPStatePure (mkParserFlags flags)
@@ -2643,8 +2611,8 @@ srcParseErr options buf len
         pattern = decodePrevNChars 8 buf
         last100 = decodePrevNChars 100 buf
         mdoInLast100 = "mdo" `isInfixOf` last100
-        th_enabled = thEnabled (pExtsBitmap options)
-        ps_enabled = patternSynonymsEnabled (pExtsBitmap options)
+        th_enabled = extopt LangExt.TemplateHaskell options
+        ps_enabled = extopt LangExt.PatternSynonyms 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
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 4c2e3e7660..f5082174ab 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -84,6 +84,8 @@ import TysWiredIn       ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilD
 -- compiler/utils
 import Util             ( looksLikePackageName, fstOf3, sndOf3, thdOf3 )
 import GhcPrelude
+
+import qualified GHC.LanguageExtensions as LangExt
 }
 
 %expect 236 -- shift/reduce conflicts
@@ -3744,14 +3746,14 @@ fileSrcSpan = do
 -- Hint about the MultiWayIf extension
 hintMultiWayIf :: SrcSpan -> P ()
 hintMultiWayIf span = do
-  mwiEnabled <- extension multiWayIfEnabled
+  mwiEnabled <- liftM ((LangExt.MultiWayIf `extopt`) . options) getPState
   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 <- extension multiWayIfEnabled
+  mwiEnabled <- liftM ((LangExt.MultiWayIf `extopt`) . options) getPState
   if mwiEnabled
     then parseErrorSDoc span $ text $ "parse error in if statement"
     else parseErrorSDoc span $ text $ "parse error in if statement: "++msg
@@ -3803,8 +3805,8 @@ warnSpaceAfterBang span = do
 -- variable or constructor. See Trac #13450.
 reportEmptyDoubleQuotes :: SrcSpan -> P (GenLocated SrcSpan (HsExpr GhcPs))
 reportEmptyDoubleQuotes span = do
-    thQuotes <- extension thQuotesEnabled
-    if thQuotes
+    thEnabled <- liftM ((LangExt.TemplateHaskellQuotes `extopt`) . options) getPState
+    if thEnabled
       then parseErrorSDoc span $ vcat
         [ text "Parser error on `''`"
         , text "Character literals may not be empty"
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index b95b117419..1ac21c6c2d 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -107,6 +107,7 @@ import Maybes
 import Util
 import ApiAnnotation
 import Data.List
+import qualified GHC.LanguageExtensions as LangExt
 import DynFlags ( WarningFlag(..) )
 
 import Control.Monad
@@ -891,8 +892,8 @@ checkRecordSyntax lr@(L loc r)
 checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
                 -> P (Located ([AddAnn], [LConDecl GhcPs]))
 checkEmptyGADTs gadts@(L span (_, []))               -- Empty GADT declaration.
-    = do gadtSyntax <- extension gadtSyntaxEnabled   -- GADTs implies GADTSyntax
-         if gadtSyntax
+    = do opts <- fmap options getPState
+         if LangExt.GADTSyntax `extopt` opts         -- GADTs implies GADTSyntax
             then return gadts
             else parseErrorSDoc span $ vcat
               [ text "Illegal keyword 'where' in data declaration"
@@ -956,8 +957,8 @@ checkBlockArguments expr = case unLoc expr of
     _ -> return ()
   where
     check element = do
-      blockArguments <- extension blockArgumentsEnabled
-      unless blockArguments $
+      pState <- getPState
+      unless (extopt LangExt.BlockArguments (options pState)) $
         parseErrorSDoc (getLoc expr) $
           text "Unexpected " <> text element <> text " in function application:"
            $$ nest 4 (ppr expr)
@@ -1042,7 +1043,8 @@ checkPat msg loc e _
 
 checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (Pat GhcPs)
 checkAPat msg loc e0 = do
- nPlusKPatterns <- extension nPlusKPatternsEnabled
+ pState <- getPState
+ let opts = options pState
  case e0 of
    EWildPat _ -> return (WildPat noExt)
    HsVar _ x  -> return (VarPat noExt x)
@@ -1076,7 +1078,7 @@ checkAPat msg loc e0 = do
    -- n+k patterns
    OpApp _ (L nloc (HsVar _ (L _ n))) (L _ (HsVar _ (L _ plus)))
            (L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}})))
-                      | nPlusKPatterns && (plus == plus_RDR)
+                      | extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR)
                       -> return (mkNPlusKPat (L nloc n) (L lloc lit))
 
    OpApp _ l (L cl (HsVar _ (L _ c))) r
@@ -1239,8 +1241,8 @@ checkDoAndIfThenElse :: LHsExpr GhcPs
                      -> P ()
 checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
  | semiThen || semiElse
-    = do doAndIfThenElse <- extension doAndIfThenElseEnabled
-         unless doAndIfThenElse $ do
+    = do pState <- getPState
+         unless (extopt LangExt.DoAndIfThenElse (options pState)) $ do
              parseErrorSDoc (combineLocs guardExpr elseExpr)
                             (text "Unexpected semi-colons in conditional:"
                           $$ nest 4 expr
@@ -1747,8 +1749,8 @@ mergeDataCon all_xs =
 
 checkMonadComp :: P (HsStmtContext Name)
 checkMonadComp = do
-    monadComprehensions <- extension monadComprehensionsEnabled
-    return $ if monadComprehensions
+    pState <- getPState
+    return $ if extopt LangExt.MonadComprehensions (options pState)
                 then MonadComp
                 else ListComp