From d7f493b949e9236a6bd6d18752a77bcaa2a208fe Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Mon, 28 Jul 2003 13:35:17 +0000
Subject: [haddock @ 2003-07-28 13:35:16 by simonmar] When a module A exports
 another module's contents via 'module B', then modules which import entities
 from B re-exported by A should link to B.foo rather than A.foo.  See
 examples/Bug2.hs.

---
 src/HaddockTypes.hs |  6 ++++++
 src/Main.hs         | 49 +++++++++++++++++++++++++++++++++++++++++++------
 2 files changed, 49 insertions(+), 6 deletions(-)

diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index 06e258cb..36cb9351 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -28,6 +28,12 @@ data Interface
 	iface_env :: NameEnv,
 		-- ^ environment mapping names to *original* names
 
+	iface_reexported :: NameEnv,
+		-- ^ For names exported by this module, but not actually documented
+		-- in this module's documentation (perhaps because they are reexported via
+		-- 'module M' in the export list), this mapping gives the location of
+		-- documentation for the name in another module.
+
 	iface_sub :: FiniteMap HsName [HsName],
 		-- ^ maps names to "subordinate" names 
 		-- (eg. tycon to constrs & fields, class to methods)
diff --git a/src/Main.hs b/src/Main.hs
index b7432166..d1bd8e51 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -221,6 +221,7 @@ readIface filename = do
 		   iface_filename     = "",
 		   iface_env          = listToFM env,
 		   iface_sub	      = listToFM sub,
+		   iface_reexported   = emptyFM,
 		   iface_exports      = [],
 		   iface_orig_exports = [],
 		   iface_insts	      = [],
@@ -362,6 +363,10 @@ mkInterface no_implicit_prelude mod_map filename
 
      name_env = listToFM [ (nameOfQName n, n) | n <- exported_names ]
 
+     -- find the names exported by this module that other modules should *not*
+     -- link to (and point them to where they should).
+     reexports = getReExports mdl mod_map orig_exports
+
   let
      (orig_module_doc, missing_names4)
         = runRnFM orig_env (renameMaybeDoc maybe_doc)
@@ -384,6 +389,7 @@ mkInterface no_implicit_prelude mod_map filename
   return (mdl, Interface { 
 		   iface_filename     = filename,
 		   iface_env          = name_env,
+		   iface_reexported    = reexports,
 		   iface_exports      = renamed_export_list,
 		   iface_sub	      = sub_map,
 		   iface_orig_exports = pruned_export_list,
@@ -648,7 +654,7 @@ exportedNames :: Module -> ModuleMap -> [HsName]
 
 exportedNames mdl mod_map local_names orig_env sub_map maybe_exps opts
   | Nothing <- maybe_exps 	    = all_local_names_pr
-  | OptIgnoreExports `elem` opts = all_local_names_pr
+  | OptIgnoreExports `elem` opts    = all_local_names_pr
   | Just expspecs <- maybe_exps     = 
 	(concat (map extract expspecs), 
 	 concat (map extract_vis expspecs))
@@ -694,7 +700,6 @@ exportedNames mdl mod_map local_names orig_env sub_map maybe_exps opts
 		-> trace ("Warning: module not found: " ++ show m) $ []
     _ -> extract e
 
-
 -- for a given entity, find all the names it "owns" (ie. all the
 -- constructors and field names of a tycon, or all the methods of a
 -- class).
@@ -706,6 +711,29 @@ all_subs_of_qname mod_map (Qual mdl nm) =
 all_subs_of_qname _ n@(UnQual _) =
     error $ "Main.all_subs_of_qname: unexpected unqual'd name:" ++ show n
 
+-- ----------------------------------------------------------------------------
+-- Get a list of names exported by this module that are not actually
+-- documented here, and build a mapping to point to where the
+-- documentation for those names can be found.  This is used for
+-- constructing the iface_reexports field of the Interface.
+
+getReExports :: Module -> ModuleMap -> Maybe [HsExportSpec] -> FiniteMap HsName HsQName
+getReExports mdl mod_map Nothing = emptyFM
+getReExports mdl mod_map (Just exps)
+  = foldr plusFM emptyFM (map extract exps)
+  where
+    extract (HsEModuleContents m) | m /= mdl =
+	  case lookupFM mod_map m of
+	    Nothing -> emptyFM
+	    Just iface
+		| OptHide `elem` iface_options iface -> emptyFM
+		| otherwise -> listToFM (map get_name (keysFM (iface_env iface)))
+		where
+		   get_name n = case lookupFM (iface_reexported iface) n of
+				   Just somewhere_else -> (n, somewhere_else)
+				   Nothing -> (n, Qual m n)
+    extract _ = emptyFM
+
 -- ----------------------------------------------------------------------------
 -- Building name environments
 
@@ -775,10 +803,19 @@ buildImportEnv mod_map this_mod exported_names imp_decls
     = case lookupFM mod_map mdl of
        Nothing    -> emptyFM
        Just iface -> listToFM (map import_map (fmToList (iface_env iface)))
-    where
-	import_map (nm,qnm) = (qnm, maps_to)
- 	  where maps_to | qnm `elem` exported_names = Qual this_mod nm
-		        | otherwise = Qual mdl nm
+        where
+	 reexport_env = iface_reexported iface
+
+	 import_map (nm,qnm) = (qnm, maps_to)
+ 	  where 
+		maps_to
+		 -- we re-export it: just link to this module
+		 | qnm `elem` exported_names = Qual this_mod nm
+		 -- re-exported from the other module, but not documented there:
+		 -- find the right place using the iface_reexported environment.
+		 | Just new_qnm <- lookupFM reexport_env nm = new_qnm
+		 -- otherwise, it's documented in the other module
+		 | otherwise = Qual mdl nm
 
 -- -----------------------------------------------------------------------------
 -- Expand multiple type signatures
-- 
cgit v1.2.3