From 42efa62c8e46da16e589520f4b93266f1ba2a904 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Mon, 25 Mar 2024 16:20:07 -0400
Subject: [PATCH] Make DocPaths a proper data type
(cherry picked from commit 7f3a5c4da0023ae47b4c376c9b1ea2d706c94d8c)
---
utils/haddock/haddock-api/src/Haddock.hs | 6 +++---
utils/haddock/haddock-api/src/Haddock/Options.hs | 13 ++++++++-----
utils/haddock/haddock-api/src/Haddock/Types.hs | 4 +++-
3 files changed, 14 insertions(+), 9 deletions(-)
diff --git a/utils/haddock/haddock-api/src/Haddock.hs b/utils/haddock/haddock-api/src/Haddock.hs
index 21ac3a117187..c9aeb6dbb646 100644
--- a/utils/haddock/haddock-api/src/Haddock.hs
+++ b/utils/haddock/haddock-api/src/Haddock.hs
@@ -208,7 +208,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
-- If any --show-interface was used, show the given interfaces
forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
name_cache <- freshNameCache
- mIfaceFile <- readInterfaceFiles name_cache [(("", Nothing), Visible, path)] noChecks
+ mIfaceFile <- readInterfaceFiles name_cache [(DocPaths "" Nothing, Visible, path)] noChecks
forM_ mIfaceFile $ \(_,_,_, ifaceFile) -> do
putMsg logger $ renderJson (jsonInterfaceFile ifaceFile)
@@ -300,7 +300,7 @@ renderStep :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOpti
renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = do
updateHTMLXRefs (map (\(docPath, _ifaceFilePath, _showModules, ifaceFile) ->
( case baseUrl flags of
- Nothing -> fst docPath
+ Nothing -> docPathsHtml docPath
Just url -> url </> packageName (ifUnitId ifaceFile)
, ifaceFile)) pkgs)
let
@@ -310,7 +310,7 @@ renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = d
-> (ifaceFilePath, mkPackageInterfaces showModules ifaceFile))
pkgs
extSrcMap = Map.fromList $ do
- ((_, Just path), _, _, ifile) <- pkgs
+ (DocPaths {docPathsSources=Just path}, _, _, ifile) <- pkgs
iface <- ifInstalledIfaces ifile
return (instMod iface, path)
render logger dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap
diff --git a/utils/haddock/haddock-api/src/Haddock/Options.hs b/utils/haddock/haddock-api/src/Haddock/Options.hs
index f9562516e775..e868c9783225 100644
--- a/utils/haddock/haddock-api/src/Haddock/Options.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Options.hs
@@ -564,16 +564,19 @@ readIfaceArgs flags = [parseIfaceOption s | Flag_ReadInterface s <- flags]
let src' = case src of
"" -> Nothing
_ -> Just (src ++ "/%M.html")
+ docPaths = DocPaths { docPathsHtml = fpath
+ , docPathsSources = src'
+ }
in case break (== ',') rest' of
(visibility, ',' : file)
| visibility == "hidden" ->
- ((fpath, src'), Hidden, file)
+ (docPaths, Hidden, file)
| otherwise ->
- ((fpath, src'), Visible, file)
+ (docPaths, Visible, file)
(file, _) ->
- ((fpath, src'), Visible, file)
- (file, _) -> ((fpath, Nothing), Visible, file)
- (file, _) -> (("", Nothing), Visible, file)
+ (docPaths, Visible, file)
+ (file, _) -> (DocPaths fpath Nothing, Visible, file)
+ (file, _) -> (DocPaths "" Nothing, Visible, file)
-- | Like 'listToMaybe' but returns the last element instead of the first.
optLast :: [a] -> Maybe a
diff --git a/utils/haddock/haddock-api/src/Haddock/Types.hs b/utils/haddock/haddock-api/src/Haddock/Types.hs
index 91795b908b4c..3ccd49cba0fd 100644
--- a/utils/haddock/haddock-api/src/Haddock/Types.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Types.hs
@@ -79,7 +79,9 @@ type SubMap = Map Name [Name]
type DeclMap = Map Name DeclMapEntry
type InstMap = Map RealSrcSpan Name
type FixMap = Map Name Fixity
-type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources
+data DocPaths = DocPaths { docPathsHtml :: FilePath -- ^ path to HTML Haddocks
+ , docPathsSources :: Maybe FilePath -- ^ path to hyperlinked sources
+ }
type WarningMap = Map Name (Doc Name)
-----------------------------------------------------------------------------
--
GitLab