diff options
| -rw-r--r-- | compiler/GHC/Driver/Backpack.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Config/Parser.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Pipeline.hs | 8 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Errors/Ppr.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Errors/Types.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Header.hs | 41 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Lexer.x | 13 | ||||
| -rw-r--r-- | testsuite/tests/ghc-api/T10942.hs | 4 | ||||
| -rw-r--r-- | utils/check-exact/Parsers.hs | 6 |
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 |