diff options
Diffstat (limited to 'haddock-api')
-rw-r--r-- | haddock-api/src/Haddock.hs | 17 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 3 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface.hs | 14 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Parser.hs | 2 |
4 files changed, 19 insertions, 17 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index d955ae4f..9158d83c 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -69,8 +69,10 @@ import Text.ParserCombinators.ReadP (readP_to_S) import GHC hiding (verbosity) import GHC.Settings.Config import GHC.Driver.Session hiding (projectVersion, verbosity) +import GHC.Driver.Config.Logger (initLogFlags) import GHC.Driver.Env import GHC.Utils.Error +import GHC.Utils.Logger import GHC.Types.Name.Cache import GHC.Unit import GHC.Utils.Panic (handleGhcException) @@ -192,7 +194,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do name_cache <- freshNameCache mIfaceFile <- readInterfaceFiles name_cache [(("", Nothing), path)] noChecks forM_ mIfaceFile $ \(_, ifaceFile) -> do - putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile) + putMsg logger $ renderJson (jsonInterfaceFile ifaceFile) if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files @@ -282,7 +284,7 @@ renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = d -- | Render the interfaces with whatever backend is specified in the flags. render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO () -render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do +render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do let title = fromMaybe "" (optTitle flags) @@ -298,6 +300,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS dflags' | unicode = gopt_set dflags Opt_PrintUnicodeSyntax | otherwise = dflags + logger = setLogFlags log' (initLogFlags dflags') visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] @@ -372,7 +375,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS let withQuickjump = Flag_QuickJumpIndex `elem` flags when (Flag_GenIndex `elem` flags) $ do - withTiming logger dflags' "ppHtmlIndex" (const ()) $ do + withTiming logger "ppHtmlIndex" (const ()) $ do _ <- {-# SCC ppHtmlIndex #-} ppHtmlIndex odir title pkgStr themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls @@ -382,7 +385,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS copyHtmlBits odir libDir themes withQuickjump when (Flag_GenContents `elem` flags) $ do - withTiming logger dflags' "ppHtmlContents" (const ()) $ do + withTiming logger "ppHtmlContents" (const ()) $ do _ <- {-# SCC ppHtmlContents #-} ppHtmlContents unit_state odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls @@ -392,7 +395,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS copyHtmlBits odir libDir themes withQuickjump when (Flag_Html `elem` flags) $ do - withTiming logger dflags' "ppHtml" (const ()) $ do + withTiming logger "ppHtml" (const ()) $ do _ <- {-# SCC ppHtml #-} ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir prologue @@ -427,14 +430,14 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS ] when (Flag_LaTeX `elem` flags) $ do - withTiming logger dflags' "ppLatex" (const ()) $ do + withTiming logger "ppLatex" (const ()) $ do _ <- {-# SCC ppLatex #-} ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style libDir return () when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do - withTiming logger dflags' "ppHyperlinkedSource" (const ()) $ do + withTiming logger "ppHyperlinkedSource" (const ()) $ do _ <- {-# SCC ppHyperlinkedSource #-} ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces return () diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 94395218..49e2c66f 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -10,6 +10,7 @@ import Data.List ( isPrefixOf, isSuffixOf ) import qualified Data.ByteString as BS +import GHC.Platform import GHC.Types.SourceText import GHC.Driver.Session import GHC.Utils.Error ( mkPlainMsgEnvelope, pprLocMsgEnvelope ) @@ -49,9 +50,11 @@ parse dflags fpath bs = case unP (go False []) initState of initState = initParserState pflags buf start buf = stringBufferFromByteString bs start = mkRealSrcLoc (mkFastString fpath) 1 1 + arch_os = platformArchOS (targetPlatform dflags) pflags = mkParserOpts (warningFlags dflags) (extensionFlags dflags) (mkPlainMsgEnvelope dflags) + (supportedLanguagesAndExtensions arch_os) (safeImportsOn dflags) False -- lex Haddocks as comment tokens True -- produce comment tokens diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 2486c752..2e9b2f7e 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -56,7 +56,7 @@ import qualified Data.Set as Set import GHC hiding (verbosity) import GHC.Data.FastString (unpackFS) import GHC.Data.Graph.Directed (flattenSCCs) -import GHC.Driver.Env (hsc_dflags, hsc_home_unit, hsc_logger, hsc_static_plugins, hsc_units) +import GHC.Driver.Env (hscUpdateFlags, hsc_home_unit, hsc_logger, hsc_static_plugins, hsc_units) import GHC.Driver.Monad (modifySession, withTimingM) import GHC.Driver.Session hiding (verbosity) import GHC.HsToCore.Docs (getMainDeclBinder) @@ -145,11 +145,8 @@ createIfaces verbosity modules flags instIfaceMap = do let installHaddockPlugin :: HscEnv -> HscEnv - installHaddockPlugin hsc_env = hsc_env - { - hsc_dflags = - gopt_set (hsc_dflags hsc_env) Opt_PluginTrustworthy - , hsc_static_plugins = + installHaddockPlugin hsc_env = hscUpdateFlags (flip gopt_set Opt_PluginTrustworthy) $ hsc_env + { hsc_static_plugins = haddockPlugin : hsc_static_plugins hsc_env } @@ -212,7 +209,7 @@ plugin verbosity flags instIfaceMap = liftIO $ do | otherwise = do hsc_env <- getTopEnv ifaces <- liftIO $ readIORef ifaceMapRef - (iface, modules) <- withTiming (hsc_logger hsc_env) (hsc_dflags hsc_env) + (iface, modules) <- withTiming (hsc_logger hsc_env) "processModule" (const ()) $ processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env @@ -266,9 +263,8 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env (!interface, messages) <- do logger <- getLogger - dflags <- getDynFlags {-# SCC createInterface #-} - withTiming logger dflags "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $ + withTiming logger "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $ createInterface1 flags unit_state mod_summary tc_gbl_env ifaces inst_ifaces diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs index ab2fa549..53cf98ad 100644 --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -19,7 +19,7 @@ import Documentation.Haddock.Types import Haddock.Types import GHC.Driver.Session ( DynFlags ) -import GHC.Driver.Config +import GHC.Driver.Config.Parser (initParserOpts) import GHC.Data.FastString ( fsLit ) import GHC.Parser.Lexer ( initParserState, unP, ParseResult(POk, PFailed) ) import GHC.Parser ( parseIdentifier ) |