aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Haddock/Backends/Html.hs20
-rw-r--r--src/Haddock/Interface/Create.hs29
-rw-r--r--src/Haddock/Types.hs4
3 files changed, 31 insertions, 22 deletions
diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index bb0927ca..cd35e9f6 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -1467,17 +1467,17 @@ topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url), iface)
case maybe_source_url of
Nothing -> Html.emptyTable
Just url -> tda [theclass "declbut"] <<
- let url' = spliceURL (Just fname) (Just orig_mod)
+ let url' = spliceURL (Just fname) (Just origMod)
(Just name) (Just loc) url
in anchor ! [href url'] << toHtml "Source"
- mod = iface_module iface
-
- -- for source links, we want to point to the original module
- -- for the name, because only that will have the source.
- orig_mod = case Map.lookup name (iface_env iface) of
- Just (Qual m _) -> m
- _ -> mod
+ -- for source links, we want to point to the original module,
+ -- because only that will have the source.
+ origMod = case Map.lookup (nameOccName name) (ifaceEnv iface) of
+ Just n -> case nameModule_maybe n of
+ Just m -> m
+ Nothing -> mod
+ _ -> error "This shouldn't happen (topDeclBox)"
wikiLink =
case maybe_wiki_url of
@@ -1487,7 +1487,9 @@ topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url), iface)
(Just name) (Just loc) url
in anchor ! [href url'] << toHtml "Comments"
- mod = iface_module iface
+ mod = ifaceMod iface
+ fname = unpackFS (srcSpanFile loc)
+
-- a box for displaying an 'argument' (some code which has text to the
-- right of it). Wrapping is not allowed in these boxes, whereas it is
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index fba25fe2..d2e616cc 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -53,17 +53,19 @@ createInterface ghcMod flags modMap = do
| Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
| otherwise = opts0
- let group = ghcGroup ghcMod
- entities = (nubBy sameName . getTopEntities) group
- exports = fmap (reverse . map unLoc) (ghcMbExports ghcMod)
- entityNames_ = entityNames entities
- subNames = allSubNames group
- localNames = entityNames_ ++ subNames
- subMap = mkSubMap group
- expDeclMap = mkDeclMap (ghcExportedNames ghcMod) group
- localDeclMap = mkDeclMap entityNames_ group
- docMap = mkDocMap group
- ignoreExps = Flag_IgnoreAllExports `elem` flags
+ let group = ghcGroup ghcMod
+ entities = (nubBy sameName . getTopEntities) group
+ exports = fmap (reverse . map unLoc) (ghcMbExports ghcMod)
+ entityNames_ = entityNames entities
+ subNames = allSubNames group
+ localNames = entityNames_ ++ subNames
+ subMap = mkSubMap group
+ expDeclMap = mkDeclMap (ghcExportedNames ghcMod) group
+ localDeclMap = mkDeclMap entityNames_ group
+ docMap = mkDocMap group
+ ignoreExps = Flag_IgnoreAllExports `elem` flags
+ exportedNames = ghcExportedNames ghcMod
+ origEnv = Map.fromList [ (nameOccName n, n) | n <- exportedNames ]
visibleNames <- mkVisibleNames mod modMap localNames
(ghcNamesInScope ghcMod)
@@ -92,8 +94,9 @@ createInterface ghcMod flags modMap = do
ifaceRnDocMap = Map.empty,
ifaceSubMap = subMap,
ifaceExportItems = prunedExportItems,
- ifaceRnExportItems = [],
- ifaceExports = ghcExportedNames ghcMod,
+ ifaceRnExportItems = [],
+ ifaceEnv = origEnv,
+ ifaceExports = exportedNames,
ifaceVisibleExports = visibleNames,
ifaceExportedDeclMap = expDeclMap,
ifaceInstances = ghcInstances ghcMod
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 0efffafb..580dc8cc 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -13,6 +13,7 @@ import qualified Data.Map as Map
import GHC hiding (NoLink)
import Outputable
+import OccName
{-! for DocOption derive: Binary !-}
data DocOption
@@ -141,6 +142,9 @@ data Interface = Interface {
ifaceExportItems :: [ExportItem Name],
ifaceRnExportItems :: [ExportItem DocName],
+ -- | Environment mapping exported names to *original* names
+ ifaceEnv :: Map OccName Name,
+
-- | All the names that are defined in this module
ifaceLocals :: [Name],