Supported reexported-modules via --reexport flag.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

5 files changed, 57 insertions, 30 deletions

diff --git a/CHANGES.md b/CHANGES.md
index 0b4ca29d..dd39c563 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -2,6 +2,9 @@
 
  * to be released
 
+ * A --reexport flag, which can be used to add extra modules to the
+   top-level module tree
+
  * Haddock no longer reports coverage statistics for hidden modules. By default
    cabal-install marks all package internal modules as hidden.
 
@@ -44,7 +47,7 @@
 
  * Remove framed view of the HTML documentation
 
-## Changes in version 2.17.2
+Changes in version 2.17.2
 
  * Fix portability of documentation building within GHC
 
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 7b4b8671..d9bc3ea6 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -67,6 +67,7 @@ import Paths_haddock_api (getDataDir)
 import System.Directory (doesDirectoryExist)
 #endif
 
+import Text.ParserCombinators.ReadP (readP_to_S)
 import GHC hiding (verbosity)
 import Config
 import DynFlags hiding (projectVersion, verbosity)
@@ -296,6 +297,23 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
 
     sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap')
 
+    -- TODO: This silently suppresses errors
+    installedMap :: Map Module InstalledInterface
+    installedMap = Map.fromList [ (unwire (instMod iface), iface) | iface <- installedIfaces ]
+
+    -- The user gives use base-4.9.0.0, but the InstalledInterface
+    -- records the *wired in* identity base.  So untranslate it
+    -- so that we can service the request.
+    unwire :: Module -> Module
+    unwire m = m { moduleUnitId = unwireUnitId dflags (moduleUnitId m) }
+
+    reexportedIfaces =
+        [ iface
+        | mod_str <- reexportFlags flags
+        , (m, "") <- readP_to_S parseModuleId mod_str
+        , Just iface <- [Map.lookup m installedMap]
+        ]
+
   libDir   <- getHaddockLibDir flags
   prologue <- getPrologue dflags' flags
   themes   <- getThemes libDir flags >>= either bye return
@@ -316,7 +334,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
     copyHtmlBits odir libDir themes withQuickjump
 
   when (Flag_Html `elem` flags) $ do
-    ppHtml dflags' title pkgStr visibleIfaces odir
+    ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir
                 prologue
                 themes opt_mathjax sourceUrls' opt_wiki_urls
                 opt_contents_url opt_index_url unicode qual
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 8205f658..04a066a7 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -37,7 +37,7 @@ import Haddock.GhcUtils
 
 import Control.Monad         ( when, unless )
 import Data.Char             ( toUpper, isSpace )
-import Data.List             ( sortBy, intercalate, isPrefixOf, intersperse )
+import Data.List             ( sortBy, isPrefixOf, intercalate, intersperse )
 import Data.Maybe
 import System.FilePath hiding ( (</>) )
 import System.Directory
@@ -49,7 +49,6 @@ import Data.Ord              ( comparing )
 import DynFlags (Language(..))
 import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) )
 import Name
-import Module
 
 --------------------------------------------------------------------------------
 -- * Generating HTML documentation
@@ -59,6 +58,7 @@ ppHtml :: DynFlags
        -> String                       -- ^ Title
        -> Maybe String                 -- ^ Package
        -> [Interface]
+       -> [InstalledInterface]         -- ^ Reexported interfaces
        -> FilePath                     -- ^ Destination directory
        -> Maybe (MDoc GHC.RdrName)     -- ^ Prologue text, maybe
        -> Themes                       -- ^ Themes
@@ -73,7 +73,7 @@ ppHtml :: DynFlags
        -> Bool                         -- ^ Also write Quickjump index
        -> IO ()
 
-ppHtml dflags doctitle maybe_package ifaces odir prologue
+ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue
         themes maybe_mathjax_url maybe_source_url maybe_wiki_url
         maybe_contents_url maybe_index_url unicode
         qual debug withQuickjump =  do
@@ -84,14 +84,14 @@ ppHtml dflags doctitle maybe_package ifaces odir prologue
   when (isNothing maybe_contents_url) $
     ppHtmlContents dflags odir doctitle maybe_package
         themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url
-        (map toInstalledIface visible_ifaces)
+        (map toInstalledIface visible_ifaces ++ reexported_ifaces)
         False -- we don't want to display the packages in a single-package contents
         prologue debug (makeContentsQual qual)
 
   when (isNothing maybe_index_url) $ do
     ppHtmlIndex odir doctitle maybe_package
       themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url
