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/Haddock
parent: a01b2ef92f9164734d6673b1f3e01cde8da477c8 (diff)
6 files changed, 31 insertions, 18 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
 
 
 -----------------------------------------------------------------------------
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/Haddock
parent	a01b2ef92f9164734d6673b1f3e01cde8da477c8 (diff)