From afcd30fcd5ac4d76ef805a636992978b5efc2ad7 Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Wed, 30 Jul 2003 15:04:52 +0000
Subject: [haddock @ 2003-07-30 15:04:52 by simonmar] Pay attention to import
 specs when building the the import env, as well as the orig env.  This may
 fix some wrong links in documentation when import specs are being used.

---
 src/Main.hs | 105 ++++++++++++++++++++++++++++++++++--------------------------
 1 file changed, 59 insertions(+), 46 deletions(-)

diff --git a/src/Main.hs b/src/Main.hs
index 092c4861..c328bad0 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -340,8 +340,8 @@ mkInterface no_implicit_prelude mod_map filename
 		   buildImportEnv mod_map mdl exported_visible_names 
 			implicit_imps
 
-  -- trace (show (fmToList orig_env)) $ do
-  -- trace (show (fmToList import_env)) $ do
+--   trace (show (fmToList orig_env)) $ do
+--  trace (show (fmToList import_env)) $ do
   let
      final_decls = orig_decls
 
@@ -743,26 +743,20 @@ getReExports mdl mod_map (Just exps)
 -- ----------------------------------------------------------------------------
 -- Building name environments
 
+-- The orig env maps names in the current source file to
+-- fully-qualified "original" names.
+
 buildOrigEnv :: ModuleMap -> [HsImportDecl] -> FiniteMap HsQName HsQName
 buildOrigEnv mod_map imp_decls
   = foldr plusFM emptyFM (map build imp_decls)
   where
-  build (HsImportDecl _ mdl qual maybe_as spec)
+  build imp_decl@(HsImportDecl _ mdl qual maybe_as _)
     = case lookupFM mod_map mdl of
        Nothing -> 
 	  trace ("Warning: module not found: " ++ show mdl) $ emptyFM
        Just iface -> 
-	  case spec of
-		-- no import specs
-	    Nothing -> import_everything
-		-- hiding
-	    Just (True, specs) -> 
-		import_everything `minusFM` 
-			listToFM (concat (map names_from_spec specs))
-		-- not hiding
-	    Just (False, specs) -> listToFM (concat (map names_from_spec specs))
+	  listToFM (concat (map orig_map (processImportDecl mod_map imp_decl)))
         where
-        import_everything = listToFM (concat (map orig_map (fmToList env)))
 
 	-- bring both qualified and unqualified names into scope, unless
 	-- the import was 'qualified'.
@@ -774,46 +768,26 @@ buildOrigEnv mod_map imp_decls
 	  | Just m <- maybe_as = m
 	  | otherwise          = mdl
 
-	env = iface_env iface
-
-	names_from_spec :: HsImportSpec -> [(HsQName,HsQName)]
-	names_from_spec (HsIVar nm) = one_name nm
-	names_from_spec (HsIAbs nm) = one_name nm
-	names_from_spec (HsIThingAll nm) = one_name nm ++ get_sub_names nm
-	names_from_spec (HsIThingWith nm nms) =
-	  one_name nm ++ concat (map one_name (
-				filter (`elem` nms) (sub_names nm)))
-
-	sub_names :: HsName -> [HsName]
-	sub_names nm =
-	  case lookupFM env nm of
-	    Just qnm -> filter (`elemFM` env) (all_subs_of_qname mod_map qnm)
-	    _ -> []
-
-	get_sub_names = concat . map one_name . sub_names
-
-	one_name :: HsName -> [(HsQName,HsQName)]
-	one_name nm = 
-	   case lookupFM env nm of
-		Nothing ->  trace ("Warning: " ++ show mdl
-				    ++ " does not export " ++ show nm) []
-		Just qnm -> orig_map (nm,qnm)
 
+-- The import env maps each "original" name referred to in the current
+-- module to the qualified name that we want to link to in the
+-- documentation.
 
 buildImportEnv :: ModuleMap -> Module -> [HsQName] -> [HsImportDecl]
 	-> FiniteMap HsQName HsQName
 buildImportEnv mod_map this_mod exported_names imp_decls
   = foldr plusFM emptyFM (map build imp_decls)
   where
-  build (HsImportDecl _ mdl _ _ _)
-    = case lookupFM mod_map mdl of
-       Nothing    -> emptyFM
-       Just iface -> listToFM (map import_map (fmToList (iface_env iface)))
-        where
-	 reexport_env = iface_reexported iface
-
-	 import_map (nm,qnm) = (qnm, maps_to)
- 	  where 
+	build imp_decl@(HsImportDecl _ mdl _ _ _) = 
+	  case lookupFM mod_map mdl of
+       	    Nothing    -> emptyFM
+            Just iface -> listToFM (map import_map imported_names)
+	     where
+	      imported_names = processImportDecl mod_map imp_decl
+	      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
@@ -823,6 +797,45 @@ buildImportEnv mod_map this_mod exported_names imp_decls
 		 -- otherwise, it's documented in the other module
 		 | otherwise = Qual mdl nm
 
+
+processImportDecl :: ModuleMap -> HsImportDecl -> [(HsName,HsQName)]
+processImportDecl mod_map (HsImportDecl _ mdl is_qualified maybe_as imp_specs)
+    = case lookupFM mod_map mdl of
+       Nothing    -> []
+       Just iface -> imported_names
+        where
+	 env = iface_env iface
+	 sub = iface_sub iface
+
+ 	 all_names = fmToList env
+
+	 imported_names :: [(HsName,HsQName)]
+	 imported_names
+	   = case imp_specs of
+		Nothing          -> all_names
+	        Just (False,specs) -> [ (n,qnm) | (n,qnm) <- all_names,
+						n `elem` names specs False ]
+	        Just (True, specs) -> [ (n,qnm) | (n,qnm) <- all_names,
+						n `notElem` names specs True ]
+	      where
+		names specs is_hiding 
+		  = concat (map (spec_names is_hiding) specs)
+
+	-- when hiding, a conid refers to both the constructor and
+	-- the type/class constructor.
+	 spec_names _hid (HsIVar v)		= [v]
+	 spec_names True  (HsIAbs (HsTyClsName i))
+		 = [HsTyClsName i, HsVarName i]
+	 spec_names False (HsIAbs v)		= [v]
+	 spec_names _hid (HsIThingAll v)	= v : sub_names v
+	 spec_names _hid (HsIThingWith v xs) 	= v : xs
+
+	 sub_names :: HsName -> [HsName]
+	 sub_names nm =
+	  case lookupFM env nm of
+	    Just qnm -> filter (`elemFM` env) (all_subs_of_qname mod_map qnm)
+	    _ -> []
+
 -- -----------------------------------------------------------------------------
 -- Expand multiple type signatures
 
-- 
cgit v1.2.3