diff options
author | Alec Theriault <alec.theriault@gmail.com> | 2019-01-31 01:37:25 -0800 |
---|---|---|
committer | GitHub <noreply@github.com> | 2019-01-31 01:37:25 -0800 |
commit | 1b26460fb3b5df5215cc1e6715661cbc7c950085 (patch) | |
tree | 0b5ac6285ecf432021e8365567d48eeb6249f44b /haddock-api/src/Haddock.hs | |
parent | 4c02498a24e6ceb775528bed043b66340296ad06 (diff) |
Use `.hie` files for the Hyperlinker backend (#977)
# Summary
This is a large architectural change to the Hyperlinker.
* extract link (and now also type) information from `.hie` instead
of doing ad-hoc SYB traversals of the `RenamedSource`. Also
adds a superb type-on-hover feature (#715).
* re-engineer the lexer to avoid needless string conversions. By going
directly through GHC's `P` monad and taking bytestring slices, we
avoid a ton of allocation and have better handling of position
pragmas and CPP.
In terms of performance, the Haddock side of things has gotten _much_
more efficient. Unfortunately, much of this is cancelled out by the
increased GHC workload for generating `.hie` files. For the full set of
boot libs (including `ghc`-the-library)
* the sum of total time went down by 9-10% overall
* the sum of total allocations went down by 6-7%
# Motivation
Haddock is moving towards working entirely over `.hi` and `.hie` files.
This change means we no longer need the `RenamedSource` from
`TypecheckedModule` (something which is _not_ in `.hi` files).
# Details
Along the way a bunch of things were fixed:
* Cross package (and other) links are now more reliable (#496)
* The lexer tries to recover from errors on every line (instead of at CPP
boundaries)
* `LINE`/`COLUMN` pragmas are taken into account
* filter out zero length tokens before rendering
* avoid recomputing the `ModuleName`-based `SrcMap`
* remove the last use of `Documentation.Haddock.Utf8` (see #998)
* restructure temporary folder logic for `.hi`/`.hie` model
Diffstat (limited to 'haddock-api/src/Haddock.hs')
-rw-r--r-- | haddock-api/src/Haddock.hs | 52 |
1 files changed, 39 insertions, 13 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 2bae60e7..358e5c3a 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -39,6 +39,7 @@ import Haddock.Version import Haddock.InterfaceFile import Haddock.Options import Haddock.Utils +import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir) import Control.Monad hiding (forM_) import Data.Foldable (forM_, foldl') @@ -66,6 +67,8 @@ import qualified GHC.Paths as GhcPaths import Paths_haddock_api (getDataDir) import System.Directory (doesDirectoryExist) #endif +import System.Directory (getTemporaryDirectory) +import System.FilePath ((</>)) import Text.ParserCombinators.ReadP (readP_to_S) import GHC hiding (verbosity) @@ -164,6 +167,15 @@ haddockWithGhc ghc args = handleTopExceptions $ do -- bypass the interface version check let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags + -- Create a temporary directory and redirect GHC output there (unless user + -- requested otherwise). + -- + -- Output dir needs to be set before calling 'depanal' since 'depanal' uses it + -- to compute output file names that are stored in the 'DynFlags' of the + -- resulting 'ModSummary's. + let withDir | Flag_NoTmpCompDir `elem` flags = id + | otherwise = withTempOutputDir + unless (Flag_NoWarnings `elem` flags) $ do hypSrcWarnings flags forM_ (warnings args) $ \warning -> do @@ -171,7 +183,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do when noChecks $ hPutStrLn stderr noCheckWarning - ghc flags' $ do + ghc flags' $ withDir $ do dflags <- getDynFlags forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do @@ -202,6 +214,15 @@ haddockWithGhc ghc args = handleTopExceptions $ do -- Render even though there are no input files (usually contents/index). liftIO $ renderStep dflags flags sinceQual qual packages [] +-- | Run the GHC action using a temporary output directory +withTempOutputDir :: Ghc a -> Ghc a +withTempOutputDir action = do + tmp <- liftIO getTemporaryDirectory + x <- liftIO getProcessID + let dir = tmp </> ".haddock-" ++ show x + modifySessionDynFlags (setOutputDir dir) + withTempDir dir action + -- | Create warnings about potential misuse of -optghc warnings :: [String] -> [String] warnings = map format . filter (isPrefixOf "-optghc") @@ -221,8 +242,9 @@ withGhc flags action = do let handleSrcErrors action' = flip handleSourceError action' $ \err -> do printException err liftIO exitFailure + needHieFiles = Flag_HyperlinkedSource `elem` flags - withGhc' libDir (ghcFlags flags) (\_ -> handleSrcErrors action) + withGhc' libDir needHieFiles (ghcFlags flags) (\_ -> handleSrcErrors action) readPackagesAndProcessModules :: [Flag] -> [String] @@ -444,14 +466,10 @@ readInterfaceFiles name_cache_accessor pairs bypass_version_check = do -- | Start a GHC session with the -haddock flag set. Also turn off -- compilation and linking. Then run the given 'Ghc' action. -withGhc' :: String -> [String] -> (DynFlags -> Ghc a) -> IO a -withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do - dynflags <- getSessionDynFlags - dynflags' <- parseGhcFlags (gopt_set dynflags Opt_Haddock) { - hscTarget = HscNothing, - ghcMode = CompManager, - ghcLink = NoLink - } +withGhc' :: String -> Bool -> [String] -> (DynFlags -> Ghc a) -> IO a +withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do + dynflags' <- parseGhcFlags =<< getSessionDynFlags + -- We disable pattern match warnings because than can be very -- expensive to check let dynflags'' = unsetPatternMatchWarnings $ @@ -482,11 +500,19 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do parseGhcFlags dynflags = do -- TODO: handle warnings? - let flags' = filterRtsFlags flags - (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags') + let extra_opts | needHieFiles = [Opt_WriteHie, Opt_Haddock] + | otherwise = [Opt_Haddock] + dynflags' = (foldl' gopt_set dynflags extra_opts) + { hscTarget = HscNothing + , ghcMode = CompManager + , ghcLink = NoLink + } + flags' = filterRtsFlags flags + + (dynflags'', rest, _) <- parseDynamicFlags dynflags' (map noLoc flags') if not (null rest) then throwE ("Couldn't parse GHC options: " ++ unwords flags') - else return dynflags' + else return dynflags'' unsetPatternMatchWarnings :: DynFlags -> DynFlags unsetPatternMatchWarnings dflags = |