Make the parser module less dependent on DynFlags

Bump haddock submodule

compiler/GHC.hs

@@ -303,6 +303,7 @@ import GHCi.RemoteTypes
 
 import GHC.Core.Ppr.TyThing  ( pprFamInst )
 import GHC.Driver.Backend
+import GHC.Driver.Config
 import GHC.Driver.Main
 import GHC.Driver.Make
 import GHC.Driver.Hooks
@@ -1426,9 +1427,9 @@ getModuleSourceAndFlags mod = do
 -- Throws a 'GHC.Driver.Types.SourceError' on parse error.
 getTokenStream :: GhcMonad m => Module -> m [Located Token]
 getTokenStream mod = do
-  (sourceFile, source, flags) <- getModuleSourceAndFlags mod
+  (sourceFile, source, dflags) <- getModuleSourceAndFlags mod
   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
-  case lexTokenStream source startLoc flags of
+  case lexTokenStream (initParserOpts dflags) source startLoc of
     POk _ ts  -> return ts
     PFailed pst ->
         do dflags <- getDynFlags
@@ -1439,9 +1440,9 @@ getTokenStream mod = do
 -- 'showRichTokenStream'.
 getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
 getRichTokenStream mod = do
-  (sourceFile, source, flags) <- getModuleSourceAndFlags mod
+  (sourceFile, source, dflags) <- getModuleSourceAndFlags mod
   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
-  case lexTokenStream source startLoc flags of
+  case lexTokenStream (initParserOpts dflags) source startLoc of
     POk _ ts -> return $ addSourceToTokens startLoc source ts
     PFailed pst ->
         do dflags <- getDynFlags
@@ -1616,7 +1617,7 @@ parser str dflags filename =
        loc  = mkRealSrcLoc (mkFastString filename) 1 1
        buf  = stringToStringBuffer str
    in
-   case unP Parser.parseModule (mkPState dflags buf loc) of
+   case unP Parser.parseModule (initParserState (initParserOpts dflags) buf loc) of
 
      PFailed pst ->
          let (warns,errs) = getMessages pst dflags in

compiler/GHC/Cmm/Parser.y

@@ -249,6 +249,7 @@ import GHC.Types.Unique.FM
 import GHC.Types.SrcLoc
 import GHC.Driver.Session
 import GHC.Driver.Ppr
+import GHC.Driver.Config
 import GHC.Utils.Error
 import GHC.Data.StringBuffer
 import GHC.Data.FastString
