[Add source entity path to --read-interface David Waern **20100829130328 Ignore-this: f6475c9222657e7e7337844e9f0848e9 You can now use this flag like this: --read-interface=,,<.haddock file> By "source entity path" I mean the same thing that is specified with the --source-entity flag. The purpose of this is to be able to specify the source entity path per package, to allow source links to work in the presence of cross-package documentation. When given two arguments or less the --read-interface flag behaves as before. ] { hunk ./src/Haddock/Backends/Xhtml/Layout.hs 45 +import qualified Data.Map as Map hunk ./src/Haddock/Backends/Xhtml/Layout.hs 179 -topDeclElem ((_,_,maybe_source_url), (_,_,maybe_wiki_url)) loc name html = +topDeclElem ((_,_,sourceMap), (_,_,maybe_wiki_url)) loc name html = hunk ./src/Haddock/Backends/Xhtml/Layout.hs 182 - case maybe_source_url of + case Map.lookup origPkg sourceMap of hunk ./src/Haddock/Backends/Xhtml/Layout.hs 200 + origPkg = modulePackageId origMod hunk ./src/Haddock/Backends/Xhtml/Types.hs 19 +import Data.Map +import GHC + + hunk ./src/Haddock/Backends/Xhtml/Types.hs 24 -type SourceURLs = (Maybe String, Maybe String, Maybe String) -type WikiURLs = (Maybe String, Maybe String, Maybe String) +type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageId FilePath) +type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) hunk ./src/Haddock/Backends/Xhtml/Types.hs 28 --- The URL for source and wiki links, and the current module +-- The URL for source and wiki links hunk ./src/Haddock/GhcUtils.hs 43 -moduleString = moduleNameString . moduleName - - --- return the name of the package, with version info -modulePackageString :: Module -> String -modulePackageString = packageIdString . modulePackageId +moduleString = moduleNameString . moduleName hunk ./src/Haddock/InterfaceFile.hs 15 - InterfaceFile(..), + InterfaceFile(..), ifPackageId, hunk ./src/Haddock/InterfaceFile.hs 49 +ifPackageId :: InterfaceFile -> PackageId +ifPackageId if_ = + case ifInstalledIfaces if_ of + [] -> error "empty InterfaceFile" + iface:_ -> modulePackageId $ instMod iface + + hunk ./src/Haddock/Options.hs 29 - ifacePairs + ifaceTriples hunk ./src/Haddock/Options.hs 233 -ifacePairs :: [Flag] -> [(FilePath, FilePath)] -ifacePairs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ] +ifaceTriples :: [Flag] -> [(DocPaths, FilePath)] +ifaceTriples flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ] hunk ./src/Haddock/Options.hs 236 - parseIfaceOption :: String -> (FilePath, FilePath) + parseIfaceOption :: String -> (DocPaths, FilePath) hunk ./src/Haddock/Options.hs 239 - (fpath, ',':file) -> (fpath, file) - (file, _) -> ("", file) + (fpath, ',':rest) -> + case break (==',') rest of + (src, ',':file) -> ((fpath, Just src), file) + (file, _) -> ((fpath, Nothing), file) + (file, _) -> (("", Nothing), file) hunk ./src/Haddock/Types.hs 40 +type SrcMap = Map PackageId FilePath hunk ./src/Haddock/Types.hs 43 +type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources hunk ./src/Main.hs 61 +import Module hunk ./src/Main.hs 144 - packages <- readInterfaceFiles freshNameCache (ifacePairs flags) + packages <- readInterfaceFiles freshNameCache (ifaceTriples flags) hunk ./src/Main.hs 150 -readPackagesAndProcessModules :: [Flag] -> [String] -> IO ([(InterfaceFile, FilePath)], - [Interface], LinkEnv) +readPackagesAndProcessModules :: [Flag] -> [String] + -> IO ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) hunk ./src/Main.hs 164 - packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags) + packages <- readInterfaceFiles nameCacheFromGhc (ifaceTriples flags) hunk ./src/Main.hs 167 - let ifaceFiles = map fst packages + let ifaceFiles = map snd packages hunk ./src/Main.hs 173 -renderStep :: [Flag] -> [(InterfaceFile, FilePath)] -> [Interface] -> IO () -renderStep flags packages interfaces = do - updateHTMLXRefs packages - let ifaceFiles = map fst packages - installedIfaces = concatMap ifInstalledIfaces ifaceFiles - render flags interfaces installedIfaces +renderStep :: [Flag] -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () +renderStep flags pkgs interfaces = do + updateHTMLXRefs pkgs + let + ifaceFiles = map snd pkgs + installedIfaces = concatMap ifInstalledIfaces ifaceFiles + srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ] + render flags interfaces installedIfaces srcMap hunk ./src/Main.hs 184 -render :: [Flag] -> [Interface] -> [InstalledInterface] -> IO () -render flags ifaces installedIfaces = do +render :: [Flag] -> [Interface] -> [InstalledInterface] -> SrcMap -> IO () +render flags ifaces installedIfaces srcMap = do hunk ./src/Main.hs 190 - opt_source_urls = optSourceUrls flags hunk ./src/Main.hs 202 - packageMod = ifaceMod (head ifaces) - packageStr = Just (modulePackageString packageMod) - (pkgName,pkgVer) = modulePackageInfo packageMod + pkgMod = ifaceMod (head ifaces) + pkgId = modulePackageId pkgMod + pkgStr = Just (packageIdString pkgId) + (pkgName,pkgVer) = modulePackageInfo pkgMod + + (src_base, src_module, src_entity) = optSourceUrls flags + srcMap' = maybe srcMap (\path -> Map.insert pkgId path srcMap) src_entity + sourceUrls = (src_base, src_module, srcMap') hunk ./src/Main.hs 216 - ppHtmlIndex odir title packageStr - themes opt_contents_url opt_source_urls opt_wiki_urls + ppHtmlIndex odir title pkgStr + themes opt_contents_url sourceUrls opt_wiki_urls hunk ./src/Main.hs 222 - ppHtmlContents odir title packageStr - themes opt_index_url opt_source_urls opt_wiki_urls + ppHtmlContents odir title pkgStr + themes opt_index_url sourceUrls opt_wiki_urls hunk ./src/Main.hs 228 - ppHtml title packageStr visibleIfaces odir + ppHtml title pkgStr visibleIfaces odir hunk ./src/Main.hs 230 - themes opt_source_urls opt_wiki_urls + themes sourceUrls opt_wiki_urls hunk ./src/Main.hs 239 - ppLaTeX title packageStr visibleIfaces odir prologue opt_latex_style + ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style hunk ./src/Main.hs 249 - -> [(FilePath, FilePath)] -> - m [(InterfaceFile, FilePath)] + -> [(DocPaths, FilePath)] -> + m [(DocPaths, InterfaceFile)] hunk ./src/Main.hs 256 - tryReadIface (html, iface) = do - eIface <- readInterfaceFile name_cache_accessor iface + tryReadIface (paths, file) = do + eIface <- readInterfaceFile name_cache_accessor file hunk ./src/Main.hs 260 - putStrLn ("Warning: Cannot read " ++ iface ++ ":") + putStrLn ("Warning: Cannot read " ++ file ++ ":") hunk ./src/Main.hs 264 - Right f -> return $ Just (f, html) + Right f -> return $ Just (paths, f) hunk ./src/Main.hs 376 -updateHTMLXRefs :: [(InterfaceFile, FilePath)] -> IO () +updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO () hunk ./src/Main.hs 379 - mapping = [ (instMod iface, html) | (ifaces, html) <- packages + mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages }