aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock.hs
diff options
context:
space:
mode:
authorAlec Theriault <alec.theriault@gmail.com>2019-01-31 01:37:25 -0800
committerGitHub <noreply@github.com>2019-01-31 01:37:25 -0800
commit1b26460fb3b5df5215cc1e6715661cbc7c950085 (patch)
tree0b5ac6285ecf432021e8365567d48eeb6249f44b /haddock-api/src/Haddock.hs
parent4c02498a24e6ceb775528bed043b66340296ad06 (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.hs52
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 =