Parser: make less DynFlags dependent

This is an attempt at reducing the number of dependencies of the Parser
(as reported by CountParserDeps). Modules in GHC.Parser.* don't import
GHC.Driver.Session directly anymore.

Sadly some GHC.Driver.* modules are still transitively imported and the
number of dependencies didn't decrease. But it's a step in the right
direction.

9 files changed, 49 insertions, 36 deletions

diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index d9723c0f1b..ca34af8d0f 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -95,7 +95,8 @@ doBackpack [src_filename] = do
     -- Apply options from file to dflags
     dflags0 <- getDynFlags
     let dflags1 = dflags0
-    src_opts <- liftIO $ getOptionsFromFile dflags1 src_filename
+    let parser_opts1 = initParserOpts dflags1
+    src_opts <- liftIO $ getOptionsFromFile parser_opts1 src_filename
     (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts
     modifySession (hscSetFlags dflags)
     -- Cribbed from: preprocessFile / GHC.Driver.Pipeline
diff --git a/compiler/GHC/Driver/Config/Parser.hs b/compiler/GHC/Driver/Config/Parser.hs
index bc4c589bf8..335e1d530e 100644
--- a/compiler/GHC/Driver/Config/Parser.hs
+++ b/compiler/GHC/Driver/Config/Parser.hs
@@ -4,6 +4,7 @@ module GHC.Driver.Config.Parser
 where
 
 import GHC.Prelude
+import GHC.Platform
 
 import GHC.Driver.Session
 import GHC.Utils.Error
@@ -17,6 +18,7 @@ initParserOpts =
     <$> warningFlags
     <*> extensionFlags
     <*> mkPlainMsgEnvelope
+    <*> (supportedLanguagesAndExtensions . platformArchOS . targetPlatform)
     <*> safeImportsOn
     <*> gopt Opt_Haddock
     <*> gopt Opt_KeepRawTokenStream
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 7c2c986967..59b5b5ea56 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -1135,7 +1135,8 @@ runPhase (RealPhase (Unlit sf)) input_fn = do
 runPhase (RealPhase (Cpp sf)) input_fn
   = do
        dflags0 <- getDynFlags
-       src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
+       let parser_opts0 = initParserOpts dflags0
+       src_opts <- liftIO $ getOptionsFromFile parser_opts0 input_fn
        (dflags1, unhandled_flags, warns)
            <- liftIO $ parseDynamicFilePragma dflags0 src_opts
        setDynFlags dflags1
@@ -1163,7 +1164,7 @@ runPhase (RealPhase (Cpp sf)) input_fn
                            input_fn output_fn
             -- re-read the pragmas now that we've preprocessed the file
             -- See #2464,#3457
-            src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
+            src_opts <- liftIO $ getOptionsFromFile parser_opts0 output_fn
             (dflags2, unhandled_flags, warns)
                 <- liftIO $ parseDynamicFilePragma dflags0 src_opts
             setDynFlags dflags2
@@ -1197,7 +1198,8 @@ runPhase (RealPhase (HsPp sf)) input_fn = do
                        )
 
         -- re-read pragmas now that we've parsed the file (see #3674)
-        src_opts <- liftIO $ getOptionsFromFile dflags output_fn
+        let parser_opts = initParserOpts dflags
+        src_opts <- liftIO $ getOptionsFromFile parser_opts output_fn
         (dflags1, unhandled_flags, warns)
             <- liftIO $ parseDynamicFilePragma dflags src_opts
         setDynFlags dflags1
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index 2cf52db558..0c35b4290f 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -9,7 +9,6 @@ module GHC.Parser.Errors.Ppr where
 
 import GHC.Prelude
 import GHC.Driver.Flags
-import GHC.Driver.Session (supportedLanguagesAndExtensions)
 import GHC.Parser.Errors.Types
 import GHC.Parser.Types
 import GHC.Types.Basic
@@ -791,7 +790,7 @@ psHeaderMessageHints :: PsHeaderMessage -> [GhcHint]
 psHeaderMessageHints = \case
   PsErrParseLanguagePragma
     -> noHints
-  PsErrUnsupportedExt unsup arch
+  PsErrUnsupportedExt unsup supported
     -> if null suggestions
           then noHints
           -- FIXME(adn) To fix the compiler crash in #19923 we just rewrap this into an
@@ -800,7 +799,7 @@ psHeaderMessageHints = \case
           else [UnknownHint $ text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)]
        where
          suggestions :: [String]
-         suggestions = fuzzyMatch unsup (supportedLanguagesAndExtensions arch)
+         suggestions = fuzzyMatch unsup supported
   PsErrParseOptionsPragma{}
     -> noHints
 
diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs
index 88a287d69b..95b1733c6e 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -15,7 +15,6 @@ import GHC.Types.Name.Occurrence (OccName)
 import GHC.Types.Name.Reader
 import GHC.Unit.Module.Name
 import GHC.Utils.Outputable
-import GHC.Platform.ArchOS
 
 -- The type aliases below are useful to make some type signatures a bit more
 -- descriptive, like 'handleWarningsThrowErrors' in 'GHC.Driver.Main'.
