Allow to hide interfaces when rendering multiple components (#1487)

This is useful when one wishes to `--gen-contents` when rendering
multiple components, but one does not want to render all modules.  This
is in particular useful when adding base package.

2 files changed, 38 insertions, 23 deletions

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 5b77a00f..927c09a3 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -193,8 +193,8 @@ haddockWithGhc ghc args = handleTopExceptions $ do
     unit_state <- hsc_units <$> getSession
 
     forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
-      mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks
-      forM_ mIfaceFile $ \(_,_, ifaceFile) -> do
+      mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), Visible, path)] noChecks
+      forM_ mIfaceFile $ \(_,_,_, ifaceFile) -> do
         putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile)
 
     if not (null files) then do
@@ -254,23 +254,23 @@ withGhc flags action = do
 
 
 readPackagesAndProcessModules :: [Flag] -> [String]
-                              -> Ghc ([(DocPaths, FilePath, InterfaceFile)], [Interface], LinkEnv)
+                              -> Ghc ([(DocPaths, Visibility, FilePath, InterfaceFile)], [Interface], LinkEnv)
 readPackagesAndProcessModules flags files = do
     -- Get packages supplied with --read-interface.
     let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
     packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks
 
     -- Create the interfaces -- this is the core part of Haddock.
-    let ifaceFiles = map (\(_, _, ifaceFile) -> ifaceFile) packages
+    let ifaceFiles = map (\(_, _, _, ifaceFile) -> ifaceFile) packages
     (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles
 
     return (packages, ifaces, homeLinks)
 
 
 renderStep :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption
-           -> [(DocPaths, FilePath, InterfaceFile)] -> [Interface] -> IO ()
+           -> [(DocPaths, Visibility, FilePath, InterfaceFile)] -> [Interface] -> IO ()
 renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = do
-  updateHTMLXRefs (map (\(docPath, _ifaceFilePath, ifaceFile) ->
+  updateHTMLXRefs (map (\(docPath, _ifaceFilePath, _showModules, ifaceFile) ->
                           ( case baseUrl flags of
                               Nothing  -> fst docPath
                               Just url -> url </> packageName (ifUnitId ifaceFile)
@@ -278,11 +278,11 @@ renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = d
   let
     installedIfaces =
       concatMap
-        (\(_, ifaceFilePath, ifaceFile)
-          -> (ifaceFilePath,) <$> ifInstalledIfaces ifaceFile)
+        (\(_, showModules, ifaceFilePath, ifaceFile)
+          -> (showModules,ifaceFilePath,) <$> ifInstalledIfaces ifaceFile)
         pkgs
     extSrcMap = Map.fromList $ do
-      ((_, Just path), _, ifile) <- pkgs
+      ((_, Just path), _, _, ifile) <- pkgs
       iface <- ifInstalledIfaces ifile
       return (instMod iface, path)
   render logger dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap
@@ -296,7 +296,7 @@ renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = d
 
 -- | Render the interfaces with whatever backend is specified in the flags.
 render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface]
-       -> [(FilePath, InstalledInterface)] -> Map Module FilePath -> IO ()
+       -> [(Visibility, FilePath, InstalledInterface)] -> Map Module FilePath -> IO ()
 render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do
 
   let
@@ -318,8 +318,9 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
     visibleIfaces    = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
 
     -- /All/ visible interfaces including external package modules.
-    allIfaces        = map toInstalledIface ifaces ++ map snd installedIfaces
-    allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ]
+    allIfaces        = map ((Visible,) . toInstalledIface) ifaces
+                    ++ map (\(showModules,_,iface) -> (showModules,iface)) installedIfaces
+    allVisibleIfaces = [ i | (Visible, i) <- allIfaces, OptHide `notElem` instOptions i ]
 
     pkgMod           = fmap ifaceMod (listToMaybe ifaces)
     pkgKey           = fmap moduleUnit pkgMod
@@ -363,7 +364,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
     sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap')
 
     installedMap :: Map Module InstalledInterface
-    installedMap = Map.fromList [ (unwire (instMod iface), iface) | (_, iface) <- installedIfaces ]
+    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
@@ -419,7 +420,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
             ppJsonIndex odir sourceUrls' opt_wiki_urls
                         unicode Nothing qual
                         ifaces
-                        (nub $ map fst installedIfaces)
+                        (nub $ map (\(_,a,_) -> a) installedIfaces)
 
   when (Flag_Html `elem` flags) $ do
     withTiming logger dflags' "ppHtml" (const ()) $ do
@@ -478,21 +479,21 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
 
 readInterfaceFiles :: MonadIO m
                    => NameCacheAccessor m
-                   -> [(DocPaths, FilePath)]
+                   -> [(DocPaths, Visibility, FilePath)]
                    -> Bool
-                   -> m [(DocPaths, FilePath, InterfaceFile)]
+                   -> m [(DocPaths, Visibility, FilePath, InterfaceFile)]
 readInterfaceFiles name_cache_accessor pairs bypass_version_check = do
   catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs
   where
     -- try to read an interface, warn if we can't
-    tryReadIface (paths, file) =
+    tryReadIface (paths, showModules, file) =
       readInterfaceFile name_cache_accessor file bypass_version_check >>= \case
         Left err -> liftIO $ do
           putStrLn ("Warning: Cannot read " ++ file ++ ":")
           putStrLn ("   " ++ err)
           putStrLn "Skipping this interface."
           return Nothing
-        Right f -> return (Just (paths, file, f))
+        Right f -> return (Just (paths, showModules, file, f))
 
 
 -------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index aa10b5b3..78bfe1a1 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -15,6 +15,7 @@
 module Haddock.Options (
   parseHaddockOpts,
   Flag(..),
+  Visibility(..),
   getUsage,
   optTitle,
   outputDir,
@@ -361,18 +362,31 @@ ghcFlags flags = [ option | Flag_OptGhc option <- flags ]
 reexportFlags :: [Flag] -> [String]
 reexportFlags flags = [ option | Flag_Reexport option <- flags ]
 
+data Visibility = Visible | Hidden
+  deriving (Eq, Show)
 
-readIfaceArgs :: [Flag] -> [(DocPaths, FilePath)]
+readIfaceArgs :: [Flag] -> [(DocPaths, Visibility, FilePath)]
 readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ]
   where
-    parseIfaceOption :: String -> (DocPaths, FilePath)
+    parseIfaceOption :: String -> (DocPaths, Visibility, FilePath)
     parseIfaceOption str =
       case break (==',') str of
         (fpath, ',':rest) ->
           case break (==',') rest of
-            (src, ',':file) -> ((fpath, Just src), file)
-            (file, _) -> ((fpath, Nothing), file)
-        (file, _) -> (("", Nothing), file)
+            (src, ',':rest') ->
+              let src' = case src of
+                    "" -> Nothing
+                    _  -> Just src
+              in
+              case break (==',') rest' of
+                (visibility, ',':file) | visibility == "hidden" ->
+                  ((fpath, src'), Hidden, file)
+                                       | otherwise ->
+                  ((fpath, src'), Visible, file)
+                (file, _) ->
+                  ((fpath, src'), Visible, file)
+            (file, _) -> ((fpath, Nothing), Visible, file)
+        (file, _) -> (("", Nothing), Visible, file)
 
 
 -- | Like 'listToMaybe' but returns the last element instead of the first.