aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-api/src/Haddock.hs59
-rw-r--r--haddock-api/src/Haddock/Interface.hs21
2 files changed, 53 insertions, 27 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 23fefb3b..dc903e08 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -1,5 +1,5 @@
{-# OPTIONS_GHC -Wwarn #-}
-{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types #-}
+{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings, Rank2Types #-}
{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
-- |
@@ -238,8 +238,8 @@ renderStep dflags flags qual pkgs interfaces = do
((_, Just path), ifile) <- pkgs
iface <- ifInstalledIfaces ifile
return (instMod iface, path)
- render dflags flags qual interfaces installedIfaces extSrcMap
+ render dflags flags qual interfaces installedIfaces extSrcMap
-- | Render the interfaces with whatever backend is specified in the flags.
render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO ()
@@ -323,24 +323,34 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
let withQuickjump = Flag_QuickJumpIndex `elem` flags
when (Flag_GenIndex `elem` flags) $ do
- ppHtmlIndex odir title pkgStr
- themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls
- allVisibleIfaces pretty
+ withTiming (pure dflags') "ppHtmlIndex" (const ()) $ do
+ _ <- {-# SCC ppHtmlIndex #-}
+ ppHtmlIndex odir title pkgStr
+ themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls
+ allVisibleIfaces pretty
+ return ()
+
copyHtmlBits odir libDir themes withQuickjump
when (Flag_GenContents `elem` flags) $ do
- ppHtmlContents dflags' odir title pkgStr
- themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
- allVisibleIfaces True prologue pretty
- (makeContentsQual qual)
+ withTiming (pure dflags') "ppHtmlContents" (const ()) $ do
+ _ <- {-# SCC ppHtmlContents #-}
+ ppHtmlContents dflags' odir title pkgStr
+ themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
+ allVisibleIfaces True prologue pretty
+ (makeContentsQual qual)
+ return ()
copyHtmlBits odir libDir themes withQuickjump
when (Flag_Html `elem` flags) $ do
- ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir
- prologue
- themes opt_mathjax sourceUrls' opt_wiki_urls
- opt_contents_url opt_index_url unicode qual
- pretty withQuickjump
+ withTiming (pure dflags') "ppHtml" (const ()) $ do
+ _ <- {-# SCC ppHtml #-}
+ ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir
+ prologue
+ themes opt_mathjax sourceUrls' opt_wiki_urls
+ opt_contents_url opt_index_url unicode qual
+ pretty withQuickjump
+ return ()
copyHtmlBits odir libDir themes withQuickjump
writeHaddockMeta odir withQuickjump
@@ -359,15 +369,24 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
Just (PackageName pkgNameFS, pkgVer) ->
let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title
| otherwise = unpackFS pkgNameFS
- in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue)
- visibleIfaces odir
+ in withTiming (pure dflags') "ppHoogle" (const ()) $ do
+ _ <- {-# SCC ppHoogle #-}
+ ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue)
+ visibleIfaces odir
+ return ()
when (Flag_LaTeX `elem` flags) $ do
- ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style
- libDir
+ withTiming (pure dflags') "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
- ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces
+ withTiming (pure dflags') "ppHyperlinkedSource" (const ()) $ do
+ _ <- {-# SCC ppHyperlinkedSource #-}
+ ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces
+ return ()
-- | From GHC 7.10, this function has a potential to crash with a
-- nasty message such as @expectJust getPackageDetails@ because
@@ -400,7 +419,7 @@ readInterfaceFiles :: MonadIO m
-> [(DocPaths, FilePath)]
-> m [(DocPaths, InterfaceFile)]
readInterfaceFiles name_cache_accessor pairs = do
- catMaybes `liftM` mapM tryReadIface pairs
+ catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs
where
-- try to read an interface, warn if we can't
tryReadIface (paths, file) =
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index cbdf81cb..89064a6c 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface
@@ -60,6 +60,7 @@ import FastString (unpackFS)
import MonadUtils (liftIO)
import TcRnTypes (tcg_rdr_env)
import RdrName (plusGlobalRdrEnv)
+import ErrUtils (withTiming)
#if defined(mingw32_HOST_OS)
import System.IO
@@ -93,13 +94,15 @@ processModules verbosity modules flags extIfaces = do
filter (\i -> not $ OptHide `elem` ifaceOptions i) interfaces
mods = Set.fromList $ map ifaceMod interfaces
out verbosity verbose "Attaching instances..."
- interfaces' <- attachInstances (exportedNames, mods) interfaces instIfaceMap
+ interfaces' <- {-# SCC attachInstances #-}
+ withTiming getDynFlags "attachInstances" (const ()) $ do
+ attachInstances (exportedNames, mods) interfaces instIfaceMap
out verbosity verbose "Building cross-linking environment..."
-- Combine the link envs of the external packages into one
let extLinks = Map.unions (map ifLinkEnv extIfaces)
- homeLinks = buildHomeLinks interfaces -- Build the environment for the home
- -- package
+ homeLinks = buildHomeLinks interfaces' -- Build the environment for the home
+ -- package
links = homeLinks `Map.union` extLinks
out verbosity verbose "Renaming interfaces..."
@@ -155,7 +158,9 @@ createIfaces verbosity flags instIfaceMap mods = do
return (reverse ifaces)
where
f (ifaces, ifaceMap) modSummary = do
- x <- processModule verbosity modSummary flags ifaceMap instIfaceMap
+ x <- {-# SCC processModule #-}
+ withTiming getDynFlags "processModule" (const ()) $ do
+ processModule verbosity modSummary flags ifaceMap instIfaceMap
return $ case x of
Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap)
Nothing -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces.
@@ -164,7 +169,7 @@ createIfaces verbosity flags instIfaceMap mods = do
processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface)
processModule verbosity modsum flags modMap instIfaceMap = do
out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
- tm <- loadModule =<< typecheckModule =<< parseModule modsum
+ tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum
-- We need to modify the interactive context's environment so that when
-- Haddock later looks for instances, it also looks in the modules it
@@ -179,7 +184,9 @@ processModule verbosity modsum flags modMap instIfaceMap = do
if not $ isBootSummary modsum then do
out verbosity verbose "Creating interface..."
- (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap
+ (interface, msg) <- {-# SCC createIterface #-}
+ withTiming getDynFlags "createInterface" (const ()) $ do
+ runWriterGhc $ createInterface tm flags modMap instIfaceMap
liftIO $ mapM_ putStrLn msg
dflags <- getDynFlags
let (haddockable, haddocked) = ifaceHaddockCoverage interface
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 09:52:47 +0000