Show re-exported names from external packages again

This fixes GHC ticket 2746.

In order to also link to the exported subordinate names of a declaration, we
need to re-introduce the sub map in the .haddock files.

7 files changed, 89 insertions, 51 deletions

diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index e93cb1e2..4044e9ef 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -609,7 +609,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface
     exports = numberSectionHeadings (ifaceRnExportItems iface)
 
     has_doc (ExportDecl _ doc _ _) = isJust doc
-    has_doc (ExportNoDecl _ _ _) = False
+    has_doc (ExportNoDecl _ _) = False
     has_doc (ExportModule _) = False
     has_doc _ = True
 
@@ -733,9 +733,9 @@ processExport _ _ _ (ExportGroup lev id0 doc)
   = ppDocGroup lev (namedAnchor id0 << docToHtml doc)
 processExport summary links docMap (ExportDecl decl doc subdocs insts)
   = ppDecl summary links decl doc insts docMap subdocs
-processExport summmary _ _ (ExportNoDecl _ y [])
+processExport summmary _ _ (ExportNoDecl y [])
   = declBox (ppDocName y)
-processExport summmary _ _ (ExportNoDecl _ y subs)
+processExport summmary _ _ (ExportNoDecl y subs)
   = declBox (ppDocName y <+> parenList (map ppDocName subs))
 processExport _ _ _ (ExportDoc doc)
   = docBox (docToHtml doc)
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index c8c03413..448d54e9 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -24,6 +24,7 @@ import Haddock.GHC.Utils
 import Haddock.GHC.Typecheck
 import Haddock.Exception
 import Haddock.Utils
+import Haddock.InterfaceFile
 
 import qualified Data.Map as Map
 import Data.Map (Map)
@@ -42,19 +43,28 @@ import SrcLoc
 -- | Turn a topologically sorted list of module names/filenames into interfaces. Also
 -- return the home link environment created in the process.
 #if __GLASGOW_HASKELL__ >= 609
-createInterfaces :: [String] -> LinkEnv -> [Flag] -> Ghc ([Interface], LinkEnv)
-createInterfaces modules externalLinks flags = do
+createInterfaces :: [String] -> [Flag] -> [InterfaceFile]
+                 -> Ghc ([Interface], LinkEnv)
+createInterfaces modules flags extIfaces = do
   -- part 1, create interfaces
-  interfaces <- createInterfaces' modules flags
+  let instIfaceMap =  Map.fromList [ (instMod iface, iface) | ext <- extIfaces
+                                   , iface <- ifInstalledIfaces ext ]
+  interfaces <- createInterfaces' modules flags instIfaceMap
 #else
-createInterfaces :: Session -> [String] -> LinkEnv -> [Flag] -> IO ([Interface], LinkEnv)
-createInterfaces session modules externalLinks flags = do
+createInterfaces :: Session -> [String] -> [Flag]
+                 -> [InterfaceFile] -> IO ([Interface], LinkEnv)
+createInterfaces session modules flags extIfaces = do
   -- part 1, create interfaces
-  interfaces <- createInterfaces' session modules flags
+  let instIfaceMap =  Map.fromList [ (instMod iface, iface) | ext <- extIfaces
+                                   , iface <- ifInstalledIfaces ext ]
+  interfaces <- createInterfaces' session modules flags instIfaceMap
 #endif
   -- part 2, build link environment
-  let homeLinks = buildHomeLinks interfaces
-      links     = homeLinks `Map.union` externalLinks
+      -- combine the link envs of the external packages into one
+  let extLinks  = Map.unions (map ifLinkEnv extIfaces)
+      homeLinks = buildHomeLinks interfaces -- build the environment for the home
+                                            -- package
+      links     = homeLinks `Map.union` extLinks
       allNames  = Map.keys links
 
   -- part 3, attach instances
@@ -70,17 +80,17 @@ createInterfaces session modules externalLinks flags = do
 
 
 #if __GLASGOW_HASKELL__ >= 609
