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.

4 files changed, 33 insertions, 29 deletions

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)