Add source entity path to --read-interface

You can now use this flag like this: --read-interface=<html path>,<source entity path>,<.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.
author: David Waern <david.waern@gmail.com> 2010-08-29 13:03:28 +0000
committer: David Waern <david.waern@gmail.com> 2010-08-29 13:03:28 +0000
commit: d5ec98534422eba93298bb8a76e6b315a55c3158 (patch)
tree: 72a4c3e98b60199e4bf1808878a81d441fa9b84c /src
parent: a01b2ef92f9164734d6673b1f3e01cde8da477c8 (diff)
7 files changed, 70 insertions, 50 deletions
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index 5ffdf181..295af305 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -42,6 +42,7 @@ import Haddock.Backends.Xhtml.Utils
 import Haddock.Types
 import Haddock.Utils (makeAnchorId)
 
+import qualified Data.Map as Map
 import Text.XHtml hiding ( name, title, p, quote )
 
 import FastString            ( unpackFS )
@@ -175,10 +176,10 @@ declElem = paragraph ! [theclass "src"]
 -- a box for top level documented names
 -- it adds a source and wiki link at the right hand side of the box
 topDeclElem :: LinksInfo -> SrcSpan -> DocName -> Html -> Html
-topDeclElem ((_,_,maybe_source_url), (_,_,maybe_wiki_url)) loc name html =
+topDeclElem ((_,_,sourceMap), (_,_,maybe_wiki_url)) loc name html =
     declElem << (html +++ srcLink +++ wikiLink)
   where srcLink =
-          case maybe_source_url of
+          case Map.lookup origPkg sourceMap of
             Nothing  -> noHtml
             Just url -> let url' = spliceURL (Just fname) (Just origMod)
                                                (Just n) (Just loc) url
@@ -196,6 +197,7 @@ topDeclElem ((_,_,maybe_source_url), (_,_,maybe_wiki_url)) loc name html =
         -- TODO: do something about type instances. They will point to
         -- the module defining the type family, which is wrong.
         origMod = nameModule n
+        origPkg = modulePackageId origMod
 
         -- Name must be documented, otherwise we wouldn't get here
         Documented n mdl = name
diff --git a/src/Haddock/Backends/Xhtml/Types.hs b/src/Haddock/Backends/Xhtml/Types.hs
index 4e23f469..7bff0eb1 100644
--- a/src/Haddock/Backends/Xhtml/Types.hs
+++ b/src/Haddock/Backends/Xhtml/Types.hs
@@ -16,10 +16,14 @@ module Haddock.Backends.Xhtml.Types (
 ) where
 
 
+import Data.Map
+import GHC
+
+
 -- the base, module and entity URLs for the source code and wiki links.
-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)
 
 
--- The URL for source and wiki links, and the current module
+-- The URL for source and wiki links
 type LinksInfo = (SourceURLs, WikiURLs)
diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs
index d8525532..c0911f70 100644
--- a/src/Haddock/GhcUtils.hs
+++ b/src/Haddock/GhcUtils.hs
@@ -40,12 +40,7 @@ import GHC
 
 
 moduleString :: Module -> String
-moduleString = moduleNameString . moduleName 
-
-
--- return the name of the package, with version info
-modulePackageString :: Module -> String
-modulePackageString = packageIdString . modulePackageId
+moduleString = moduleNameString . moduleName
 
 
 -- return the (name,version) of the package
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 5fe47b72..1df9cd12 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -12,7 +12,7 @@
 -- Reading and writing the .haddock interface file
 -----------------------------------------------------------------------------
 module Haddock.InterfaceFile (
-  InterfaceFile(..),
+  InterfaceFile(..), ifPackageId,
   readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor,
   writeInterfaceFile
 ) where
@@ -46,6 +46,13 @@ data InterfaceFile = InterfaceFile {
 }
 
 
+ifPackageId :: InterfaceFile -> PackageId
+ifPackageId if_ =
+  case ifInstalledIfaces if_ of
+    [] -> error "empty InterfaceFile"
+    iface:_ -> modulePackageId $ instMod iface
+
+
 binaryInterfaceMagic :: Word32
 binaryInterfaceMagic = 0xD0Cface
 
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index b855f545..65c3092e 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -26,7 +26,7 @@ module Haddock.Options (
   optLaTeXStyle,
   verbosity,
   ghcFlags,
-  ifacePairs
+  ifaceTriples
 ) where
 
 
@@ -230,14 +230,17 @@ ghcFlags :: [Flag] -> [String]
 ghcFlags flags = [ option | Flag_OptGhc option <- flags ]
 
 
-ifacePairs :: [Flag] -> [(FilePath, FilePath)]
-ifacePairs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ]
+ifaceTriples :: [Flag] -> [(DocPaths, FilePath)]
+ifaceTriples flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ]
   where
-    parseIfaceOption :: String -> (FilePath, FilePath)
+    parseIfaceOption :: String -> (DocPaths, FilePath)
     parseIfaceOption str =
       case break (==',') str of
-        (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)
 
 
 -- | Like 'listToMaybe' but returns the last element instead of the first.
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 62a603ee..3ec37469 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -37,8 +37,10 @@ import Name
 type IfaceMap      = Map Module Interface
 type InstIfaceMap  = Map Module InstalledInterface
 type DocMap        = Map Name (Doc DocName)
+type SrcMap        = Map PackageId FilePath
 type Decl          = LHsDecl Name
 type GhcDocHdr     = Maybe LHsDocString
+type DocPaths      = (FilePath, Maybe FilePath) -- paths to HTML and sources
 
 
 -----------------------------------------------------------------------------
diff --git a/src/Main.hs b/src/Main.hs
index 22a649d2..b9eb6b95 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -58,6 +58,7 @@ import GHC hiding (flags, verbosity)
 import Config
 import DynFlags hiding (flags, verbosity)
 import Panic (handleGhcException)