@@ -1432,7 +1433,8 @@ parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (te
   buf <- hGetStringBuffer filename
   let
         init_loc = mkRealSrcLoc (mkFastString filename) 1 1
-        init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
+        opts       = initParserOpts dflags
+        init_state = (initParserState opts buf init_loc) { lex_state = [0] }
                 -- reset the lex_state: the Lexer monad leaves some stuff
                 -- in there we don't want.
   case unPD cmmParse dflags init_state of

compiler/GHC/Driver/Backpack.hs

@@ -27,6 +27,7 @@ import GHC.Parser.Annotation
 import GHC hiding (Failed, Succeeded)
 import GHC.Parser
 import GHC.Parser.Lexer
+import GHC.Driver.Config
 import GHC.Driver.Monad
 import GHC.Driver.Session
 import GHC.Driver.Ppr
@@ -83,7 +84,7 @@ doBackpack [src_filename] = do
 
     buf <- liftIO $ hGetStringBuffer src_filename
     let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great
-    case unP parseBackpack (mkPState dflags buf loc) of
+    case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of
         PFailed pst -> throwErrors (getErrorMessages pst dflags)
         POk _ pkgname_bkp -> do
             -- OK, so we have an LHsUnit PackageName, but we want an

compiler/GHC/Driver/Config.hs

@@ -2,6 +2,7 @@
 module GHC.Driver.Config
    ( initOptCoercionOpts
    , initSimpleOpts
+   , initParserOpts
    )
 where
 
@@ -10,6 +11,7 @@ import GHC.Prelude
 import GHC.Driver.Session
 import GHC.Core.SimpleOpt
 import GHC.Core.Coercion.Opt
+import GHC.Parser.Lexer
 
 -- | Initialise coercion optimiser configuration from DynFlags
 initOptCoercionOpts :: DynFlags -> OptCoercionOpts
@@ -23,3 +25,15 @@ initSimpleOpts dflags = SimpleOpts
    { so_uf_opts = unfoldingOpts dflags
    , so_co_opts = initOptCoercionOpts dflags
    }
+
+-- | Extracts the flag information needed for parsing
+initParserOpts :: DynFlags -> ParserOpts
+initParserOpts =
+  mkParserOpts
+    <$> warningFlags
+    <*> extensionFlags
+    <*> homeUnitId_
+    <*> safeImportsOn
+    <*> gopt Opt_Haddock
+    <*> gopt Opt_KeepRawTokenStream
+    <*> const True

compiler/GHC/Driver/Main.hs

@@ -138,6 +138,7 @@ import GHC.Cmm.Info.Build
 import GHC.Cmm.Pipeline
 import GHC.Cmm.Info
 import GHC.Driver.CodeOutput
+import GHC.Driver.Config
 import GHC.Core.InstEnv
 import GHC.Core.FamInstEnv
 import GHC.Utils.Fingerprint ( Fingerprint )
@@ -353,7 +354,7 @@ hscParse' mod_summary
                  = parseSignature
                  | otherwise = parseModule
 
-    case unP parseMod (mkPState dflags buf loc) of
+    case unP parseMod (initParserState (initParserOpts dflags) buf loc) of
         PFailed pst ->
             handleWarningsThrowErrors (getMessages pst dflags)
         POk pst rdr_module -> do
@@ -1875,7 +1876,7 @@ hscParseThingWithLocation source linenumber parser str
     let buf = stringToStringBuffer str
         loc = mkRealSrcLoc (fsLit source) linenumber 1
 
-    case unP parser (mkPState dflags buf loc) of
+    case unP parser (initParserState (initParserOpts dflags) buf loc) of
         PFailed pst -> do
             handleWarningsThrowErrors (getMessages pst dflags)
 

compiler/GHC/Parser.y

@@ -21,13 +21,13 @@
 -- and then parse that string:
 --
 -- @
---     runParser :: DynFlags -> String -> P a -> ParseResult a
---     runParser flags str parser = unP parser parseState
+--     runParser :: ParserOpts -> String -> P a -> ParseResult a
+--     runParser opts str parser = unP parser parseState
 --     where
 --       filename = "\<interactive\>"
 --       location = mkRealSrcLoc (mkFastString filename) 1 1
 --       buffer = stringToStringBuffer str
---       parseState = mkPState flags buffer location
+--       parseState = initParserState opts buffer location
 -- @
 module GHC.Parser
    ( parseModule, parseSignature, parseImport, parseStatement, parseBackpack

compiler/GHC/Parser/Header.hs

@@ -37,6 +37,7 @@ import GHC.Builtin.Names
 import GHC.Data.StringBuffer
 import GHC.Types.SrcLoc
 import GHC.Driver.Session
+import GHC.Driver.Config
 import GHC.Utils.Error
 import GHC.Utils.Misc
 import GHC.Utils.Outputable as Outputable
@@ -73,7 +74,7 @@ getImports :: DynFlags
               -- names from -XPackageImports), and the module name.
 getImports dflags buf filename source_filename = do
   let loc  = mkRealSrcLoc (mkFastString filename) 1 1
-  case unP parseHeader (mkPState dflags buf loc) of
+  case unP parseHeader (initParserState (initParserOpts dflags) buf loc) of
     PFailed pst ->
         -- assuming we're not logging warnings here as per below
       return $ Left $ getErrorMessages pst dflags
@@ -178,7 +179,8 @@ blockSize = 1024
 lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]
 lazyGetToks dflags filename handle = do
   buf <- hGetStringBufferBlock handle blockSize
-  unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize
+  let prag_state = initPragState (initParserOpts dflags) buf loc
+  unsafeInterleaveIO $ lazyLexBuf handle prag_state False blockSize
  where
   loc  = mkRealSrcLoc (mkFastString filename) 1 1
 
@@ -214,8 +216,9 @@ lazyGetToks dflags filename handle = do
 
 
 getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
-getToks dflags filename buf = lexAll (pragState dflags buf loc)
+getToks dflags filename buf = lexAll pstate
  where
+  pstate = initPragState (initParserOpts dflags) buf loc
   loc  = mkRealSrcLoc (mkFastString filename) 1 1
 
   lexAll state = case unP (lexer False return) state of

compiler/GHC/Parser/Lexer.x