@@ -37,7 +36,7 @@ and having a single constructor to handle them all is handy.
 
 data PsHeaderMessage
   = PsErrParseLanguagePragma
-  | PsErrUnsupportedExt !String !ArchOS
+  | PsErrUnsupportedExt !String ![String]
   | PsErrParseOptionsPragma !String
 
 
diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs
index 0249acb769..2037f6bc48 100644
--- a/compiler/GHC/Parser/Header.hs
+++ b/compiler/GHC/Parser/Header.hs
@@ -23,10 +23,6 @@ where
 
 import GHC.Prelude
 
-import GHC.Platform
-
-import GHC.Driver.Session
-import GHC.Driver.Config.Parser (initParserOpts)
 import GHC.Driver.Errors.Types -- Unfortunate, needed due to the fact we throw exceptions!
 
 import GHC.Parser.Errors.Types
@@ -163,16 +159,16 @@ mkPrelImports this_mod loc implicit_prelude import_decls
 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
 --
 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
-getOptionsFromFile :: DynFlags
+getOptionsFromFile :: ParserOpts
                    -> FilePath            -- ^ Input file
                    -> IO [Located String] -- ^ Parsed options, if any.
-getOptionsFromFile dflags filename
+getOptionsFromFile opts filename
     = Exception.bracket
               (openBinaryFile filename ReadMode)
               (hClose)
               (\handle -> do
-                  opts <- fmap (getOptions' dflags)
-                               (lazyGetToks (initParserOpts dflags') filename handle)
+                  opts <- fmap (getOptions' opts)
+                               (lazyGetToks opts' filename handle)
                   seqList opts $ return opts)
     where -- We don't need to get haddock doc tokens when we're just
           -- getting the options from pragmas, and lazily lexing them
@@ -182,7 +178,7 @@ getOptionsFromFile dflags filename
           -- we already have an apparently-complete token.
           -- We therefore just turn Opt_Haddock off when doing the lazy
           -- lex.
-          dflags' = gopt_unset dflags Opt_Haddock
+          opts' = disableHaddock opts
 
 blockSize :: Int
 -- blockSize = 17 -- for testing :-)
@@ -242,21 +238,21 @@ getToks popts filename buf = lexAll pstate
 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
 --
 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
-getOptions :: DynFlags
+getOptions :: ParserOpts
            -> StringBuffer -- ^ Input Buffer
            -> FilePath     -- ^ Source filename.  Used for location info.
            -> [Located String] -- ^ Parsed options.
-getOptions dflags buf filename
-    = getOptions' dflags (getToks (initParserOpts dflags) filename buf)
+getOptions opts buf filename
+    = getOptions' opts (getToks opts filename buf)
 
 -- The token parser is written manually because Happy can't
 -- return a partial result when it encounters a lexer error.
 -- We want to extract options before the buffer is passed through
 -- CPP, so we can't use the same trick as 'getImports'.
-getOptions' :: DynFlags
+getOptions' :: ParserOpts
             -> [Located Token]      -- Input buffer
             -> [Located String]     -- Options.
-getOptions' dflags toks
+getOptions' opts toks
     = parseToks toks
     where
           parseToks (open:close:xs)
@@ -288,7 +284,7 @@ getOptions' dflags toks
               = parseToks xs
           parseToks _ = []
           parseLanguage ((L loc (ITconid fs)):rest)
-              = checkExtension dflags (L loc fs) :
+              = checkExtension opts (L loc fs) :
                 case rest of
                   (L _loc ITcomma):more -> parseLanguage more
                   (L _loc ITclose_prag):more -> parseToks more
@@ -429,24 +425,23 @@ checkProcessArgsResult flags
 
 -----------------------------------------------------------------------------
 
-checkExtension :: DynFlags -> Located FastString -> Located String
-checkExtension dflags (L l ext)
+checkExtension :: ParserOpts -> Located FastString -> Located String
+checkExtension opts (L l ext)
 -- Checks if a given extension is valid, and if so returns
 -- its corresponding flag. Otherwise it throws an exception.
-  = if ext' `elem` supported
+  = if ext' `elem` (pSupportedExts opts)
     then L l ("-X"++ext')
-    else unsupportedExtnError dflags l ext'
+    else unsupportedExtnError opts l ext'
   where
     ext' = unpackFS ext
-    supported = supportedLanguagesAndExtensions $ platformArchOS $ targetPlatform dflags
 
 languagePragParseError :: SrcSpan -> a
 languagePragParseError loc =
     throwErr loc $ PsErrParseLanguagePragma
 
-unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a
-unsupportedExtnError dflags loc unsup =
-    throwErr loc $ PsErrUnsupportedExt unsup (platformArchOS $ targetPlatform dflags)
+unsupportedExtnError :: ParserOpts -> SrcSpan -> String -> a
+unsupportedExtnError opts loc unsup =
+    throwErr loc $ PsErrUnsupportedExt unsup (pSupportedExts opts)
 
 optionsParseError :: String -> SrcSpan -> a     -- #15053
 optionsParseError str loc =
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index 10c9f2042f..1466e7da71 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -68,6 +68,7 @@ module GHC.Parser.Lexer (
    getLexState, popLexState, pushLexState,
    ExtBits(..),
    xtest, xunset, xset,
+   disableHaddock,
    lexTokenStream,
    mkParensEpAnn,
    getCommentsFor, getPriorCommentsFor, getFinalCommentsFor,
@@ -2324,6 +2325,8 @@ data ParserOpts = ParserOpts
     -- ^ The function to be used to construct diagnostic messages.
     -- The idea is to partially-apply 'mkParserMessage' upstream, to
     -- avoid the dependency on the 'DynFlags' in the Lexer.
+  , pSupportedExts  :: [String]
+    -- ^ supported extensions (only used for suggestions in error messages)
   }
 
 -- | Haddock comment as produced by the lexer. These are accumulated in
@@ -2771,6 +2774,7 @@ mkParserOpts
   :: EnumSet WarningFlag        -- ^ warnings flags enabled
   -> EnumSet LangExt.Extension  -- ^ permitted language extensions enabled
   -> (SrcSpan -> PsMessage -> MsgEnvelope PsMessage) -- ^ How to construct diagnostics
+  -> [String]                   -- ^ Supported Languages and Extensions
   -> Bool                       -- ^ are safe imports on?
   -> Bool                       -- ^ keeping Haddock comment tokens
   -> Bool                       -- ^ keep regular comment tokens
@@ -2782,12 +2786,13 @@ mkParserOpts
 
   -> ParserOpts
 -- ^ Given exactly the information needed, set up the 'ParserOpts'
-mkParserOpts warningFlags extensionFlags mkMessage
+mkParserOpts warningFlags extensionFlags mkMessage supported
   safeImports isHaddock rawTokStream usePosPrags =
     ParserOpts {
       pWarningFlags  = warningFlags
     , pExtsBitmap    = safeHaskellBit .|. langExtBits .|. optBits
     , pMakePsMessage = mkMessage
+    , pSupportedExts = supported
     }
   where
     safeHaskellBit = SafeHaskellBit `setBitIf` safeImports
@@ -2848,6 +2853,12 @@ mkParserOpts warningFlags extensionFlags mkMessage
     b `setBitIf` cond | cond      = xbit b
                       | otherwise = 0
 
+disableHaddock :: ParserOpts -> ParserOpts
+disableHaddock opts = upd_bitmap (xunset HaddockBit)
+  where
+    upd_bitmap f = opts { pExtsBitmap = f (pExtsBitmap opts) }
+
+
 -- | Set parser options for parsing OPTIONS pragmas
 initPragState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState
 initPragState options buf loc = (initParserState options buf loc)
diff --git a/testsuite/tests/ghc-api/T10942.hs b/testsuite/tests/ghc-api/T10942.hs
index a6cee0fd7f..06cdcd62e4 100644
--- a/testsuite/tests/ghc-api/T10942.hs
+++ b/testsuite/tests/ghc-api/T10942.hs
@@ -1,6 +1,7 @@
 module Main where
 
 import GHC.Driver.Session
+import GHC.Driver.Config.Parser
 import GHC
 
 import Control.Monad.IO.Class (liftIO)
@@ -17,6 +18,7 @@ main = do
     let dflags' = dflags `gopt_set` Opt_KeepRawTokenStream
                          `gopt_set` Opt_Haddock
         filename = "T10942_A.hs"
+        parser_opts = initParserOpts dflags'
     setSessionDynFlags dflags'
     stringBuffer <- liftIO $ hGetStringBuffer filename
-    liftIO $ print (map unLoc (getOptions dflags' stringBuffer filename))
+    liftIO $ print (map unLoc (getOptions parser_opts stringBuffer filename))
diff --git a/utils/check-exact/Parsers.hs b/utils/check-exact/Parsers.hs
index 5d8b180cd4..cb6af2ad94 100644
--- a/utils/check-exact/Parsers.hs
+++ b/utils/check-exact/Parsers.hs
@@ -278,7 +278,8 @@ postParseTransform parseRes = fmap mkAnns parseRes
 initDynFlags :: GHC.GhcMonad m => FilePath -> m GHC.DynFlags
 initDynFlags file = do
   dflags0         <- GHC.getSessionDynFlags
-  src_opts        <- GHC.liftIO $ GHC.getOptionsFromFile dflags0 file
+  let parser_opts0 = GHC.initParserOpts dflags0
+  src_opts        <- GHC.liftIO $ GHC.getOptionsFromFile parser_opts0 file
   (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 src_opts
   -- Turn this on last to avoid T10942
   let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream
@@ -304,7 +305,8 @@ initDynFlagsPure fp s = do
   -- as long as `parseDynamicFilePragma` is impure there seems to be
   -- no reason to use it.
   dflags0 <- GHC.getSessionDynFlags
-  let pragmaInfo = GHC.getOptions dflags0 (GHC.stringToStringBuffer $ s) fp
+  let parser_opts0 = GHC.initParserOpts dflags0
+  let pragmaInfo = GHC.getOptions parser_opts0 (GHC.stringToStringBuffer $ s) fp
   (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 pragmaInfo
   -- Turn this on last to avoid T10942
   let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream