diff options
| -rw-r--r-- | haddock-api/src/Haddock.hs | 37 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Options.hs | 24 |
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. |