@@ -49,8 +49,10 @@
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
 module GHC.Parser.Lexer (
-   Token(..), lexer, lexerDbg, pragState, mkPState, mkPStatePure, PState(..),
-   P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags(..),
+   Token(..), lexer, lexerDbg,
+   ParserOpts(..), mkParserOpts,
+   PState (..), initParserState, initPragState,
+   P(..), ParseResult(..),
    appendWarning,
    appendError,
    allocateComments,
@@ -62,7 +64,7 @@ module GHC.Parser.Lexer (
    activeContext, nextIsEOF,
    getLexState, popLexState, pushLexState,
    ExtBits(..),
-   xtest,
+   xtest, xunset, xset,
    lexTokenStream,
    AddAnn(..),mkParensApiAnn,
    addAnnsAt,
@@ -2207,12 +2209,13 @@ data ParseResult a
              --   a non-empty bag of errors.
 
 -- | Test whether a 'WarningFlag' is set
-warnopt :: WarningFlag -> ParserFlags -> Bool
+warnopt :: WarningFlag -> ParserOpts -> 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.
-data ParserFlags = ParserFlags {
+-- | Parser options.
+--
+-- See 'mkParserOpts' to construct this.
+data ParserOpts = ParserOpts {
     pWarningFlags   :: EnumSet WarningFlag
   , pHomeUnitId     :: UnitId      -- ^ id of the unit currently being compiled
                                    -- (only used in Cmm parser)
@@ -2230,7 +2233,7 @@ data HdkComment
 
 data PState = PState {
         buffer     :: StringBuffer,
-        options    :: ParserFlags,
+        options    :: ParserOpts,
         -- This needs to take DynFlags as an argument until
         -- we have a fix for #10143
         messages   :: DynFlags -> Messages,
@@ -2570,6 +2573,12 @@ xbit = bit . fromEnum
 xtest :: ExtBits -> ExtsBitmap -> Bool
 xtest ext xmap = testBit xmap (fromEnum ext)
 
+xset :: ExtBits -> ExtsBitmap -> ExtsBitmap
+xset ext xmap = setBit xmap (fromEnum ext)
+
+xunset :: ExtBits -> ExtsBitmap -> ExtsBitmap
+xunset ext xmap = clearBit 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.
 data ExtBits
@@ -2630,19 +2639,8 @@ data ExtBits
     -- tokens of their own.
   deriving Enum
 
-
-
-
-
--- PState for parsing options pragmas
---
-pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
-pragState dynflags buf loc = (mkPState dynflags buf loc) {
-                                 lex_state = [bol, option_prags, 0]
-                             }
-
-{-# INLINE mkParserFlags' #-}
-mkParserFlags'
+{-# INLINE mkParserOpts #-}
+mkParserOpts
   :: EnumSet WarningFlag        -- ^ warnings flags enabled
   -> EnumSet LangExt.Extension  -- ^ permitted language extensions enabled
   -> UnitId                     -- ^ id of the unit currently being compiled
@@ -2656,11 +2654,11 @@ mkParserFlags'
   -- 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 homeUnitId
+  -> ParserOpts
+-- ^ Given exactly the information needed, set up the 'ParserOpts'
+mkParserOpts warningFlags extensionFlags homeUnitId
   safeImports isHaddock rawTokStream usePosPrags =
-    ParserFlags {
+    ParserOpts {
       pWarningFlags = warningFlags
     , pHomeUnitId   = homeUnitId
     , pExtsBitmap   = safeHaskellBit .|. langExtBits .|. optBits
@@ -2722,25 +2720,15 @@ mkParserFlags' warningFlags extensionFlags homeUnitId
     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.homeUnitId_
-    <*> safeImportsOn
-    <*> gopt Opt_Haddock
-    <*> gopt Opt_KeepRawTokenStream
-    <*> const True
-
--- | Creates a parse state from a 'DynFlags' value
-mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
-mkPState flags = mkPStatePure (mkParserFlags flags)
-
--- | Creates a parse state from a 'ParserFlags' value
-mkPStatePure :: ParserFlags -> StringBuffer -> RealSrcLoc -> PState
-mkPStatePure options buf loc =
+-- | Set parser options for parsing OPTIONS pragmas
+initPragState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState
+initPragState options buf loc = (initParserState options buf loc)
+   { lex_state = [bol, option_prags, 0]
+   }
+
+-- | Creates a parse state from a 'ParserOpts' value
+initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState
+initParserState options buf loc =
   PState {
       buffer        = buf,
       options       = options,
@@ -2818,7 +2806,7 @@ appendError srcspan msg m =
     in (ws, es')
 
 appendWarning
-  :: ParserFlags
+  :: ParserOpts
   -> WarningFlag
   -> SrcSpan
   -> SDoc
@@ -2928,7 +2916,7 @@ getOffside = P $ \s@PState{last_loc=loc, context=stk} ->
 -- Construct a parse error
 
 srcParseErr
-  :: ParserFlags
+  :: ParserOpts
   -> StringBuffer       -- current buffer (placed just after the last token)
   -> Int                -- length of the previous token
   -> MsgDoc
@@ -3248,16 +3236,20 @@ reportLexError loc1 loc2 buf str
      then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
      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' }
-    where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
-          initState@PState{ options = opts } = mkPState dflags' buf loc
-          opts' = opts{ pExtsBitmap = complement (xbit UsePosPragsBit) .&. pExtsBitmap opts }
-          go = do
-            ltok <- lexer False return
-            case ltok of
-              L _ ITeof -> return []
-              _ -> liftM (ltok:) go
+lexTokenStream :: ParserOpts -> StringBuffer -> RealSrcLoc -> ParseResult [Located Token]
+lexTokenStream opts buf loc = unP go initState{ options = opts' }
+    where
+    new_exts  = xunset HaddockBit        -- disable Haddock
+                $ xunset UsePosPragsBit  -- parse LINE/COLUMN pragmas as tokens
+                $ xset RawTokenStreamBit -- include comments
+                $ pExtsBitmap opts
+    opts'     = opts { pExtsBitmap = new_exts }
+    initState = initParserState opts' buf loc
+    go = do
+      ltok <- lexer False return
+      case ltok of
+        L _ ITeof -> return []
+        _ -> liftM (ltok:) go
 
 linePrags = Map.singleton "line" linePrag
 

compiler/GHC/Parser/PostProcess.hs

@@ -2660,7 +2660,7 @@ failOpFewArgs (L loc op) =
 
 data PV_Context =
   PV_Context
-    { pv_options :: ParserFlags
+    { pv_options :: ParserOpts
     , pv_hint :: SDoc  -- See Note [Parser-Validator Hint]
     }
 

compiler/GHC/Runtime/Eval.hs

@@ -96,8 +96,8 @@ import GHC.Utils.Outputable
 import GHC.Data.FastString
 import GHC.Data.Bag
 import GHC.Utils.Misc
-import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, mkPStatePure)
-import GHC.Parser.Lexer (ParserFlags)
+import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, initParserState)
+import GHC.Parser.Lexer (ParserOpts)
 import qualified GHC.Parser       as Parser (parseStmt, parseModule, parseDeclaration, parseImport)
 
 import System.Directory
@@ -877,14 +877,14 @@ parseName str = withSession $ \hsc_env -> liftIO $
       ; hscTcRnLookupRdrName hsc_env lrdr_name }
 
 -- | Returns @True@ if passed string is a statement.
-isStmt :: ParserFlags -> String -> Bool
+isStmt :: ParserOpts -> String -> Bool
 isStmt pflags stmt =
   case parseThing Parser.parseStmt pflags stmt of
     Lexer.POk _ _ -> True
     Lexer.PFailed _ -> False
 
 -- | Returns @True@ if passed string has an import declaration.
-hasImport :: ParserFlags -> String -> Bool
+hasImport :: ParserOpts -> String -> Bool
 hasImport pflags stmt =
   case parseThing Parser.parseModule pflags stmt of
     Lexer.POk _ thing -> hasImports thing
@@ -893,14 +893,14 @@ hasImport pflags stmt =
     hasImports = not . null . hsmodImports . unLoc
 
 -- | Returns @True@ if passed string is an import declaration.
-isImport :: ParserFlags -> String -> Bool
+isImport :: ParserOpts -> String -> Bool
 isImport pflags stmt =
   case parseThing Parser.parseImport pflags stmt of
     Lexer.POk _ _ -> True
     Lexer.PFailed _ -> False
 
 -- | Returns @True@ if passed string is a declaration but __/not a splice/__.
-isDecl :: ParserFlags -> String -> Bool
+isDecl :: ParserOpts -> String -> Bool
 isDecl pflags stmt = do
   case parseThing Parser.parseDeclaration pflags stmt of
     Lexer.POk _ thing ->
@@ -909,12 +909,12 @@ isDecl pflags stmt = do
         _ -> True
     Lexer.PFailed _ -> False
 
-parseThing :: Lexer.P thing -> ParserFlags -> String -> Lexer.ParseResult thing
-parseThing parser pflags stmt = do
+parseThing :: Lexer.P thing -> ParserOpts -> String -> Lexer.ParseResult thing
+parseThing parser opts stmt = do
   let buf = stringToStringBuffer stmt
       loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
 
-  Lexer.unP parser (Lexer.mkPStatePure pflags buf loc)
+  Lexer.unP parser (Lexer.initParserState opts buf loc)
 
 getDocs :: GhcMonad m
         => Name

ghc/GHCi/UI.hs

@@ -50,6 +50,7 @@ import GHC.Driver.Ppr hiding (printForUser)
 import GHC.Utils.Error hiding (traceCmd)
 import GHC.Driver.Finder as Finder
 import GHC.Driver.Monad ( modifySession )
+import GHC.Driver.Config
 import qualified GHC
 import GHC ( LoadHowMuch(..), Target(..),  TargetId(..), InteractiveImport(..),
              TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
@@ -1133,7 +1134,7 @@ checkInputForLayout stmt getStmt = do
    st0 <- getGHCiState
    let buf'   =  stringToStringBuffer stmt
        loc    = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1
-       pstate = Lexer.mkPState dflags buf' loc
+       pstate = Lexer.initParserState (initParserOpts dflags) buf' loc
    case Lexer.unP goToEnd pstate of
      (Lexer.POk _ False) -> return $ Just stmt
      _other              -> do
@@ -1175,7 +1176,7 @@ enqueueCommands cmds = do
 -- The return value True indicates success, as in `runOneCommand`.
 runStmt :: GhciMonad m => String -> SingleStep -> m (Maybe GHC.ExecResult)
 runStmt input step = do
-  pflags <- Lexer.mkParserFlags <$> GHC.getInteractiveDynFlags
+  pflags <- initParserOpts <$> GHC.getInteractiveDynFlags
   -- In GHCi, we disable `-fdefer-type-errors`, as well as `-fdefer-type-holes`
   -- and `-fdefer-out-of-scope-variables` for **naked expressions**. The
   -- declarations and statements are not affected.

testsuite/tests/ghc-api/T11579.hs

 import System.Environment
 import GHC.Driver.Session
+import GHC.Driver.Config
 import GHC.Data.FastString
 import GHC
 import GHC.Data.StringBuffer
@@ -16,7 +17,8 @@ main = do
 
     hdk_comments <- runGhc (Just libdir) $ do
         dflags <- getSessionDynFlags
-        let pstate = mkPState (dflags `gopt_set` Opt_Haddock) stringBuffer loc
+        let opts   = initParserOpts (dflags `gopt_set` Opt_Haddock)
+            pstate = initParserState opts stringBuffer loc
         case unP (lexer False return) pstate of
             POk s (L _ ITeof) -> return (map unLoc (toList (hdk_comments s)))
             _                 -> error "No token"

testsuite/tests/ghc-api/T9015.hs

@@ -3,7 +3,7 @@ module Main where
 import GHC
 import GHC.Driver.Session
 import GHC.Driver.Monad
-import GHC.Parser.Lexer (mkParserFlags)
+import GHC.Driver.Config
 import System.Environment
 
 testStrings = [
@@ -53,7 +53,7 @@ main = do
   where
     testWithParser parser = do
       dflags <- getSessionDynFlags
-      let pflags = mkParserFlags dflags
+      let pflags = initParserOpts dflags
       liftIO . putStrLn . unlines $ map (testExpr (parser pflags)) testStrings
 
     testExpr parser expr = do

testsuite/tests/parser/should_run/CountParserDeps.hs

@@ -28,9 +28,12 @@ main = do
   [libdir] <- getArgs
   modules <- parserDeps libdir
   let num = sizeUniqSet modules
---  print num
---  print (map moduleNameString $ nonDetEltsUniqSet modules)
-  unless (num <= 201) $ exitWith (ExitFailure num)
+      max_num = 201
+      min_num = max_num - 10 -- so that we don't forget to change the number
+                             -- when the number of dependencies decreases
+  -- putStrLn $ "Found " ++ show num ++ " parser module dependencies"
+  -- forM_ (map moduleNameString $ nonDetEltsUniqSet modules) putStrLn
+  unless (num <= max_num && num >= min_num) $ exitWith (ExitFailure num)
 
 parserDeps :: FilePath -> IO (UniqSet ModuleName)
 parserDeps libdir =

haddock @ a18c3af7

-Subproject commit 37c47822d390b553ce24fe256c9700d5fd83bf9f
+Subproject commit a18c3af7f983f3b6d3cd84093c9079031da58468