Change ModuleTree Node to carry PackageKey and SourcePackageId to resolve #385

Signed-off-by: Austin Seipp <aseipp@pobox.com>

2 files changed, 24 insertions, 21 deletions

diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 65a7e6c4..6ef1e863 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -289,7 +289,7 @@ mkNodeList qual ss p ts = case ts of
 
 
 mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html
-mkNode qual ss p (Node s leaf pkg short ts) =
+mkNode qual ss p (Node s leaf pkg srcPkg short ts) =
   htmlModule <+> shortDescr +++ htmlPkg +++ subtree
   where
     modAttrs = case (ts, leaf) of
@@ -313,7 +313,7 @@ mkNode qual ss p (Node s leaf pkg short ts) =
     mdl = intercalate "." (reverse (s:ss))
 
     shortDescr = maybe noHtml (origDocToHtml qual) short
-    htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg
+    htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg
 
     subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True ""
 
diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs
index eec1342e..2f731214 100644
--- a/haddock-api/src/Haddock/ModuleTree.hs
+++ b/haddock-api/src/Haddock/ModuleTree.hs
@@ -15,41 +15,44 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where
 import Haddock.Types ( MDoc )
 
 import GHC           ( Name )
-import Module        ( Module, moduleNameString, moduleName, modulePackageKey )
+import Module        ( Module, moduleNameString, moduleName, modulePackageKey, packageKeyString )
 import DynFlags      ( DynFlags )
 import Packages      ( lookupPackage )
 import PackageConfig ( sourcePackageIdString )
 
 
-data ModuleTree = Node String Bool (Maybe String) (Maybe (MDoc Name)) [ModuleTree]
+data ModuleTree = Node String Bool (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree]
 
 
 mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree]
 mkModuleTree dflags showPkgs mods =
-  foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ]
+  foldr fn [] [ (splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ]
   where
-    modPkg mod_ | showPkgs = fmap sourcePackageIdString
-                                  (lookupPackage dflags (modulePackageKey mod_))
+    modPkg mod_ | showPkgs = Just (packageKeyString (modulePackageKey mod_))
                 | otherwise = Nothing
-    fn (mod_,pkg,short) = addToTrees mod_ pkg short
-
-
-addToTrees :: [String] -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree]
-addToTrees [] _ _ ts = ts
-addToTrees ss pkg short [] = mkSubTree ss pkg short
-addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts)
-  | s1 >  s2  = t : addToTrees (s1:ss) pkg short ts
-  | s1 == s2  = Node s2 (leaf || null ss) this_pkg this_short (addToTrees ss pkg short subs) : ts
-  | otherwise = mkSubTree (s1:ss) pkg short ++ t : ts
+    modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString
+                                     (lookupPackage dflags (modulePackageKey mod_))
+                   | otherwise = Nothing
+    fn (mod_,pkg,srcPkg,short) = addToTrees mod_ pkg srcPkg short
+
+
+addToTrees :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree]
+addToTrees [] _ _ _ ts = ts
+addToTrees ss pkg srcPkg short [] = mkSubTree ss pkg srcPkg short
+addToTrees (s1:ss) pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts)
+  | s1 >  s2  = t : addToTrees (s1:ss) pkg srcPkg short ts
+  | s1 == s2  = Node s2 (leaf || null ss) this_pkg this_srcPkg this_short (addToTrees ss pkg srcPkg short subs) : ts
+  | otherwise = mkSubTree (s1:ss) pkg srcPkg short ++ t : ts
  where
   this_pkg = if null ss then pkg else node_pkg
+  this_srcPkg = if null ss then srcPkg else node_srcPkg
   this_short = if null ss then short else node_short
 
 
-mkSubTree :: [String] -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree]
-mkSubTree []     _   _     = []
-mkSubTree [s]    pkg short = [Node s True pkg short []]
-mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)]
+mkSubTree :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree]
+mkSubTree []     _   _      _     = []
+mkSubTree [s]    pkg srcPkg short = [Node s True pkg srcPkg short []]
+mkSubTree (s:ss) pkg srcPkg short = [Node s (null ss) Nothing Nothing Nothing (mkSubTree ss pkg srcPkg short)]
 
 
 splitModule :: Module -> [String]