[Git][ghc/ghc][master] 2 commits: haddock: Fix hyperlinker source urls (#24907)

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
97b141a3 by Zubin Duggal at 2024-06-12T12:52:55-04:00
haddock: Fix hyperlinker source urls (#24907)

This fixes a bug introduced by f56838c36235febb224107fa62334ebfe9941aba Links to
external modules in the hyperlinker are uniformly generated using splicing the
template given to us instead of attempting to construct the url in an ad-hoc manner.

- - - - -
954f864c by Zubin Duggal at 2024-06-12T12:52:55-04:00
haddock: Add name anchor to external source urls from documentation page

URLs for external source links from documentation pages were missing a splice
location for the name.

Fixes #24912

- - - - -


4 changed files:

- utils/haddock/haddock-api/src/Haddock.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Options.hs


Changes:

=====================================
utils/haddock/haddock-api/src/Haddock.hs
=====================================
@@ -394,11 +394,14 @@ render log' dflags unit_state flags sinceQual qual ifaces packages extSrcMap = d
       | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat
       | otherwise = srcModule
 
+    -- These urls have a template for the module %M
     srcMap = Map.union
-      (Map.map SrcExternal extSrcMap)
+      (Map.map (SrcExternal . hypSrcPkgUrlToModuleFormat) extSrcMap)
       (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ])
 
-    pkgSrcMap = Map.mapKeys moduleUnit extSrcMap
+    -- These urls have a template for the module %M and the name %N
+    pkgSrcMap = Map.map (hypSrcModuleUrlToNameFormat . hypSrcPkgUrlToModuleFormat)
+              $ Map.mapKeys moduleUnit extSrcMap
     pkgSrcMap'
       | Flag_HyperlinkedSource `elem` flags
       , Just k <- pkgKey
@@ -408,6 +411,7 @@ render log' dflags unit_state flags sinceQual qual ifaces packages extSrcMap = d
       = Map.insert k srcNameUrl pkgSrcMap
       | otherwise = pkgSrcMap
 
+    -- These urls have a template for the module %M and the line %L
     -- TODO: Get these from the interface files as with srcMap
     pkgSrcLMap'
       | Flag_HyperlinkedSource `elem` flags


=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
=====================================
@@ -275,7 +275,7 @@ hyperlink (srcs, srcs') ident = case ident of
         Html.anchor content
           ! [Html.href $ hypSrcModuleNameUrl mdl name]
       Just (SrcExternal path) ->
-        let hyperlinkUrl = makeHyperlinkUrl path </> hypSrcModuleNameUrl mdl name
+        let hyperlinkUrl = hypSrcModuleUrlToNameFormat $ makeHyperlinkUrl path
          in Html.anchor content
               ! [Html.href $ spliceURL (Just mdl) (Just name) Nothing hyperlinkUrl]
       Nothing -> content
@@ -288,7 +288,7 @@ hyperlink (srcs, srcs') ident = case ident of
           Html.anchor content
             ! [Html.href $ hypSrcModuleUrl' moduleName]
         Just (SrcExternal path) ->
-          let hyperlinkUrl = makeHyperlinkUrl path </> hypSrcModuleUrl' moduleName
+          let hyperlinkUrl = makeHyperlinkUrl path
            in Html.anchor content
                 ! [Html.href $ spliceURL' (Just moduleName) Nothing Nothing hyperlinkUrl]
         Nothing -> content


=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
=====================================
@@ -13,6 +13,8 @@ module Haddock.Backends.Hyperlinker.Utils
   , hypSrcModuleUrlFormat
   , hypSrcModuleNameUrlFormat
   , hypSrcModuleLineUrlFormat
+  , hypSrcModuleUrlToNameFormat
+  , hypSrcPkgUrlToModuleFormat
   , spliceURL
   , spliceURL'
 
@@ -82,6 +84,12 @@ hypSrcModuleNameUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ nameFormat
 hypSrcModuleLineUrlFormat :: String
 hypSrcModuleLineUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ lineFormat
 
+hypSrcModuleUrlToNameFormat :: String -> String
+hypSrcModuleUrlToNameFormat url = url ++ "#" ++ nameFormat
+
+hypSrcPkgUrlToModuleFormat :: String -> String
+hypSrcPkgUrlToModuleFormat url = url </> moduleFormat
+
 moduleFormat :: String
 moduleFormat = "%{MODULE}.html"
 


=====================================
utils/haddock/haddock-api/src/Haddock/Options.hs
=====================================
@@ -563,7 +563,7 @@ readIfaceArgs flags = [parseIfaceOption s | Flag_ReadInterface s <- flags]
             (src, ',' : rest') ->
               let src' = case src of
                     "" -> Nothing
-                    _  -> Just (src ++ "/%M.html")
+                    _  -> Just src
                   docPaths = DocPaths { docPathsHtml = fpath
                                       , docPathsSources = src'
                                       }



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1b1523b1701bd14005048d190d92e808c7d3f7e4...954f864c33852f6511f295d941c45c3c6193dad1

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1b1523b1701bd14005048d190d92e808c7d3f7e4...954f864c33852f6511f295d941c45c3c6193dad1
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240612/b2bf3abc/attachment-0001.html>