aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Haddock/Backends/Html.hs6
-rw-r--r--src/Haddock/Interface.hs50
-rw-r--r--src/Haddock/Interface/Create.hs45
-rw-r--r--src/Haddock/Interface/Rename.hs6
-rw-r--r--src/Haddock/InterfaceFile.hs8
-rw-r--r--src/Haddock/Types.hs14
-rw-r--r--src/Main.hs11
7 files changed, 89 insertions, 51 deletions
diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index e93cb1e2..4044e9ef 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -609,7 +609,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface
exports = numberSectionHeadings (ifaceRnExportItems iface)
has_doc (ExportDecl _ doc _ _) = isJust doc
- has_doc (ExportNoDecl _ _ _) = False
+ has_doc (ExportNoDecl _ _) = False
has_doc (ExportModule _) = False
has_doc _ = True
@@ -733,9 +733,9 @@ processExport _ _ _ (ExportGroup lev id0 doc)
= ppDocGroup lev (namedAnchor id0 << docToHtml doc)
processExport summary links docMap (ExportDecl decl doc subdocs insts)
= ppDecl summary links decl doc insts docMap subdocs
-processExport summmary _ _ (ExportNoDecl _ y [])
+processExport summmary _ _ (ExportNoDecl y [])
= declBox (ppDocName y)
-processExport summmary _ _ (ExportNoDecl _ y subs)
+processExport summmary _ _ (ExportNoDecl y subs)
= declBox (ppDocName y <+> parenList (map ppDocName subs))
processExport _ _ _ (ExportDoc doc)
= docBox (docToHtml doc)
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index c8c03413..448d54e9 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -24,6 +24,7 @@ import Haddock.GHC.Utils
import Haddock.GHC.Typecheck
import Haddock.Exception
import Haddock.Utils
+import Haddock.InterfaceFile
import qualified Data.Map as Map
import Data.Map (Map)
@@ -42,19 +43,28 @@ import SrcLoc
-- | Turn a topologically sorted list of module names/filenames into interfaces. Also
-- return the home link environment created in the process.
#if __GLASGOW_HASKELL__ >= 609
-createInterfaces :: [String] -> LinkEnv -> [Flag] -> Ghc ([Interface], LinkEnv)
-createInterfaces modules externalLinks flags = do
+createInterfaces :: [String] -> [Flag] -> [InterfaceFile]
+ -> Ghc ([Interface], LinkEnv)
+createInterfaces modules flags extIfaces = do
-- part 1, create interfaces
- interfaces <- createInterfaces' modules flags
+ let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
+ , iface <- ifInstalledIfaces ext ]
+ interfaces <- createInterfaces' modules flags instIfaceMap
#else
-createInterfaces :: Session -> [String] -> LinkEnv -> [Flag] -> IO ([Interface], LinkEnv)
-createInterfaces session modules externalLinks flags = do
+createInterfaces :: Session -> [String] -> [Flag]
+ -> [InterfaceFile] -> IO ([Interface], LinkEnv)
+createInterfaces session modules flags extIfaces = do
-- part 1, create interfaces
- interfaces <- createInterfaces' session modules flags
+ let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
+ , iface <- ifInstalledIfaces ext ]
+ interfaces <- createInterfaces' session modules flags instIfaceMap
#endif
-- part 2, build link environment
- let homeLinks = buildHomeLinks interfaces
- links = homeLinks `Map.union` externalLinks
+ -- 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
+ links = homeLinks `Map.union` extLinks
allNames = Map.keys links
-- part 3, attach instances
@@ -70,17 +80,17 @@ createInterfaces session modules externalLinks flags = do
#if __GLASGOW_HASKELL__ >= 609
-createInterfaces' :: [String] -> [Flag] -> Ghc [Interface]
-createInterfaces' modules flags = do
+createInterfaces' :: [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
+createInterfaces' modules flags instIfaceMap = do
targets <- mapM (\f -> guessTarget f Nothing) modules
setTargets targets
modgraph <- depanal [] False
let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
(ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
- interface <- processModule modsum flags modMap
+ interface <- processModule modsum flags modMap instIfaceMap
#else
-createInterfaces' :: Session -> [String] -> [Flag] -> IO [Interface]
-createInterfaces' session modules flags = do
+createInterfaces' :: Session -> [String] -> [Flag] -> InstIfaceMap -> IO [Interface]
+createInterfaces' session modules flags instIfaceMap = do
targets <- mapM (\f -> guessTarget f Nothing) modules
setTargets session targets
mbGraph <- depanal session [] False
@@ -89,7 +99,7 @@ createInterfaces' session modules flags = do
Nothing -> throwE "Failed to create dependecy graph"
let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
(ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
- interface <- processModule session modsum flags modMap
+ interface <- processModule session modsum flags modMap instIfaceMap
#endif
return $ (interface : ifaces , Map.insert (ifaceMod interface) interface modMap)
) ([], Map.empty) orderedMods
@@ -128,8 +138,8 @@ ppModInfo (HaddockModInfo a b c d) = show (fmap pretty a) ++ show b ++ show c ++
-}
#if __GLASGOW_HASKELL__ >= 609
-processModule :: ModSummary -> [Flag] -> ModuleMap -> Ghc Interface
-processModule modsum flags modMap =
+processModule :: ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> Ghc Interface
+processModule modsum flags modMap instIfaceMap =
let handleSrcErrors action = flip handleSourceError action $ \err -> do
printExceptionAndWarnings err
@@ -147,20 +157,20 @@ processModule modsum flags modMap =
typecheckedSource tc_mod,
moduleInfo tc_mod))
dynflags
- let (interface, msg) = runWriter $ createInterface ghcMod flags modMap
+ let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap
liftIO $ mapM_ putStrLn msg
liftIO $ evaluate interface
return interface
#else
-processModule :: Session -> ModSummary -> [Flag] -> ModuleMap -> IO Interface
-processModule session modsum flags modMap = do
+processModule :: Session -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> IO Interface
+processModule session modsum flags modMap instIfaceMap = do
let filename = msHsFilePath modsum
mbMod <- checkAndLoadModule session modsum False
ghcMod <- case mbMod of
Just (CheckedModule a (Just b) (Just c) (Just d) _)
-> return $ mkGhcModule (ms_mod modsum, filename, (a,b,c,d)) (ms_hspp_opts modsum)
_ -> throwE ("Failed to check module: " ++ (moduleString $ ms_mod modsum))
- let (interface, msg) = runWriter $ createInterface ghcMod flags modMap
+ let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap
mapM_ putStrLn msg
return interface
#endif
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index a5bbff3c..7a958504 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -40,8 +40,9 @@ import HscTypes
-- | Process the data in the GhcModule to produce an interface.
-- To do this, we need access to already processed modules in the topological
-- sort. That's what's in the module map.
-createInterface :: GhcModule -> [Flag] -> ModuleMap -> ErrMsgM Interface
-createInterface ghcMod flags modMap = do
+createInterface :: GhcModule -> [Flag] -> ModuleMap -> InstIfaceMap
+ -> ErrMsgM Interface
+createInterface ghcMod flags modMap instIfaceMap = do
let mod = ghcModule ghcMod
@@ -63,9 +64,9 @@ createInterface ghcMod flags modMap = do
warnAboutFilteredDecls mod decls0
exportItems <- mkExportItems modMap mod (ghcExportedNames ghcMod) decls declMap
- opts exports ignoreExps instances
+ opts exports ignoreExps instances instIfaceMap
- let visibleNames = mkVisibleNames exportItems
+ let visibleNames = mkVisibleNames exportItems opts
-- prune the export list to just those declarations that have
-- documentation, if the 'prune' option is on.
@@ -88,6 +89,7 @@ createInterface ghcMod flags modMap = do
ifaceExports = exportedNames,
ifaceVisibleExports = visibleNames,
ifaceDeclMap = declMap,
+ ifaceSubMap = mkSubMap declMap exportedNames,
ifaceInstances = ghcInstances ghcMod
}
@@ -123,6 +125,14 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
-- Declarations
--------------------------------------------------------------------------------
+-- | Make a sub map from a declaration map. Make sure we only include exported
+-- names.
+mkSubMap :: Map Name DeclInfo -> [Name] -> Map Name [Name]
+mkSubMap declMap exports =
+ Map.filterWithKey (\k _ -> k `elem` exports) (Map.map filterSubs declMap)
+ where
+ filterSubs (_, _, subs) = [ sub | (sub, _) <- subs, sub `elem` exports ]
+
-- Make a map from names to 'DeclInfo's. Exclude declarations that don't
-- have names (instances and stand-alone documentation comments). Include
@@ -322,6 +332,9 @@ attachATs exports =
-- | Build the list of items that will become the documentation, from the
-- export list. At this point, the list of ExportItems is in terms of
-- original names.
+--
+-- We create the export items even if the module is hidden, since they
+-- might be useful when creating the export items for other modules.
mkExportItems
:: ModuleMap
-> Module -- this module
@@ -332,10 +345,11 @@ mkExportItems
-> Maybe [IE Name]
-> Bool -- --ignore-all-exports flag
-> [Instance]
+ -> InstIfaceMap
-> ErrMsgM [ExportItem Name]
mkExportItems modMap this_mod exported_names decls declMap
- opts maybe_exps ignore_all_exports instances
+ opts maybe_exps ignore_all_exports instances instIfaceMap
| isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts
= everything_local_exported
| Just specs <- maybe_exps = liftM concat $ mapM lookupExport specs
@@ -373,7 +387,17 @@ mkExportItems modMap this_mod exported_names decls declMap
-- name out in mkVisibleNames...
| Just x@(decl,_,_) <- findDecl t,
t `notElem` declATs (unL decl) = return [ mkExportDecl t x ]
- | otherwise = return []
+ | otherwise =
+ -- If we can't find the declaration, it must belong to another package.
+ -- We return an 'ExportNoDecl', and we try to get the subs from the
+ -- installed interface of that package.
+ case Map.lookup (nameModule t) instIfaceMap of
+ Nothing -> return [ ExportNoDecl t [] ]
+ Just iface ->
+ let subs = case Map.lookup t (instSubMap iface) of
+ Nothing -> []
+ Just x -> x
+ in return [ ExportNoDecl t subs ]
mkExportDecl :: Name -> DeclInfo -> ExportItem Name
mkExportDecl n (decl, doc, subs) = decl'
@@ -481,15 +505,18 @@ pruneExportItems items = filter hasDoc items
hasDoc _ = True
-mkVisibleNames :: [ExportItem Name] -> [Name]
-mkVisibleNames exports = concatMap exportName exports
+mkVisibleNames :: [ExportItem Name] -> [DocOption] -> [Name]
+mkVisibleNames exports opts
+ | OptHide `elem` opts = []
+ | otherwise = concatMap exportName exports
where
exportName e@ExportDecl {} =
case getMainDeclBinder $ unL $ expItemDecl e of
Just n -> n : subs
Nothing -> subs
where subs = map fst (expItemSubDocs e)
- exportName e@ExportNoDecl {} = expItemName e : expItemSubs e
+ exportName e@ExportNoDecl {} = [] -- we don't count these as visible, since
+ -- we don't want links to go to them.
exportName _ = []
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 3eb52d8f..3e4f6fbc 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -405,10 +405,10 @@ renameExportItem item = case item of
subs' <- mapM renameSub subs
instances' <- mapM renameInstHead instances
return (ExportDecl decl' doc' subs' instances')
- ExportNoDecl x y subs -> do
- y' <- lookupRn id y
+ ExportNoDecl x subs -> do
+ x' <- lookupRn id x
subs' <- mapM (lookupRn id) subs
- return (ExportNoDecl x y' subs')
+ return (ExportNoDecl x' subs')
ExportDoc doc -> do
doc' <- renameDoc doc
return (ExportDoc doc')
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index e04e5b3e..0daa21aa 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -353,13 +353,14 @@ instance Binary InterfaceFile where
instance Binary InstalledInterface where
- put_ bh (InstalledInterface modu info docMap exps visExps opts) = do
+ put_ bh (InstalledInterface modu info docMap exps visExps opts subMap) = do
put_ bh modu
put_ bh info
put_ bh (Map.toList docMap)
put_ bh exps
put_ bh visExps
put_ bh opts
+ put_ bh (Map.toList subMap)
get bh = do
modu <- get bh
@@ -368,7 +369,10 @@ instance Binary InstalledInterface where
exps <- get bh
visExps <- get bh
opts <- get bh
- return (InstalledInterface modu info (Map.fromList docMap) exps visExps opts)
+ subMap <- get bh
+
+ return (InstalledInterface modu info (Map.fromList docMap)
+ exps visExps opts (Map.fromList subMap))
instance Binary DocOption where
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index c10cfee7..b47444b7 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -56,11 +56,7 @@ data ExportItem name
} -- ^ An exported declaration
| ExportNoDecl {
- -- | The original name
- expItemName :: Name,
-
- -- | Where to link to
- expItemLinkTarget :: name,
+ expItemName :: name,
-- | Subordinate names
expItemSubs :: [name]
@@ -89,6 +85,7 @@ data ExportItem name
type InstHead name = ([HsPred name], name, [HsType name])
type ModuleMap = Map Module Interface
+type InstIfaceMap = Map Module InstalledInterface
type DocMap = Map Name (HsDoc DocName)
type LinkEnv = Map Name Module
@@ -136,6 +133,7 @@ data Interface = Interface {
ifaceDeclMap :: Map Name DeclInfo,
ifaceRnDocMap :: Map Name (HsDoc DocName),
+ ifaceSubMap :: Map Name [Name],
ifaceExportItems :: ![ExportItem Name],
ifaceRnExportItems :: [ExportItem DocName],
@@ -168,7 +166,8 @@ data InstalledInterface = InstalledInterface {
instDocMap :: Map Name (HsDoc DocName),
instExports :: [Name],
instVisibleExports :: [Name],
- instOptions :: [DocOption]
+ instOptions :: [DocOption],
+ instSubMap :: Map Name [Name]
}
@@ -180,7 +179,8 @@ toInstalledIface interface = InstalledInterface {
instDocMap = ifaceRnDocMap interface,
instExports = ifaceExports interface,
instVisibleExports = ifaceVisibleExports interface,
- instOptions = ifaceOptions interface
+ instOptions = ifaceOptions interface,
+ instSubMap = ifaceSubMap interface
}
diff --git a/src/Main.hs b/src/Main.hs
index 686e9237..328fce4d 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -166,11 +166,10 @@ main = handleTopExceptions $ do
-- get packages supplied with --read-interface
packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags)
- -- combine the link envs of the external packages into one
- let extLinks = Map.unions (map (ifLinkEnv . fst) packages)
-- create the interfaces -- this is the core part of Haddock
- (interfaces, homeLinks) <- createInterfaces fileArgs extLinks flags
+ (interfaces, homeLinks) <- createInterfaces fileArgs flags
+ (map fst packages)
liftIO $ do
-- render the interfaces
@@ -185,11 +184,9 @@ main = handleTopExceptions $ do
-- get packages supplied with --read-interface
packages <- readInterfaceFiles (nameCacheFromGhc session) (ifacePairs flags)
- -- combine the link envs of the external packages into one
- let extLinks = Map.unions (map (ifLinkEnv . fst) packages)
-
-- create the interfaces -- this is the core part of Haddock
- (interfaces, homeLinks) <- createInterfaces session fileArgs extLinks flags
+ (interfaces, homeLinks) <- createInterfaces session fileArgs flags
+ (map fst packages)
-- render the interfaces
renderStep packages interfaces
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 22:40:16 +0000