aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMurray Campbell <murray@sonology.net>2015-04-26 13:49:01 -0700
committerAustin Seipp <aseipp@pobox.com>2015-05-11 06:35:06 -0500
commitbf31846b9f7280b5e75f09e91ca18c4ced37af08 (patch)
tree98804e03bb764a28ad319b544abe06fad5f9d1f6
parent319bf20d44589545e6850db3e676e30216dd3cc2 (diff)
Change ModuleTree Node to carry PackageKey and SourcePackageId to resolve #385
Signed-off-by: Austin Seipp <aseipp@pobox.com> (cherry picked from commit 2380f07c430c525b205ce2eae6dab23c8388d899)
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs4
-rw-r--r--haddock-api/src/Haddock/ModuleTree.hs41
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 948ef641..90cb9fa4 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -288,7 +288,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
@@ -312,7 +312,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]