From 671ec1ad8aec260511887788338f186055ac52d1 Mon Sep 17 00:00:00 2001
From: David Waern <davve@dtek.chalmers.se>
Date: Sun, 6 Jan 2008 14:40:52 +0000
Subject: Manual merge of a patch to the 0.8 branch

  Thu Dec  6 15:00:10 CET 2007  Simon Marlow <simonmar@microsoft.com>
    * Source links must point to the original module, not the referring
      module
---
 src/Haddock/Backends/Html.hs    | 20 +++++++++++---------
 src/Haddock/Interface/Create.hs | 29 ++++++++++++++++-------------
 src/Haddock/Types.hs            |  4 ++++
 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],
 
-- 
cgit v1.2.3