+import Module
 
 
 --------------------------------------------------------------------------------
@@ -140,14 +141,14 @@ main = handleTopExceptions $ do
         throwE "No input file(s)."
 
       -- Get packages supplied with --read-interface.
-      packages <- readInterfaceFiles freshNameCache (ifacePairs flags)
+      packages <- readInterfaceFiles freshNameCache (ifaceTriples flags)
 
       -- Render even though there are no input files (usually contents/index).
       renderStep flags packages []
 
 
-readPackagesAndProcessModules :: [Flag] -> [String] -> IO ([(InterfaceFile, FilePath)],
-                                                           [Interface], LinkEnv)
+readPackagesAndProcessModules :: [Flag] -> [String]
+                              -> IO ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
 readPackagesAndProcessModules flags files = do
   libDir <- getGhcLibDir flags
 
@@ -160,31 +161,32 @@ readPackagesAndProcessModules flags files = do
   withGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do
 
     -- Get packages supplied with --read-interface.
-    packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags)
+    packages <- readInterfaceFiles nameCacheFromGhc (ifaceTriples flags)
 
     -- Create the interfaces -- this is the core part of Haddock.
-    let ifaceFiles = map fst packages
+    let ifaceFiles = map snd packages
     (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles
 
     return (packages, ifaces, homeLinks)
 
 
-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
 
 
 -- | Render the interfaces with whatever backend is specified in the flags.
-render :: [Flag] -> [Interface] -> [InstalledInterface] -> IO ()
-render flags ifaces installedIfaces = do
+render :: [Flag] -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()
+render flags ifaces installedIfaces srcMap = do
 
   let
     title                = fromMaybe "" (optTitle flags)
     unicode              = Flag_UseUnicode `elem` flags
-    opt_source_urls      = optSourceUrls     flags
     opt_wiki_urls        = optWikiUrls       flags
     opt_contents_url     = optContentsUrl    flags
     opt_index_url        = optIndexUrl       flags
@@ -197,30 +199,35 @@ render flags ifaces installedIfaces = do
     allIfaces        = map toInstalledIface ifaces ++ installedIfaces
     allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ]
 
-    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')
 
   libDir   <- getHaddockLibDir flags
   prologue <- getPrologue flags
   themes <- getThemes libDir flags >>= either bye return
 
   when (Flag_GenIndex `elem` flags) $ do
-    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
                 allVisibleIfaces
     copyHtmlBits odir libDir themes
 
   when (Flag_GenContents `elem` flags) $ do
-    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
                    allVisibleIfaces True prologue
     copyHtmlBits odir libDir themes
 
   when (Flag_Html `elem` flags) $ do
-    ppHtml title packageStr visibleIfaces odir
+    ppHtml title pkgStr visibleIfaces odir
                 prologue
-                themes opt_source_urls opt_wiki_urls
+                themes sourceUrls opt_wiki_urls
                 opt_contents_url opt_index_url unicode
     copyHtmlBits odir libDir themes
 
@@ -229,7 +236,7 @@ render flags ifaces installedIfaces = do
     ppHoogle pkgName2 pkgVer title prologue visibleIfaces odir
 
   when (Flag_LaTeX `elem` flags) $ do
-    ppLaTeX title packageStr visibleIfaces odir prologue opt_latex_style
+    ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style
                   libDir
 
 -------------------------------------------------------------------------------
@@ -239,22 +246,22 @@ render flags ifaces installedIfaces = do
 
 readInterfaceFiles :: MonadIO m =>
                       NameCacheAccessor m
-                   -> [(FilePath, FilePath)] ->
-                      m [(InterfaceFile, FilePath)]
+                   -> [(DocPaths, FilePath)] ->
+                      m [(DocPaths, InterfaceFile)]
 readInterfaceFiles name_cache_accessor pairs = do
   mbPackages <- mapM tryReadIface pairs
   return (catMaybes mbPackages)
   where
     -- try to read an interface, warn if we can't
-    tryReadIface (html, iface) = do
-      eIface <- readInterfaceFile name_cache_accessor iface
+    tryReadIface (paths, file) = do
+      eIface <- readInterfaceFile name_cache_accessor file
       case eIface of
         Left err -> liftIO $ do
-          putStrLn ("Warning: Cannot read " ++ iface ++ ":")
+          putStrLn ("Warning: Cannot read " ++ file ++ ":")
           putStrLn ("   " ++ err)
           putStrLn "Skipping this interface."
           return Nothing
-        Right f -> return $ Just (f, html)
+        Right f -> return $ Just (paths, f)
 
 
 dumpInterfaceFile :: FilePath -> [InstalledInterface] -> LinkEnv -> IO ()
@@ -366,10 +373,10 @@ shortcutFlags flags = do
     byeGhcVersion = bye (cProjectVersion ++ "\n")
 
 
-updateHTMLXRefs :: [(InterfaceFile, FilePath)] -> IO ()
+updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO ()
 updateHTMLXRefs packages = writeIORef html_xrefs_ref (Map.fromList mapping)
   where
-    mapping = [ (instMod iface, html) | (ifaces, html) <- packages
+    mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages
               , iface <- ifInstalledIfaces ifaces ]
author	David Waern <david.waern@gmail.com>	2010-08-29 13:03:28 +0000
committer	David Waern <david.waern@gmail.com>	2010-08-29 13:03:28 +0000
commit	d5ec98534422eba93298bb8a76e6b315a55c3158 (patch)
tree	72a4c3e98b60199e4bf1808878a81d441fa9b84c /src
parent	a01b2ef92f9164734d6673b1f3e01cde8da477c8 (diff)