[Git][ghc/ghc][master] Refactoring: Remove `pSupportedExts` from `ParserOpts`
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Nov 25 19:04:15 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
caaf5388 by Simon Hengel at 2024-11-25T14:02:41-05:00
Refactoring: Remove `pSupportedExts` from `ParserOpts`
This is never used for lexing / parsing. It is only used by
`GHC.Parser.Header.getOptions`.
- - - - -
13 changed files:
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Config/Parser.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Parser/HaddockLex.x
- compiler/GHC/Parser/Header.hs
- compiler/GHC/Parser/Lexer.x
- ghc/GHCi/UI.hs
- testsuite/tests/ghc-api/T10942.hs
- utils/check-exact/Parsers.hs
- utils/haddock/haddock-api/src/Haddock.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
Changes:
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -24,7 +24,7 @@ import GHC.Driver.Backend
-- In a separate module because it hooks into the parser.
import GHC.Driver.Backpack.Syntax
import GHC.Driver.Config.Finder (initFinderOpts)
-import GHC.Driver.Config.Parser (initParserOpts)
+import GHC.Driver.Config.Parser
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Monad
import GHC.Driver.Session
@@ -100,7 +100,7 @@ doBackpack [src_filename] = do
dflags0 <- getDynFlags
let dflags1 = dflags0
let parser_opts1 = initParserOpts dflags1
- (p_warns, src_opts) <- liftIO $ getOptionsFromFile parser_opts1 src_filename
+ (p_warns, src_opts) <- liftIO $ getOptionsFromFile parser_opts1 (supportedLanguagePragmas dflags1) src_filename
(dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts
modifySession (hscSetFlags dflags)
logger <- getLogger -- Get the logger after having set the session flags,
=====================================
compiler/GHC/Driver/Config/Parser.hs
=====================================
@@ -1,5 +1,6 @@
module GHC.Driver.Config.Parser
( initParserOpts
+ , supportedLanguagePragmas
)
where
@@ -17,9 +18,10 @@ initParserOpts =
mkParserOpts
<$> extensionFlags
<*> initDiagOpts
- <*> (supportedLanguagesAndExtensions . platformArchOS . targetPlatform)
<*> safeImportsOn
<*> gopt Opt_Haddock
<*> gopt Opt_KeepRawTokenStream
<*> const True -- use LINE/COLUMN to update the internal location
+supportedLanguagePragmas :: DynFlags -> [String]
+supportedLanguagePragmas = supportedLanguagesAndExtensions . platformArchOS . targetPlatform
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -657,7 +657,7 @@ getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, Messages
getFileArgs hsc_env input_fn = do
let dflags0 = hsc_dflags hsc_env
parser_opts = initParserOpts dflags0
- (warns0, src_opts) <- getOptionsFromFile parser_opts input_fn
+ (warns0, src_opts) <- getOptionsFromFile parser_opts (supportedLanguagePragmas dflags0) input_fn
(dflags1, unhandled_flags, warns)
<- parseDynamicFilePragma dflags0 src_opts
checkProcessArgsResult unhandled_flags
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -3167,7 +3167,7 @@ setMainIs arg = parse parse_main_f arg
-- dummy parser state.
p_state str = initParserState
- (mkParserOpts mempty emptyDiagOpts [] False False False True)
+ (mkParserOpts mempty emptyDiagOpts False False False True)
(stringToStringBuffer str)
(mkRealSrcLoc (mkFastString []) 1 1)
=====================================
compiler/GHC/Parser/HaddockLex.x
=====================================
@@ -175,7 +175,6 @@ validateIdentWith identParser mloc str0 =
pflags = mkParserOpts
(EnumSet.fromList [LangExt.MagicHash])
dopts
- []
False False False False
dopts = emptyDiagOpts
buffer = stringBufferFromByteString str0
=====================================
compiler/GHC/Parser/Header.hs
=====================================
@@ -168,14 +168,15 @@ mkPrelImports this_mod loc implicit_prelude import_decls
--
-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
getOptionsFromFile :: ParserOpts
+ -> [String] -- ^ Supported LANGUAGE pragmas
-> FilePath -- ^ Input file
-> IO (Messages PsMessage, [Located String]) -- ^ Parsed options, if any.
-getOptionsFromFile opts filename
+getOptionsFromFile opts supported filename
= Exception.bracket
(openBinaryFile filename ReadMode)
(hClose)
(\handle -> do
- (warns, opts) <- fmap (getOptions' opts)
+ (warns, opts) <- fmap (getOptions' opts supported)
(lazyGetToks opts' filename handle)
seqList opts
$ seqList (bagToList $ getMessages warns)
@@ -249,20 +250,22 @@ getToks popts filename buf = lexAll pstate
--
-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
getOptions :: ParserOpts
+ -> [String] -- ^ Supported LANGUAGE pragmas
-> StringBuffer -- ^ Input Buffer
-> FilePath -- ^ Source filename. Used for location info.
-> (Messages PsMessage,[Located String]) -- ^ warnings and parsed options.
-getOptions opts buf filename
- = getOptions' opts (getToks opts filename buf)
+getOptions opts supported buf filename
+ = getOptions' opts supported (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' :: ParserOpts
+ -> [String]
-> [Located Token] -- Input buffer
-> (Messages PsMessage,[Located String]) -- Options.
-getOptions' opts toks
+getOptions' opts supported toks
= parseToks toks
where
parseToks (open:close:xs)
@@ -296,7 +299,7 @@ getOptions' opts toks
parseToks xs = (unionManyMessages $ mapMaybe mkMessage xs ,[])
parseLanguage ((L loc (ITconid fs)):rest)
- = fmap (checkExtension opts (L loc fs) :) $
+ = fmap (checkExtension supported (L loc fs) :) $
case rest of
(L _loc ITcomma):more -> parseLanguage more
(L _loc ITclose_prag):more -> parseToks more
@@ -446,13 +449,13 @@ checkProcessArgsResult flags
-----------------------------------------------------------------------------
-checkExtension :: ParserOpts -> Located FastString -> Located String
-checkExtension opts (L l ext)
+checkExtension :: [String] -> Located FastString -> Located String
+checkExtension supported (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` (pSupportedExts opts)
+ = if ext' `elem` supported
then L l ("-X"++ext')
- else unsupportedExtnError opts l ext'
+ else unsupportedExtnError supported l ext'
where
ext' = unpackFS ext
@@ -460,9 +463,9 @@ languagePragParseError :: SrcSpan -> a
languagePragParseError loc =
throwErr loc $ PsErrParseLanguagePragma
-unsupportedExtnError :: ParserOpts -> SrcSpan -> String -> a
-unsupportedExtnError opts loc unsup =
- throwErr loc $ PsErrUnsupportedExt unsup (pSupportedExts opts)
+unsupportedExtnError :: [String] -> SrcSpan -> String -> a
+unsupportedExtnError supported loc unsup =
+ throwErr loc $ PsErrUnsupportedExt unsup supported
optionsParseError :: String -> SrcSpan -> a -- #15053
optionsParseError str loc =
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -2419,8 +2419,6 @@ data ParserOpts = ParserOpts
{ pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions
, pDiagOpts :: !DiagOpts
-- ^ Options to construct diagnostic messages.
- , pSupportedExts :: [String]
- -- ^ supported extensions (only used for suggestions in error messages)
}
pWarningFlags :: ParserOpts -> EnumSet WarningFlag
@@ -2890,7 +2888,6 @@ data ExtBits
mkParserOpts
:: EnumSet LangExt.Extension -- ^ permitted language extensions enabled
-> DiagOpts -- ^ diagnostic options
- -> [String] -- ^ Supported Languages and Extensions
-> Bool -- ^ are safe imports on?
-> Bool -- ^ keeping Haddock comment tokens
-> Bool -- ^ keep regular comment tokens
@@ -2902,12 +2899,11 @@ mkParserOpts
-> ParserOpts
-- ^ Given exactly the information needed, set up the 'ParserOpts'
-mkParserOpts extensionFlags diag_opts supported
+mkParserOpts extensionFlags diag_opts
safeImports isHaddock rawTokStream usePosPrags =
ParserOpts {
pDiagOpts = diag_opts
, pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits
- , pSupportedExts = supported
}
where
safeHaskellBit = SafeHaskellBit `setBitIf` safeImports
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -55,7 +55,7 @@ import GHC.Driver.Ppr hiding (printForUser)
import GHC.Utils.Error hiding (traceCmd)
import GHC.Driver.Monad ( modifySession )
import GHC.Driver.Make ( newIfaceCache, ModIfaceCache(..) )
-import GHC.Driver.Config.Parser (initParserOpts)
+import GHC.Driver.Config.Parser
import GHC.Driver.Config.Diagnostic
import qualified GHC
import GHC ( LoadHowMuch(..), Target(..), TargetId(..),
@@ -1253,7 +1253,8 @@ 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 <- initParserOpts <$> GHC.getInteractiveDynFlags
+ dflags <- GHC.getInteractiveDynFlags
+ let pflags = initParserOpts dflags
-- 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.
@@ -1262,8 +1263,8 @@ runStmt input step = do
let source = progname st
let line = line_number st
- -- Add any LANGUAGE/OPTIONS_GHC pragmas we find find.
- set_pragmas pflags
+ -- Add any LANGUAGE/OPTIONS_GHC pragmas we find.
+ set_pragmas pflags (supportedLanguagePragmas dflags)
if | GHC.isStmt pflags input -> do
hsc_env <- GHC.getSession
@@ -1298,9 +1299,9 @@ runStmt input step = do
run_imports imports = mapM_ (addImportToContext . unLoc) imports
- set_pragmas pflags =
+ set_pragmas pflags supported =
let stringbuf = stringToStringBuffer input
- (_msgs, loc_opts) = Header.getOptions pflags stringbuf "<interactive>"
+ (_msgs, loc_opts) = Header.getOptions pflags supported stringbuf "<interactive>"
opts = unLoc <$> loc_opts
in setOptions opts
=====================================
testsuite/tests/ghc-api/T10942.hs
=====================================
@@ -21,4 +21,4 @@ main = do
parser_opts = initParserOpts dflags'
setSessionDynFlags dflags'
stringBuffer <- liftIO $ hGetStringBuffer filename
- liftIO $ print (map unLoc (snd $ getOptions parser_opts stringBuffer filename))
+ liftIO $ print (map unLoc (snd $ getOptions parser_opts (supportedLanguagePragmas dflags) stringBuffer filename))
=====================================
utils/check-exact/Parsers.hs
=====================================
@@ -348,7 +348,7 @@ initDynFlags file = do
-- Based on GHC backpack driver doBackPack
dflags0 <- GHC.getSessionDynFlags
let parser_opts0 = GHC.initParserOpts dflags0
- (_, src_opts) <- GHC.liftIO $ GHC.getOptionsFromFile parser_opts0 file
+ (_, src_opts) <- GHC.liftIO $ GHC.getOptionsFromFile parser_opts0 (GHC.supportedLanguagePragmas dflags0) file
(dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 src_opts
-- Turn this on last to avoid T10942
let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream
@@ -376,7 +376,7 @@ initDynFlagsPure fp s = do
-- no reason to use it.
dflags0 <- GHC.getSessionDynFlags
let parser_opts0 = GHC.initParserOpts dflags0
- let (_, pragmaInfo) = GHC.getOptions parser_opts0 (GHC.stringToStringBuffer $ s) fp
+ let (_, pragmaInfo) = GHC.getOptions parser_opts0 (GHC.supportedLanguagePragmas dflags0) (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
=====================================
utils/haddock/haddock-api/src/Haddock.hs
=====================================
@@ -82,7 +82,7 @@ import Haddock.Version
import Haddock.InterfaceFile
import Haddock.Options
import Haddock.Utils
-import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir, getSupportedLanguagesAndExtensions)
+import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir)
import Haddock.Compat (getProcessID)
--------------------------------------------------------------------------------
@@ -228,7 +228,6 @@ haddockWithGhc ghc args = handleTopExceptions $ do
, piPackageVersion =
fromMaybe (makeVersion []) (optPackageVersion flags)
}
- languagesAndExtensions = getSupportedLanguagesAndExtensions ifaces
-- Dump an "interface file" (.haddock file), if requested.
forM_ (optDumpInterfaceFile flags) $ \path -> liftIO $ do
@@ -239,7 +238,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
}
-- Render the interfaces.
- liftIO $ renderStep dflags languagesAndExtensions parserOpts logger unit_state flags sinceQual qual packages ifaces
+ liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual packages ifaces
-- If we were not given any input files, error if documentation was
-- requested
@@ -252,7 +251,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks
-- Render even though there are no input files (usually contents/index).
- liftIO $ renderStep dflags [] parserOpts logger unit_state flags sinceQual qual packages []
+ liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual packages []
-- | Run the GHC action using a temporary output directory
withTempOutputDir :: Ghc a -> Ghc a
@@ -306,8 +305,6 @@ readPackagesAndProcessModules flags files = do
renderStep
:: DynFlags
- -> [String]
- -- ^ Supported languages and extensions based on architecture and OS
-> ParserOpts
-> Logger
-> UnitState
@@ -317,7 +314,7 @@ renderStep
-> [(DocPaths, Visibility, FilePath, InterfaceFile)]
-> [Interface]
-> IO ()
-renderStep dflags languagesAndExtensions parserOpts logger unit_state flags sinceQual nameQual pkgs interfaces = do
+renderStep dflags parserOpts logger unit_state flags sinceQual nameQual pkgs interfaces = do
updateHTMLXRefs (map (\(docPath, _ifaceFilePath, _showModules, ifaceFile) ->
( case baseUrl flags of
Nothing -> docPathsHtml docPath
@@ -333,7 +330,7 @@ renderStep dflags languagesAndExtensions parserOpts logger unit_state flags sinc
(DocPaths {docPathsSources=Just path}, _, _, ifile) <- pkgs
iface <- ifInstalledIfaces ifile
return (instMod iface, path)
- render dflags languagesAndExtensions parserOpts logger unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap
+ render dflags parserOpts logger unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap
where
-- get package name from unit-id
packageName :: Unit -> String
@@ -345,8 +342,6 @@ renderStep dflags languagesAndExtensions parserOpts logger unit_state flags sinc
-- | Render the interfaces with whatever backend is specified in the flags.
render
:: DynFlags
- -> [String]
- -- ^ Supported languages and extensions based on architecture and OS
-> ParserOpts
-> Logger
-> UnitState
@@ -357,7 +352,7 @@ render
-> [(FilePath, PackageInterfaces)]
-> Map Module FilePath
-> IO ()
-render dflags languagesAndExtensions parserOpts logger unit_state flags sinceQual qual ifaces packages extSrcMap = do
+render dflags parserOpts logger unit_state flags sinceQual qual ifaces packages extSrcMap = do
let
packageInfo = PackageInfo { piPackageName = fromMaybe (PackageName mempty)
$ optPackageName flags
@@ -560,7 +555,7 @@ render dflags languagesAndExtensions parserOpts logger unit_state flags sinceQua
when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do
withTiming logger "ppHyperlinkedSource" (const ()) $ do
_ <- {-# SCC ppHyperlinkedSource #-}
- ppHyperlinkedSource (verbosity flags) (isJust (optOneShot flags)) languagesAndExtensions odir libDir opt_source_css pretty srcMap ifaces
+ ppHyperlinkedSource (verbosity flags) (isJust (optOneShot flags)) odir libDir opt_source_css pretty srcMap ifaces
return ()
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs
=====================================
@@ -42,8 +42,6 @@ ppHyperlinkedSource
:: Verbosity
-> Bool
-- ^ In one-shot mode
- -> [String]
- -- ^ Supported languages and extensions based on architecture and OS
-> FilePath
-- ^ Output directory
-> FilePath
@@ -57,14 +55,14 @@ ppHyperlinkedSource
-> [Interface]
-- ^ Interfaces for which we create source
-> IO ()
-ppHyperlinkedSource verbosity isOneShot languagesAndExtensions outdir libdir mstyle pretty srcs' ifaces = do
+ppHyperlinkedSource verbosity isOneShot outdir libdir mstyle pretty srcs' ifaces = do
createDirectoryIfMissing True srcdir
unless isOneShot $ do
let cssFile = fromMaybe (defaultCssFile libdir) mstyle
copyFile cssFile $ srcdir </> srcCssFile
copyFile (libdir </> "html" </> highlightScript) $
srcdir </> highlightScript
- mapM_ (ppHyperlinkedModuleSource verbosity languagesAndExtensions srcdir pretty srcs) ifaces
+ mapM_ (ppHyperlinkedModuleSource verbosity srcdir pretty srcs) ifaces
where
srcdir = outdir </> hypSrcDir
srcs = (srcs', M.mapKeys moduleName srcs')
@@ -72,14 +70,12 @@ ppHyperlinkedSource verbosity isOneShot languagesAndExtensions outdir libdir ms
-- | Generate hyperlinked source for particular interface.
ppHyperlinkedModuleSource
:: Verbosity
- -> [String]
- -- ^ Supported languages and extensions based on architecture and OS
-> FilePath
-> Bool
-> SrcMaps
-> Interface
-> IO ()
-ppHyperlinkedModuleSource verbosity languagesAndExtensions srcdir pretty srcs iface = do
+ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do
-- Parse the GHC-produced HIE file
nc <- freshNameCache
HieFile
@@ -128,7 +124,6 @@ ppHyperlinkedModuleSource verbosity languagesAndExtensions srcdir pretty srcs if
Lexer.mkParserOpts
(dflags.extensionFlags)
(initDiagOpts dflags)
- languagesAndExtensions
(safeImportsOn dflags)
False -- lex Haddocks as comment tokens
True -- produce comment tokens
=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -47,7 +47,6 @@ import GHC.Data.StringBuffer (StringBuffer)
import qualified GHC.Data.StringBuffer as S
import GHC.Driver.Session
import GHC.HsToCore.Docs hiding (sigNameNoLoc)
-import GHC.Platform (Platform (..))
import GHC.Types.Name
import GHC.Types.SrcLoc (advanceSrcLoc)
import GHC.Types.Var
@@ -65,7 +64,7 @@ import GHC.Utils.Outputable (Outputable, SDocContext, ppr)
import qualified GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic (panic)
-import Haddock.Types (DocName, DocNameI, Interface (..), XRecCond)
+import Haddock.Types (DocName, DocNameI, XRecCond)
moduleString :: Module -> String
moduleString = moduleNameString . moduleName
@@ -618,14 +617,6 @@ setOutputDir dir dynFlags =
, dumpDir = Just dir
}
-getSupportedLanguagesAndExtensions
- :: [Interface]
- -> [String]
-getSupportedLanguagesAndExtensions [] = []
-getSupportedLanguagesAndExtensions (iface : _) = do
- let dflags = ifaceDynFlags iface
- in supportedLanguagesAndExtensions dflags.targetPlatform.platformArchOS
-
-------------------------------------------------------------------------------
-- * 'StringBuffer' and 'ByteString'
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/caaf53881d5cc82ebff617f39ad5363429d2eccf
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/caaf53881d5cc82ebff617f39ad5363429d2eccf
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241125/3cca25a4/attachment-0001.html>
More information about the ghc-commits
mailing list