Make visible names from ExportItems

Instead of a complicated calculation of visible names out of GHC's export
items, we can get them straight out of the already calculated ExportItems.  The
ExportItems should represent exactly those items that are visible in an
interface. 

If store all the exported sub-names in ExportDecl instead of only those with
documentation, the calculation becomes very simple. So we do this change as
well (should perhaps have been a separate patch).
 
This should fix the problem with names from ghc-prim not appearing in the link
environment.

4 files changed, 29 insertions, 69 deletions

diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index 7302cf2e..e93cb1e2 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -27,7 +27,7 @@ import Haddock.GHC.Utils
 import qualified Haddock.Utils.Html as Html
 
 import Control.Exception     ( bracket )
-import Control.Monad         ( when, unless )
+import Control.Monad         ( when, unless, join )
 import Data.Char             ( isUpper, toUpper )
 import Data.List             ( sortBy, groupBy )
 import Data.Maybe
@@ -763,7 +763,7 @@ declWithDoc False links loc nm (Just doc) html_decl =
 
 -- TODO: use DeclInfo DocName or something
 ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> 
-          Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> [(DocName, HsDoc DocName)] -> HtmlTable
+          Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> [(DocName, Maybe (HsDoc DocName))] -> HtmlTable
 ppDecl summ links (L loc decl) mbDoc instances docMap subdocs = case decl of
   TyClD d@(TyFamily {})          -> ppTyFam summ False links loc mbDoc d
   TyClD d@(TyData {})
@@ -1070,7 +1070,7 @@ ppFds fds =
 	fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> toHtml "->" <+>
 			       hsep (map ppDocName vars2)
 
-ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, HsDoc DocName)] -> HtmlTable
+ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, Maybe (HsDoc DocName))] -> HtmlTable
 ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc subdocs = 
   if null sigs && null ats
     then (if summary then declBox else topDeclBox links loc nm) hdr
@@ -1081,11 +1081,11 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc
 					aboves
 					(
 						[ ppAssocType summary links doc at | at <- ats
-                                                , let doc = lookup (tcdName $ unL at) subdocs ]  ++
+                                                , let doc = join $ lookup (tcdName $ unL at) subdocs ]  ++
 
 						[ ppFunSig summary links loc doc n typ
 						| L _ (TypeSig (L _ n) (L _ typ)) <- sigs
-						, let doc = lookup n subdocs ] 
+						, let doc = join $ lookup n subdocs ] 
 					)
 				)
   where
@@ -1095,7 +1095,7 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc
 
 
 ppClassDecl :: Bool -> LinksInfo -> [InstHead DocName] -> SrcSpan ->
-               Maybe (HsDoc DocName) -> DocMap -> [(DocName, HsDoc DocName)] -> TyClDecl DocName -> 
+               Maybe (HsDoc DocName) -> DocMap -> [(DocName, Maybe (HsDoc DocName))] -> TyClDecl DocName -> 
                HtmlTable
 ppClassDecl summary links instances loc mbDoc docMap subdocs
 	decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _)
@@ -1124,10 +1124,10 @@ ppClassDecl summary links instances loc mbDoc docMap subdocs
     methodTable =
       abovesSep s8 [ ppFunSig summary links loc doc n typ
                    | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs
-                   , let doc = lookup n subdocs ]
+                   , let doc = join $ lookup n subdocs ]
 
     atTable = abovesSep s8 $ [ ppAssocType summary links doc at | at <- ats
-                             , let doc = lookup (tcdName $ unL at) subdocs ]
+                             , let doc = join $ lookup (tcdName $ unL at) subdocs ]
 
     instId = collapseId (docNameOrig nm)
     instancesBit
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index b7c82267..a5bbff3c 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -62,13 +62,11 @@ createInterface ghcMod flags modMap = do
 
   warnAboutFilteredDecls mod decls0
 
-  visibleNames <- mkVisibleNames mod modMap localNames 
-                                 (ghcNamesInScope ghcMod) 
-                                 exports opts declMap 
-
   exportItems <- mkExportItems modMap mod (ghcExportedNames ghcMod) decls declMap
                                opts exports ignoreExps instances
 
+  let visibleNames = mkVisibleNames exportItems
+  
   -- prune the export list to just those declarations that have
   -- documentation, if the 'prune' option is on.
   let 
@@ -377,15 +375,13 @@ mkExportItems modMap this_mod exported_names decls declMap
         t `notElem` declATs (unL decl) = return [ mkExportDecl t x ]
       | otherwise = return []
 
-
     mkExportDecl :: Name -> DeclInfo -> ExportItem Name
     mkExportDecl n (decl, doc, subs) = decl'
       where
-        decl' = ExportDecl (restrictTo subs' (extractDecl n mdl decl)) doc subdocs []
+        decl' = ExportDecl (restrictTo sub_names (extractDecl n mdl decl)) doc subs' []
         mdl = nameModule n
-        subs' = filter (`elem` exported_names) $ map fst subs
-        subdocs = [ (n, doc) | (n, Just doc) <- subs ]
-
+        subs' = filter ((`elem` exported_names) . fst) subs
+        sub_names = map fst subs'
 
     fullContentsOf m  
 	| m == this_mod = return (fullContentsOfThisModule this_mod decls)
@@ -412,8 +408,7 @@ fullContentsOfThisModule module_ decls = catMaybes (map mkExportItem decls)
   where
     mkExportItem (L _ (DocD (DocGroup lev doc)), _, _) = Just $ ExportGroup lev "" doc
     mkExportItem (L _ (DocD (DocCommentNamed _ doc)), _, _)   = Just $ ExportDoc doc
-    mkExportItem (decl, doc, subs) = Just $ ExportDecl decl doc subdocs []
-      where subdocs = [ (n, doc) | (n, Just doc) <- subs ]
+    mkExportItem (decl, doc, subs) = Just $ ExportDecl decl doc subs []
 
 --    mkExportItem _ = Nothing -- TODO: see if this is really needed
 
@@ -486,53 +481,18 @@ pruneExportItems items = filter hasDoc items
 	hasDoc _ = True
 
 
--- | Gather a list of original names exported from this module
-mkVisibleNames :: Module 
-             -> ModuleMap
-             -> [Name] 
-             -> [Name]
-             -> Maybe [IE Name]
-             -> [DocOption]
-             -> Map Name DeclInfo
-             -> ErrMsgM [Name]
-
-mkVisibleNames mdl modMap localNames scope maybeExps opts declMap 
-  -- if no export list, just return all local names 
-  | Nothing <- maybeExps         = return (filter hasDecl localNames)
-  | OptIgnoreExports `elem` opts = return localNames
-  | Just expspecs <- maybeExps = do
-      visibleNames <- mapM extract expspecs
-      return $ filter isNotPackageName (concat visibleNames)
- where
-  hasDecl name = isJust (Map.lookup name declMap)
-  isNotPackageName name = nameMod == mdl || isJust (Map.lookup nameMod modMap)
-    where nameMod = nameModule name
-
-  extract e = 
-   case e of
-    IEVar x -> return [x]
-    IEThingAbs t -> return [t]
-    IEThingAll t -> return (t : all_subs)
-	 where
-	      all_subs | nameModule t == mdl = subsOfName t declMap
-		       | otherwise = allSubsOfName modMap t
-
-    IEThingWith t cs -> return (t : cs)
-	
-    IEModuleContents m
-	| mkModule (modulePackageId mdl) m == mdl -> return localNames 
-	| otherwise -> let m' = mkModule (modulePackageId mdl) m in
-	  case Map.lookup m' modMap of
-	    Just mod
-		| OptHide `elem` ifaceOptions mod ->
-		    return (filter (`elem` scope) (ifaceExports mod))
-		| otherwise -> return []
-	    Nothing
-		-> tell (exportModuleMissingErr mdl m') >> return []
-  
-    _ -> return []
-
-
+mkVisibleNames :: [ExportItem Name] -> [Name]
+mkVisibleNames exports = concatMap exportName exports
+  where
+    exportName e@ExportDecl {} =
+      case getMainDeclBinder $ unL $ expItemDecl e of
+        Just n -> n : subs
+        Nothing -> subs
+      where subs = map fst (expItemSubDocs e) 
+    exportName e@ExportNoDecl {} = expItemName e : expItemSubs e
+    exportName _ = []
+
+      
 exportModuleMissingErr this mdl 
   = ["Warning: in export list of " ++ show (moduleString this)
 	 ++ ": module not found: " ++ show (moduleString mdl)]
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 0e0da5a6..3eb52d8f 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -416,5 +416,5 @@ renameExportItem item = case item of
 
 renameSub (n,doc) = do
   n' <- rename n
-  doc' <- renameDoc doc
+  doc' <- mapM renameDoc doc
   return (n', doc')
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 44cc9161..c10cfee7 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -47,8 +47,8 @@ data ExportItem name
       -- | Maybe a doc comment
       expItemMbDoc :: Maybe (HsDoc name),
 
-      -- | Documentation for subordinate declarations
-      expItemSubDocs :: [(name, HsDoc name)],
+      -- | Subordinate names, possibly with documentation
+      expItemSubDocs :: [(name, Maybe (HsDoc name))],
 
       -- | Instances relevant to this declaration
       expItemInstances :: [InstHead name]