-createInterfaces' :: [String] -> [Flag] -> Ghc [Interface]
-createInterfaces' modules flags = do
+createInterfaces' :: [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
+createInterfaces' modules flags instIfaceMap = do
   targets <- mapM (\f -> guessTarget f Nothing) modules
   setTargets targets
   modgraph <- depanal [] False
   let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
   (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
-    interface <- processModule modsum flags modMap
+    interface <- processModule modsum flags modMap instIfaceMap
 #else
-createInterfaces' :: Session -> [String] -> [Flag] -> IO [Interface]
-createInterfaces' session modules flags = do
+createInterfaces' :: Session -> [String] -> [Flag] -> InstIfaceMap -> IO [Interface]
+createInterfaces' session modules flags instIfaceMap = do
   targets <- mapM (\f -> guessTarget f Nothing) modules
   setTargets session targets
   mbGraph <- depanal session [] False
@@ -89,7 +99,7 @@ createInterfaces' session modules flags = do
     Nothing -> throwE "Failed to create dependecy graph"
   let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
   (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do
-    interface <- processModule session modsum flags modMap
+    interface <- processModule session modsum flags modMap instIfaceMap
 #endif
     return $ (interface : ifaces , Map.insert (ifaceMod interface) interface modMap)
     ) ([], Map.empty) orderedMods
@@ -128,8 +138,8 @@ ppModInfo (HaddockModInfo a b c d) = show (fmap pretty a) ++ show b ++ show c ++
 -}
 
 #if __GLASGOW_HASKELL__ >= 609
-processModule :: ModSummary -> [Flag] -> ModuleMap -> Ghc Interface
-processModule modsum flags modMap = 
+processModule :: ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> Ghc Interface
+processModule modsum flags modMap instIfaceMap = 
 
   let handleSrcErrors action = flip handleSourceError action $ \err -> do 
         printExceptionAndWarnings err
@@ -147,20 +157,20 @@ processModule modsum flags modMap =
                               typecheckedSource tc_mod,
                               moduleInfo tc_mod))
                              dynflags
-       let (interface, msg) = runWriter $ createInterface ghcMod flags modMap
+       let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap
        liftIO $ mapM_ putStrLn msg
        liftIO $ evaluate interface
        return interface
 #else
-processModule :: Session -> ModSummary -> [Flag] -> ModuleMap -> IO Interface
-processModule session modsum flags modMap = do
+processModule :: Session -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> IO Interface
+processModule session modsum flags modMap instIfaceMap = do
   let filename = msHsFilePath modsum
   mbMod <- checkAndLoadModule session modsum False
   ghcMod <- case mbMod of
     Just (CheckedModule a (Just b) (Just c) (Just d) _)
       -> return $ mkGhcModule (ms_mod modsum, filename, (a,b,c,d)) (ms_hspp_opts modsum)
     _ -> throwE ("Failed to check module: " ++ (moduleString $ ms_mod modsum))
-  let (interface, msg) = runWriter $ createInterface ghcMod flags modMap
+  let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap
   mapM_ putStrLn msg
   return interface
 #endif
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index a5bbff3c..7a958504 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -40,8 +40,9 @@ import HscTypes
 -- | Process the data in the GhcModule to produce an interface.
 -- To do this, we need access to already processed modules in the topological
 -- sort. That's what's in the module map.
-createInterface :: GhcModule -> [Flag] -> ModuleMap -> ErrMsgM Interface
-createInterface ghcMod flags modMap = do
+createInterface :: GhcModule -> [Flag] -> ModuleMap -> InstIfaceMap
+                -> ErrMsgM Interface
+createInterface ghcMod flags modMap instIfaceMap = do
 
   let mod = ghcModule ghcMod
 
@@ -63,9 +64,9 @@ createInterface ghcMod flags modMap = do
   warnAboutFilteredDecls mod decls0
 
   exportItems <- mkExportItems modMap mod (ghcExportedNames ghcMod) decls declMap
-                               opts exports ignoreExps instances
+                               opts exports ignoreExps instances instIfaceMap
 
-  let visibleNames = mkVisibleNames exportItems
+  let visibleNames = mkVisibleNames exportItems opts
   
   -- prune the export list to just those declarations that have
   -- documentation, if the 'prune' option is on.
