aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface.hs
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Interface.hs')
-rw-r--r--haddock-api/src/Haddock/Interface.hs23
1 files changed, 15 insertions, 8 deletions
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index cbdf81cb..a66745ea 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,8 +184,10 @@ 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
- liftIO $ mapM_ putStrLn msg
+ (interface, msgs) <- {-# SCC createIterface #-}
+ withTiming getDynFlags "createInterface" (const ()) $ do
+ runWriterGhc $ createInterface tm flags modMap instIfaceMap
+ liftIO $ mapM_ putStrLn (nub msgs)
dflags <- getDynFlags
let (haddockable, haddocked) = ifaceHaddockCoverage interface
percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int