diff options
Diffstat (limited to 'haddock-api/src/Haddock.hs')
| -rw-r--r-- | haddock-api/src/Haddock.hs | 81 |
1 files changed, 58 insertions, 23 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 8182707d..5b77a00f 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -1,6 +1,10 @@ -{-# OPTIONS_GHC -Wwarn #-} -{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings, Rank2Types #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock @@ -46,7 +50,7 @@ import Control.Monad.IO.Class (MonadIO(..)) import Data.Bifunctor (second) import Data.Foldable (forM_, foldl') import Data.Traversable (for) -import Data.List (isPrefixOf) +import Data.List (find, isPrefixOf, nub) import Control.Exception import Data.Maybe import Data.IORef @@ -72,6 +76,7 @@ import GHC.Driver.Session hiding (projectVersion, verbosity) import GHC.Driver.Env import GHC.Utils.Error import GHC.Unit +import GHC.Unit.State (lookupUnit) import GHC.Utils.Panic (handleGhcException) import GHC.Data.FastString @@ -189,7 +194,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks - forM_ mIfaceFile $ \(_, ifaceFile) -> do + forM_ mIfaceFile $ \(_,_, ifaceFile) -> do putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile) if not (null files) then do @@ -249,35 +254,49 @@ withGhc flags action = do readPackagesAndProcessModules :: [Flag] -> [String] - -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) + -> Ghc ([(DocPaths, 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 snd 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, InterfaceFile)] -> [Interface] -> IO () + -> [(DocPaths, FilePath, InterfaceFile)] -> [Interface] -> IO () renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = do - updateHTMLXRefs pkgs + updateHTMLXRefs (map (\(docPath, _ifaceFilePath, ifaceFile) -> + ( case baseUrl flags of + Nothing -> fst docPath + Just url -> url </> packageName (ifUnitId ifaceFile) + , ifaceFile)) pkgs) let - ifaceFiles = map snd pkgs - installedIfaces = concatMap ifInstalledIfaces ifaceFiles + installedIfaces = + concatMap + (\(_, ifaceFilePath, ifaceFile) + -> (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 + where + -- get package name from unit-id + packageName :: Unit -> String + packageName unit = + case lookupUnit unit_state unit of + Nothing -> show unit + Just pkg -> unitPackageNameString pkg -- | Render the interfaces with whatever backend is specified in the flags. render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface] - -> [InstalledInterface] -> Map Module FilePath -> IO () + -> [(FilePath, InstalledInterface)] -> Map Module FilePath -> IO () render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do let @@ -285,6 +304,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS unicode = Flag_UseUnicode `elem` flags pretty = Flag_PrettyHtml `elem` flags opt_wiki_urls = wikiUrls flags + opt_base_url = baseUrl flags opt_contents_url = optContentsUrl flags opt_index_url = optIndexUrl flags odir = outputDir flags @@ -298,7 +318,7 @@ 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 ++ installedIfaces + allIfaces = map toInstalledIface ifaces ++ map snd installedIfaces allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] pkgMod = fmap ifaceMod (listToMaybe ifaces) @@ -343,7 +363,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 @@ -366,6 +386,13 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS themes <- getThemes libDir flags >>= either bye return let withQuickjump = Flag_QuickJumpIndex `elem` flags + withBaseURL = isJust + . find (\flag -> case flag of + Flag_BaseURL base_url -> + base_url /= "." && base_url /= "./" + _ -> False + ) + $ flags when (Flag_GenIndex `elem` flags) $ do withTiming logger dflags' "ppHtmlIndex" (const ()) $ do @@ -375,7 +402,8 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS allVisibleIfaces pretty return () - copyHtmlBits odir libDir themes withQuickjump + unless withBaseURL $ + copyHtmlBits odir libDir themes withQuickjump when (Flag_GenContents `elem` flags) $ do withTiming logger dflags' "ppHtmlContents" (const ()) $ do @@ -387,17 +415,24 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS return () copyHtmlBits odir libDir themes withQuickjump + when withQuickjump $ void $ + ppJsonIndex odir sourceUrls' opt_wiki_urls + unicode Nothing qual + ifaces + (nub $ map fst installedIfaces) + when (Flag_Html `elem` flags) $ do withTiming logger dflags' "ppHtml" (const ()) $ do _ <- {-# SCC ppHtml #-} ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir prologue - themes opt_mathjax sourceUrls' opt_wiki_urls + themes opt_mathjax sourceUrls' opt_wiki_urls opt_base_url opt_contents_url opt_index_url unicode sincePkg qual pretty withQuickjump return () - copyHtmlBits odir libDir themes withQuickjump - writeHaddockMeta odir withQuickjump + unless withBaseURL $ do + copyHtmlBits odir libDir themes withQuickjump + writeHaddockMeta odir withQuickjump -- TODO: we throw away Meta for both Hoogle and LaTeX right now, -- might want to fix that if/when these two get some work on them @@ -445,7 +480,7 @@ readInterfaceFiles :: MonadIO m => NameCacheAccessor m -> [(DocPaths, FilePath)] -> Bool - -> m [(DocPaths, InterfaceFile)] + -> m [(DocPaths, FilePath, InterfaceFile)] readInterfaceFiles name_cache_accessor pairs bypass_version_check = do catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs where @@ -457,7 +492,7 @@ readInterfaceFiles name_cache_accessor pairs bypass_version_check = do putStrLn (" " ++ err) putStrLn "Skipping this interface." return Nothing - Right f -> return $ Just (paths, f) + Right f -> return (Just (paths, file, f)) ------------------------------------------------------------------------------- @@ -678,12 +713,12 @@ hypSrcWarnings flags = do isSourceCssFlag _ = False -updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO () +updateHTMLXRefs :: [(FilePath, InterfaceFile)] -> IO () updateHTMLXRefs packages = do writeIORef html_xrefs_ref (Map.fromList mapping) writeIORef html_xrefs_ref' (Map.fromList mapping') where - mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages + mapping = [ (instMod iface, html) | (html, ifaces) <- packages , iface <- ifInstalledIfaces ifaces ] mapping' = [ (moduleName m, html) | (m, html) <- mapping ] |