@@ -88,6 +89,7 @@ createInterface ghcMod flags modMap = do
     ifaceExports         = exportedNames,
     ifaceVisibleExports  = visibleNames, 
     ifaceDeclMap         = declMap,
+    ifaceSubMap          = mkSubMap declMap exportedNames,
     ifaceInstances       = ghcInstances ghcMod
   }
 
@@ -123,6 +125,14 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
 -- Declarations
 --------------------------------------------------------------------------------
 
+-- | Make a sub map from a declaration map. Make sure we only include exported
+-- names.
+mkSubMap :: Map Name DeclInfo -> [Name] -> Map Name [Name]
+mkSubMap declMap exports =
+  Map.filterWithKey (\k _ -> k `elem` exports) (Map.map filterSubs declMap)
+  where
+    filterSubs (_, _, subs) = [ sub  | (sub, _) <- subs, sub `elem` exports ]
+
 
 -- Make a map from names to 'DeclInfo's. Exclude declarations that don't
 -- have names (instances and stand-alone documentation comments). Include
@@ -322,6 +332,9 @@ attachATs exports =
 -- | Build the list of items that will become the documentation, from the
 -- export list.  At this point, the list of ExportItems is in terms of
 -- original names.
+--
+-- We create the export items even if the module is hidden, since they
+-- might be useful when creating the export items for other modules.
 mkExportItems
   :: ModuleMap
   -> Module			-- this module
@@ -332,10 +345,11 @@ mkExportItems
   -> Maybe [IE Name]
   -> Bool				-- --ignore-all-exports flag
   -> [Instance]
+  -> InstIfaceMap
   -> ErrMsgM [ExportItem Name]
 
 mkExportItems modMap this_mod exported_names decls declMap
-              opts maybe_exps ignore_all_exports instances
+              opts maybe_exps ignore_all_exports instances instIfaceMap
   | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts
     = everything_local_exported
   | Just specs <- maybe_exps = liftM concat $ mapM lookupExport specs
@@ -373,7 +387,17 @@ mkExportItems modMap this_mod exported_names decls declMap
       -- name out in mkVisibleNames...
       | Just x@(decl,_,_) <- findDecl t,
         t `notElem` declATs (unL decl) = return [ mkExportDecl t x ]
-      | otherwise = return []
+      | otherwise =
+        -- If we can't find the declaration, it must belong to another package.
+        -- We return an 'ExportNoDecl', and we try to get the subs from the
+        -- installed interface of that package.
+        case Map.lookup (nameModule t) instIfaceMap of
+          Nothing -> return [ ExportNoDecl t [] ]
+          Just iface ->
+            let subs = case Map.lookup t (instSubMap iface) of
+                         Nothing -> []
+                         Just x -> x
+            in return [ ExportNoDecl t subs ]
 
     mkExportDecl :: Name -> DeclInfo -> ExportItem Name
     mkExportDecl n (decl, doc, subs) = decl'
@@ -481,15 +505,18 @@ pruneExportItems items = filter hasDoc items
 	hasDoc _ = True
 
 
-mkVisibleNames :: [ExportItem Name] -> [Name]
-mkVisibleNames exports = concatMap exportName exports
+mkVisibleNames :: [ExportItem Name] -> [DocOption] -> [Name]
+mkVisibleNames exports opts
+  | OptHide `elem` opts = []
+  | otherwise = 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 e@ExportNoDecl {} = [] -- we don't count these as visible, since
+                                      -- we don't want links to go to them.
     exportName _ = []
 
       
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 3eb52d8f..3e4f6fbc 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -405,10 +405,10 @@ renameExportItem item = case item of
     subs' <- mapM renameSub subs
     instances' <- mapM renameInstHead instances
     return (ExportDecl decl' doc' subs' instances')
-  ExportNoDecl x y subs -> do
-    y'    <- lookupRn id y
+  ExportNoDecl x subs -> do
+    x'    <- lookupRn id x
     subs' <- mapM (lookupRn id) subs
