From ca90e10eab9c938f211ce5e83ae0e8c15222a958 Mon Sep 17 00:00:00 2001 From: David Waern Date: Fri, 2 Jan 2009 21:38:27 +0000 Subject: Show re-exported names from external packages again This fixes GHC ticket 2746. In order to also link to the exported subordinate names of a declaration, we need to re-introduce the sub map in the .haddock files. --- src/Haddock/Backends/Html.hs | 6 ++--- src/Haddock/Interface.hs | 50 ++++++++++++++++++++++++----------------- src/Haddock/Interface/Create.hs | 45 +++++++++++++++++++++++++++++-------- src/Haddock/Interface/Rename.hs | 6 ++--- src/Haddock/InterfaceFile.hs | 8 +++++-- src/Haddock/Types.hs | 14 ++++++------ src/Main.hs | 11 ++++----- 7 files changed, 89 insertions(+), 51 deletions(-) (limited to 'src') 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 -- cgit v1.2.3