aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-api/src/Haddock/Interface.hs59
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs11
2 files changed, 42 insertions, 28 deletions
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index a66745ea..c330c5fe 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, OverloadedStrings #-}
+{-# LANGUAGE CPP, OverloadedStrings, BangPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface
@@ -51,6 +51,7 @@ import System.Directory
import System.FilePath
import Text.Printf
+import Module (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet)
import Digraph
import DynFlags hiding (verbosity)
import Exception
@@ -59,7 +60,9 @@ import HscTypes
import FastString (unpackFS)
import MonadUtils (liftIO)
import TcRnTypes (tcg_rdr_env)
-import RdrName (plusGlobalRdrEnv)
+import Name (nameIsFromExternalPackage, nameOccName)
+import OccName (isTcOcc)
+import RdrName (unQualOK, gre_name, globalRdrEnvElts)
import ErrUtils (withTiming)
#if defined(mingw32_HOST_OS)
@@ -87,7 +90,7 @@ processModules verbosity modules flags extIfaces = do
out verbosity verbose "Creating interfaces..."
let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
, iface <- ifInstalledIfaces ext ]
- interfaces <- createIfaces0 verbosity modules flags instIfaceMap
+ (interfaces, ms) <- createIfaces0 verbosity modules flags instIfaceMap
let exportedNames =
Set.unions $ map (Set.fromList . ifaceExports) $
@@ -96,7 +99,7 @@ processModules verbosity modules flags extIfaces = do
out verbosity verbose "Attaching instances..."
interfaces' <- {-# SCC attachInstances #-}
withTiming getDynFlags "attachInstances" (const ()) $ do
- attachInstances (exportedNames, mods) interfaces instIfaceMap
+ attachInstances (exportedNames, mods) interfaces instIfaceMap ms
out verbosity verbose "Building cross-linking environment..."
-- Combine the link envs of the external packages into one
@@ -120,7 +123,7 @@ processModules verbosity modules flags extIfaces = do
--------------------------------------------------------------------------------
-createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
+createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet)
createIfaces0 verbosity modules flags instIfaceMap =
-- 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
@@ -150,43 +153,51 @@ createIfaces0 verbosity modules flags instIfaceMap =
depanal [] False
-createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface]
+createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc ([Interface], ModuleSet)
createIfaces verbosity flags instIfaceMap mods = do
let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing
out verbosity normal "Haddock coverage:"
- (ifaces, _) <- foldM f ([], Map.empty) sortedMods
- return (reverse ifaces)
+ (ifaces, _, !ms) <- foldM f ([], Map.empty, emptyModuleSet) sortedMods
+ return (reverse ifaces, ms)
where
- f (ifaces, ifaceMap) modSummary = do
+ f (ifaces, ifaceMap, !ms) modSummary = do
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.
+ Just (iface, ms') -> ( iface:ifaces
+ , Map.insert (ifaceMod iface) iface ifaceMap
+ , unionModuleSet ms ms' )
+ Nothing -> ( ifaces
+ , ifaceMap
+ , ms ) -- Boot modules don't generate ifaces.
-processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface)
+processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe (Interface, ModuleSet))
processModule verbosity modsum flags modMap instIfaceMap = do
out verbosity verbose $ "Checking module " ++ moduleString (ms_mod 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
- -- encountered while typechecking.
- --
- -- See https://github.com/haskell/haddock/issues/469.
- hsc_env@HscEnv{ hsc_IC = old_IC } <- getSession
- let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm
- setSession hsc_env{ hsc_IC = old_IC {
- ic_rn_gbl_env = ic_rn_gbl_env old_IC `plusGlobalRdrEnv` new_rdr_env
- } }
-
if not $ isBootSummary modsum then do
out verbosity verbose "Creating interface..."
(interface, msgs) <- {-# SCC createIterface #-}
withTiming getDynFlags "createInterface" (const ()) $ do
runWriterGhc $ createInterface tm flags modMap instIfaceMap
+
+ -- We need to keep track of which modules were somehow in scope so that when
+ -- Haddock later looks for instances, it also looks in these modules too.
+ --
+ -- See https://github.com/haskell/haddock/issues/469.
+ hsc_env <- getSession
+ let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm
+ this_pkg = thisPackage (hsc_dflags hsc_env)
+ !mods = mkModuleSet [ nameModule name
+ | gre <- globalRdrEnvElts new_rdr_env
+ , let name = gre_name gre
+ , nameIsFromExternalPackage this_pkg name
+ , isTcOcc (nameOccName name) -- Types and classes only
+ , unQualOK gre ] -- In scope unqualified
+
liftIO $ mapM_ putStrLn (nub msgs)
dflags <- getDynFlags
let (haddockable, haddocked) = ifaceHaddockCoverage interface
@@ -220,7 +231,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do
unless header $ out verbosity normal " Module header"
mapM_ (out verbosity normal . (" " ++)) undocumentedExports
interface' <- liftIO $ evaluate interface
- return (Just interface')
+ return (Just (interface', mods))
else
return Nothing
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index bf50ded3..2d72d117 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, MagicHash #-}
+{-# LANGUAGE CPP, MagicHash, BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
@@ -34,6 +34,7 @@ import FamInstEnv
import FastString
import GHC
import InstEnv
+import Module ( ModuleSet, moduleSetElts )
import MonadUtils (liftIO)
import Name
import NameEnv
@@ -51,11 +52,13 @@ type Modules = Set.Set Module
type ExportInfo = (ExportedNames, Modules)
-- Also attaches fixities
-attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface]
-attachInstances expInfo ifaces instIfaceMap = do
- (_msgs, mb_index) <- getNameToInstancesIndex (map ifaceMod ifaces)
+attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> ModuleSet -> Ghc [Interface]
+attachInstances expInfo ifaces instIfaceMap mods = do
+ (_msgs, mb_index) <- getNameToInstancesIndex (map ifaceMod ifaces) mods'
mapM (attach $ fromMaybe emptyNameEnv mb_index) ifaces
where
+ mods' = Just (moduleSetElts mods)
+
-- TODO: take an IfaceMap as input
ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ]
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 06:26:19 +0000