aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
authorMarcin Szamotulski <coot@coot.me>2022-05-21 23:32:31 +0200
committerGitHub <noreply@github.com>2022-05-21 23:32:31 +0200
commitc0f06d55bd64d2777588860917be3dcdaede3479 (patch)
treeb9868542f50ced56ec522bec3921f9dc497da948 /haddock-api
parent2c27d150f777f08165d3c8c60c8aa2a0fa164fdd (diff)
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.
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/src/Haddock.hs37
-rw-r--r--haddock-api/src/Haddock/Options.hs24
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.