-    return (ExportNoDecl x y' subs')
+    return (ExportNoDecl x' subs')
   ExportDoc doc -> do
     doc' <- renameDoc doc
     return (ExportDoc doc')
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index e04e5b3e..0daa21aa 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -353,13 +353,14 @@ instance Binary InterfaceFile where
 
 
 instance Binary InstalledInterface where
-  put_ bh (InstalledInterface modu info docMap exps visExps opts) = do
+  put_ bh (InstalledInterface modu info docMap exps visExps opts subMap) = do
     put_ bh modu
     put_ bh info
     put_ bh (Map.toList docMap)
     put_ bh exps
     put_ bh visExps
     put_ bh opts
+    put_ bh (Map.toList subMap)
 
   get bh = do
     modu    <- get bh
@@ -368,7 +369,10 @@ instance Binary InstalledInterface where
     exps    <- get bh
     visExps <- get bh
     opts    <- get bh
-    return (InstalledInterface modu info (Map.fromList docMap) exps visExps opts)
+    subMap  <- get bh
+    
+    return (InstalledInterface modu info (Map.fromList docMap)
+            exps visExps opts (Map.fromList subMap))
 
 
 instance Binary DocOption where
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index c10cfee7..b47444b7 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -56,11 +56,7 @@ data ExportItem name
 	  }	-- ^ An exported declaration 
 		    
   | ExportNoDecl {
-	  -- | The original name
-      expItemName :: Name,
-
-      -- | Where to link to
-      expItemLinkTarget :: name,
+      expItemName :: name,
 
       -- | Subordinate names
       expItemSubs :: [name]
@@ -89,6 +85,7 @@ data ExportItem name
 
 type InstHead name = ([HsPred name], name, [HsType name])
 type ModuleMap     = Map Module Interface
+type InstIfaceMap  = Map Module InstalledInterface
 type DocMap        = Map Name (HsDoc DocName)
 type LinkEnv       = Map Name Module
 
@@ -136,6 +133,7 @@ data Interface = Interface {
 
   ifaceDeclMap         :: Map Name DeclInfo,
   ifaceRnDocMap        :: Map Name (HsDoc DocName),
+  ifaceSubMap          :: Map Name [Name],
 
   ifaceExportItems     :: ![ExportItem Name],
   ifaceRnExportItems   :: [ExportItem DocName],
@@ -168,7 +166,8 @@ data InstalledInterface = InstalledInterface {
   instDocMap         :: Map Name (HsDoc DocName),
   instExports        :: [Name],
   instVisibleExports :: [Name],
-  instOptions        :: [DocOption]
+  instOptions        :: [DocOption],
+  instSubMap         :: Map Name [Name]
 }
 
 
@@ -180,7 +179,8 @@ toInstalledIface interface = InstalledInterface {
   instDocMap         = ifaceRnDocMap       interface,
   instExports        = ifaceExports        interface,
   instVisibleExports = ifaceVisibleExports interface,
-  instOptions        = ifaceOptions        interface
+  instOptions        = ifaceOptions        interface,
+  instSubMap         = ifaceSubMap         interface
 }
 
 
diff --git a/src/Main.hs b/src/Main.hs
index 686e9237..328fce4d 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -166,11 +166,10 @@ main = handleTopExceptions $ do
         -- get packages supplied with --read-interface
         packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags)
 
-        -- combine the link envs of the external packages into one
-        let extLinks = Map.unions (map (ifLinkEnv . fst) packages)
 
         -- create the interfaces -- this is the core part of Haddock
-        (interfaces, homeLinks) <- createInterfaces fileArgs extLinks flags
+        (interfaces, homeLinks) <- createInterfaces fileArgs flags
+                                                    (map fst packages)
 
         liftIO $ do
           -- render the interfaces
@@ -185,11 +184,9 @@ main = handleTopExceptions $ do
       -- get packages supplied with --read-interface
       packages <- readInterfaceFiles (nameCacheFromGhc session) (ifacePairs flags)
 
-      -- combine the link envs of the external packages into one
-      let extLinks = Map.unions (map (ifLinkEnv . fst) packages)
-
       -- create the interfaces -- this is the core part of Haddock
-      (interfaces, homeLinks) <- createInterfaces session fileArgs extLinks flags
+      (interfaces, homeLinks) <- createInterfaces session fileArgs flags
+                                                  (map fst packages)
 
       -- render the interfaces
       renderStep packages interfaces