-      (map toInstalledIface visible_ifaces) debug
+      (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug
 
     when withQuickjump $
       ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual
@@ -309,29 +309,26 @@ mkNodeList qual ss p ts = case ts of
 
 
 mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html
-mkNode qual ss p (Node s leaf pkg srcPkg short ts) =
+mkNode qual ss p (Node s leaf _pkg srcPkg short ts) =
   htmlModule <+> shortDescr +++ htmlPkg +++ subtree
   where
     modAttrs = case (ts, leaf) of
-      (_:_, False) -> collapseControl p "module"
+      (_:_, Nothing) -> collapseControl p "module"
       (_,   _    ) -> [theclass "module"]
 
     cBtn = case (ts, leaf) of
-      (_:_, True) -> thespan ! collapseControl p "" << spaceHtml
+      (_:_, Just _) -> thespan ! collapseControl p "" << spaceHtml
       (_,   _   ) -> noHtml
       -- We only need an explicit collapser button when the module name
       -- is also a leaf, and so is a link to a module page. Indeed, the
       -- spaceHtml is a minor hack and does upset the layout a fraction.
 
     htmlModule = thespan ! modAttrs << (cBtn +++
-      if leaf
-        then ppModule (mkModule (stringToUnitId (fromMaybe "" pkg))
-                                       (mkModuleName mdl))
-        else toHtml s
+      case leaf of
+        Just m -> ppModule m
+        Nothing -> toHtml s
       )
 
-    mdl = intercalate "." (reverse (s:ss))
-
     shortDescr = maybe noHtml (origDocToHtml qual) short
     htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg
 
diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs
index e6cf8201..a0be820a 100644
--- a/haddock-api/src/Haddock/ModuleTree.hs
+++ b/haddock-api/src/Haddock/ModuleTree.hs
@@ -20,39 +20,41 @@ import DynFlags      ( DynFlags )
 import Packages      ( lookupPackage )
 import PackageConfig ( sourcePackageIdString )
 
+import qualified Control.Applicative as A
 
-data ModuleTree = Node String Bool (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree]
+
+data ModuleTree = Node String (Maybe Module) (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree]
 
 
 mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree]
 mkModuleTree dflags showPkgs mods =
-  foldr fn [] [ (splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ]
+  foldr fn [] [ (mdl, splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ]
   where
     modPkg mod_ | showPkgs = Just (unitIdString (moduleUnitId mod_))
                 | otherwise = Nothing
     modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString
                                      (lookupPackage dflags (moduleUnitId mod_))
                    | otherwise = Nothing
-    fn (mod_,pkg,srcPkg,short) = addToTrees mod_ pkg srcPkg short
+    fn (m,mod_,pkg,srcPkg,short) = addToTrees mod_ m pkg srcPkg short
 
 
-addToTrees :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree]
-addToTrees [] _ _ _ ts = ts
-addToTrees ss pkg srcPkg short [] = mkSubTree ss pkg srcPkg short
-addToTrees (s1:ss) pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts)
-  | s1 >  s2  = t : addToTrees (s1:ss) pkg srcPkg short ts
-  | s1 == s2  = Node s2 (leaf || null ss) this_pkg this_srcPkg this_short (addToTrees ss pkg srcPkg short subs) : ts
-  | otherwise = mkSubTree (s1:ss) pkg srcPkg short ++ t : ts
+addToTrees :: [String] -> Module -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree]
+addToTrees [] _ _ _ _ ts = ts
+addToTrees ss m pkg srcPkg short [] = mkSubTree ss m pkg srcPkg short
+addToTrees (s1:ss) m pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts)
+  | s1 >  s2  = t : addToTrees (s1:ss) m pkg srcPkg short ts
+  | s1 == s2  = Node s2 (leaf A.<|> (if null ss then Just m else Nothing)) this_pkg this_srcPkg this_short (addToTrees ss m pkg srcPkg short subs) : ts
+  | otherwise = mkSubTree (s1:ss) m pkg srcPkg short ++ t : ts
  where
   this_pkg = if null ss then pkg else node_pkg
   this_srcPkg = if null ss then srcPkg else node_srcPkg
   this_short = if null ss then short else node_short
 
 
-mkSubTree :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree]
-mkSubTree []     _   _      _     = []
-mkSubTree [s]    pkg srcPkg short = [Node s True pkg srcPkg short []]
-mkSubTree (s:ss) pkg srcPkg short = [Node s (null ss) Nothing Nothing Nothing (mkSubTree ss pkg srcPkg short)]
+mkSubTree :: [String] -> Module -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree]
+mkSubTree []     _ _   _      _     = []
+mkSubTree [s]    m pkg srcPkg short = [Node s (Just m) pkg srcPkg short []]
+mkSubTree (s:s':ss) m pkg srcPkg short = [Node s Nothing Nothing Nothing Nothing (mkSubTree (s':ss) m pkg srcPkg short)]
 
 
 splitModule :: Module -> [String]
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index 59d2c8a7..caf1fefe 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -31,6 +31,7 @@ module Haddock.Options (
   qualification,
   verbosity,
   ghcFlags,
+  reexportFlags,
   readIfaceArgs,
   optPackageName,
   optPackageVersion
@@ -99,6 +100,7 @@ data Flag
   | Flag_NoPrintMissingDocs
   | Flag_PackageName String
   | Flag_PackageVersion String
+  | Flag_Reexport String
   deriving (Eq, Show)
 
 
@@ -197,6 +199,8 @@ options backwardsCompat =
       "generate html with newlines and indenting (for use with --html)",
     Option [] ["no-print-missing-docs"] (NoArg Flag_NoPrintMissingDocs)
       "don't print information about any undocumented entities",
+    Option []  ["reexport"] (ReqArg Flag_Reexport "MOD")
+      "reexport the module MOD, adding it to the index",
     Option [] ["package-name"] (ReqArg Flag_PackageName "NAME")
       "name of the package being documented",
     Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION")
@@ -313,6 +317,9 @@ verbosity flags =
 ghcFlags :: [Flag] -> [String]
 ghcFlags flags = [ option | Flag_OptGhc option <- flags ]
 
+reexportFlags :: [Flag] -> [String]
+reexportFlags flags = [ option | Flag_Reexport option <- flags ]
+
 
 readIfaceArgs :: [Flag] -> [(DocPaths, FilePath)]
 readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ]