'DynFlag'-free version of 'mkParserFlags'

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.

Reviewers: bgamari, alanz, sjakobi

Reviewed By: bgamari, sjakobi

Subscribers: mpickering, sjakobi, rwbarton, carter

GHC Trac Issues: #11301

Differential Revision: https://phabricator.haskell.org/D5269

3 files changed, 83 insertions, 55 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 9597f10b0a..4572e6d9af 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, ParserFlags(..), getSrcLoc,
-   getPState, extopt, withThisPackage,
+   P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags,
+   getSrcLoc, getPState, withThisPackage,
    failLocMsgP, failSpanMsgP, srcParseFail,
    getMessages,
    popContext, pushModuleContext, setLastToken, setSrcLoc,
@@ -61,8 +61,9 @@ module Lexer (
    inRulePrag,
    explicitNamespacesEnabled,
    patternSynonymsEnabled,
-   sccProfilingOn, hpcEnabled,
-   starIsTypeEnabled,
+   starIsTypeEnabled, monadComprehensionsEnabled, doAndIfThenElseEnabled,
+   nPlusKPatternsEnabled, blockArgumentsEnabled, gadtSyntaxEnabled,
+   multiWayIfEnabled, thQuotesEnabled,
    addWarning,
    lexTokenStream,
    addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
@@ -1935,14 +1936,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
   }
@@ -2246,8 +2243,7 @@ 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)
+getALRTransitional = extension alternativeLayoutTransitionalRule
 
 getJustClosedExplicitLetBlock :: P Bool
 getJustClosedExplicitLetBlock
@@ -2294,6 +2290,7 @@ 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
@@ -2319,9 +2316,8 @@ 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
@@ -2335,9 +2331,13 @@ data ExtBits
   | StaticPointersBit
   | NumericUnderscoresBit
   | StarIsTypeBit
+  | BlockArgumentsBit
+  | NPlusKPatternsBit
+  | DoAndIfThenElseBit
+  | MultiWayIfBit
+  | GadtSyntaxBit
   deriving Enum
 
-
 always :: ExtsBitmap -> Bool
 always           _     = True
 arrowsEnabled :: ExtsBitmap -> Bool
@@ -2366,6 +2366,8 @@ 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
@@ -2376,14 +2378,12 @@ rawTokenStreamEnabled :: ExtsBitmap -> Bool
 rawTokenStreamEnabled = xtest RawTokenStreamBit
 alternativeLayoutRule :: ExtsBitmap -> Bool
 alternativeLayoutRule = xtest AlternativeLayoutRuleBit
-hpcEnabled :: ExtsBitmap -> Bool
-hpcEnabled = xtest HpcBit
+alternativeLayoutTransitionalRule :: ExtsBitmap -> Bool
+alternativeLayoutTransitionalRule = xtest ALRTransitionalBit
 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,6 +2407,18 @@ 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
 --
@@ -2415,19 +2427,25 @@ pragState dynflags buf loc = (mkPState dynflags buf loc) {
                                  lex_state = [bol, option_prags, 0]
                              }
 
--- | Extracts the flag information needed for parsing
-mkParserFlags :: DynFlags -> ParserFlags
-mkParserFlags flags =
+{-# 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 =
     ParserFlags {
-      pWarningFlags = DynFlags.warningFlags flags
-    , pExtensionFlags = DynFlags.extensionFlags flags
-    , pThisPackage = DynFlags.thisPackage flags
-    , pExtsBitmap = bitmap
+      pWarningFlags = warningFlags
+    , pThisPackage = thisPackage
+    , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits
     }
   where
-    bitmap = safeHaskellBit .|. langExtBits .|. optBits
-    safeHaskellBit =
-          SafeHaskellBit `setBitIf` safeImportsOn flags
+    safeHaskellBit = SafeHaskellBit `setBitIf` safeImports
     langExtBits =
           FfiBit                      `xoptBit` LangExt.ForeignFunctionInterface
       .|. InterruptibleFfiBit         `xoptBit` LangExt.InterruptibleFFI
@@ -2449,6 +2467,7 @@ mkParserFlags flags =
       .|. 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
@@ -2462,19 +2481,32 @@ mkParserFlags flags =
       .|. 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        `goptBit` Opt_Haddock
-      .|. RawTokenStreamBit `goptBit` Opt_KeepRawTokenStream
-      .|. HpcBit            `goptBit` Opt_Hpc
-      .|. SccProfilingOnBit `goptBit` Opt_SccProfilingOn
+          HaddockBit        `setBitIf` isHaddock
+      .|. RawTokenStreamBit `setBitIf` rawTokStream
 
-    xoptBit bit ext = bit `setBitIf` xopt ext flags
-    goptBit bit opt = bit `setBitIf` gopt opt flags
+    xoptBit bit ext = bit `setBitIf` EnumSet.member ext extensionFlags
 
     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)
@@ -2611,8 +2643,8 @@ srcParseErr options buf len
         pattern = decodePrevNChars 8 buf
         last100 = decodePrevNChars 100 buf
         mdoInLast100 = "mdo" `isInfixOf` last100
-        th_enabled = extopt LangExt.TemplateHaskell options
-        ps_enabled = extopt LangExt.PatternSynonyms 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
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index f5082174ab..4c2e3e7660 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -84,8 +84,6 @@ 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
@@ -3746,14 +3744,14 @@ fileSrcSpan = do
 -- Hint about the MultiWayIf extension
 hintMultiWayIf :: SrcSpan -> P ()
 hintMultiWayIf span = do
-  mwiEnabled <- liftM ((LangExt.MultiWayIf `extopt`) . options) getPState
+  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 <- liftM ((LangExt.MultiWayIf `extopt`) . options) getPState
+  mwiEnabled <- extension multiWayIfEnabled
   if mwiEnabled
     then parseErrorSDoc span $ text $ "parse error in if statement"
     else parseErrorSDoc span $ text $ "parse error in if statement: "++msg
@@ -3805,8 +3803,8 @@ warnSpaceAfterBang span = do
 -- variable or constructor. See Trac #13450.
 reportEmptyDoubleQuotes :: SrcSpan -> P (GenLocated SrcSpan (HsExpr GhcPs))
 reportEmptyDoubleQuotes span = do
-    thEnabled <- liftM ((LangExt.TemplateHaskellQuotes `extopt`) . options) getPState
-    if thEnabled
+    thQuotes <- extension thQuotesEnabled
+    if thQuotes
       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 0da9747575..94b1dfafb2 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -108,7 +108,6 @@ import Util
 import ApiAnnotation
 import HsExtension      ( noExt )
 import Data.List
-import qualified GHC.LanguageExtensions as LangExt
 import DynFlags ( WarningFlag(..) )
 
 import Control.Monad
@@ -893,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 opts <- fmap options getPState
-         if LangExt.GADTSyntax `extopt` opts         -- GADTs implies GADTSyntax
+    = do gadtSyntax <- extension gadtSyntaxEnabled   -- GADTs implies GADTSyntax
+         if gadtSyntax
             then return gadts
             else parseErrorSDoc span $ vcat
               [ text "Illegal keyword 'where' in data declaration"
@@ -958,8 +957,8 @@ checkBlockArguments expr = case unLoc expr of
     _ -> return ()
   where
     check element = do
-      pState <- getPState
-      unless (extopt LangExt.BlockArguments (options pState)) $
+      blockArguments <- extension blockArgumentsEnabled
+      unless blockArguments $
         parseErrorSDoc (getLoc expr) $
           text "Unexpected " <> text element <> text " in function application:"
            $$ nest 4 (ppr expr)
@@ -1044,8 +1043,7 @@ checkPat msg loc e _
 
 checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (Pat GhcPs)
 checkAPat msg loc e0 = do
- pState <- getPState
- let opts = options pState
+ nPlusKPatterns <- extension nPlusKPatternsEnabled
  case e0 of
    EWildPat _ -> return (WildPat noExt)
    HsVar _ x  -> return (VarPat noExt x)
@@ -1079,7 +1077,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 {}})))
-                      | extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR)
+                      | nPlusKPatterns && (plus == plus_RDR)
                       -> return (mkNPlusKPat (L nloc n) (L lloc lit))
 
    OpApp _ l (L cl (HsVar _ (L _ c))) r
@@ -1242,8 +1240,8 @@ checkDoAndIfThenElse :: LHsExpr GhcPs
                      -> P ()
 checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
  | semiThen || semiElse
-    = do pState <- getPState
-         unless (extopt LangExt.DoAndIfThenElse (options pState)) $ do
+    = do doAndIfThenElse <- extension doAndIfThenElseEnabled
+         unless doAndIfThenElse $ do
              parseErrorSDoc (combineLocs guardExpr elseExpr)
                             (text "Unexpected semi-colons in conditional:"
                           $$ nest 4 expr
@@ -1750,8 +1748,8 @@ mergeDataCon all_xs =
 
 checkMonadComp :: P (HsStmtContext Name)
 checkMonadComp = do
-    pState <- getPState
-    return $ if extopt LangExt.MonadComprehensions (options pState)
+    monadComprehensions <- extension monadComprehensionsEnabled
+    return $ if monadComprehensions
                 then MonadComp
                 else ListComp