diff options
Diffstat (limited to 'haddock-api/src/Haddock.hs')
| -rw-r--r-- | haddock-api/src/Haddock.hs | 37 |
1 files changed, 19 insertions, 18 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)) ------------------------------------------------------------------------------- |