[Git][ghc/ghc][wip/shorter-this-module-links] Use showUnique in internalAnchorIdent

14 Sep 2025


      Oleg Grenrus pushed to branch wip/shorter-this-module-links at Glasgow Haskell Compiler / GHC


Commits:
6d4eb0db by Oleg Grenrus at 2025-09-14T19:04:32+03:00
Use showUnique in internalAnchorIdent

Showing the key of Unique as a number is generally not a great idea.
GHC Unique has a tag in high bits, so the raw number is unnecessarily
big.

So now we have

```html
<a href="#l-rvgK"><span class="hs-identifier hs-var hs-var">bar</span></a>
```

instead of

```html
<a href="#local-6989586621679015689"><span class="hs-identifier hs-var hs-var">bar</span></a>
```

Together with previous changes of shorter intra-module links the effect
on compressed files is not huge, that is expected as we simply remove
repetitive contents which pack well.

```
12_694_206  Agda-2.9.0-docs-orig.tar.gz
12_566_065  Agda-2.9.0-docs.tar.gz
```

However when unpacked, the difference can be significant,
e.g. Agda's largest module source got 5% reduction:

```
14_230_117  Agda.Syntax.Parser.Parser.html
13_422_109  Agda.Syntax.Parser.Parser.html
```

The whole hyperlinked source code directory got similar reduction

```
121M	Agda-2.9.0-docs-orig/src
114M	Agda-2.9.0-docs/src
```

For the reference, sources are about 2/3 of the generated haddocks

```
178M	Agda-2.9.0-docs-old
172M	Agda-2.9.0-docs
```

so we get around 3.5% size reduction overall. Not bad for a small local
changes.

- - - - -


3 changed files:

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


Changes:

=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs
=====================================
@@ -80,7 +80,6 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do
   nc <- freshNameCache
   HieFile
     { hie_hs_file = file
-    , hie_module = thisModule
     , hie_asts = HieASTs asts
     , hie_types = types
     , hie_hs_src = rawSrc
@@ -117,7 +116,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do
   let tokens = fmap (\tk -> tk{tkSpan = (tkSpan tk){srcSpanFile = srcSpanFile $ nodeSpan fullAst}}) tokens'
 
   -- Produce and write out the hyperlinked sources
-  writeUtf8File path . renderToString pretty . render' thisModule fullAst $ tokens
+  writeUtf8File path . renderToString pretty . render' fullAst $ tokens
   where
     dflags = ifaceDynFlags iface
     sDocContext = DynFlags.initSDocContext dflags Outputable.defaultUserStyle
@@ -129,7 +128,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do
         False -- lex Haddocks as comment tokens
         True -- produce comment tokens
         False -- produce position pragmas tokens
-    render' thisModule = render thisModule (Just srcCssFile) (Just highlightScript) srcs
+    render' = render (Just srcCssFile) (Just highlightScript) srcs
     path = srcdir  hypSrcModuleFile (ifaceMod iface)
 
     emptyHieAst fileFs =


=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
=====================================
@@ -15,7 +15,7 @@ import GHC.Iface.Ext.Utils (emptyNodeInfo, isEvidenceContext)
 import GHC.Types.Name (Name, getOccString, isInternalName, nameModule, nameUnique)
 import GHC.Types.SrcLoc
 import GHC.Types.Unique (getKey)
-import GHC.Unit.Module (Module, ModuleName, moduleNameString)
+import GHC.Unit.Module (ModuleName, moduleNameString)
 import GHC.Utils.Encoding (utf8DecodeByteString)
 import System.FilePath.Posix (())
 import Text.XHtml (Html, HtmlAttr, (!))
@@ -28,9 +28,7 @@ type StyleClass = String
 
 -- | Produce the HTML corresponding to a hyperlinked Haskell source
 render
-  :: Module
-  -- ^ this module
-  -> Maybe FilePath
+  :: Maybe FilePath
   -- ^ path to the CSS file
   -> Maybe FilePath
   -- ^ path to the JS file
@@ -41,12 +39,12 @@ render
   -> [Token]
   -- ^ tokens to render
   -> Html
-render thisModule mcss mjs srcs ast tokens = header mcss mjs <> body thisModule srcs ast tokens
+render mcss mjs srcs ast tokens = header mcss mjs <> body srcs ast tokens
 
-body :: Module -> SrcMaps -> HieAST PrintedType -> [Token] -> Html
-body thisModule srcs ast tokens = Html.body . Html.pre $ hypsrc
+body :: SrcMaps -> HieAST PrintedType -> [Token] -> Html
+body srcs ast tokens = Html.body . Html.pre $ hypsrc
   where
-    hypsrc = renderWithAst thisModule srcs ast tokens
+    hypsrc = renderWithAst srcs ast tokens
 
 header :: Maybe FilePath -> Maybe FilePath -> Html
 header Nothing Nothing = Html.noHtml
@@ -77,9 +75,9 @@ splitTokens ast toks = (before, during, after)
 
 -- | Turn a list of tokens into hyperlinked sources, threading in relevant link
 -- information from the 'HieAST'.
-renderWithAst :: Module -> SrcMaps -> HieAST PrintedType -> [Token] -> Html
-renderWithAst thisModule srcs Node{..} toks = anchored $ case toks of
-  [tok] | nodeSpan == tkSpan tok -> richToken thisModule srcs nodeInfo tok
+renderWithAst :: SrcMaps -> HieAST PrintedType -> [Token] -> Html
+renderWithAst srcs Node{..} toks = anchored $ case toks of
+  [tok] | nodeSpan == tkSpan tok -> richToken srcs nodeInfo tok
   -- NB: the GHC lexer lexes backquoted identifiers and parenthesized operators
   -- as multiple tokens.
   --
@@ -94,7 +92,6 @@ renderWithAst thisModule srcs Node{..} toks = anchored $ case toks of
     | realSrcSpanStart s1 == realSrcSpanStart nodeSpan
     , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan ->
         richToken
-          thisModule
           srcs
           nodeInfo
           ( Token
@@ -107,7 +104,6 @@ renderWithAst thisModule srcs Node{..} toks = anchored $ case toks of
     | realSrcSpanStart s1 == realSrcSpanStart nodeSpan
     , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan ->
         richToken
-          thisModule
           srcs
           nodeInfo
           ( Token
@@ -122,7 +118,7 @@ renderWithAst thisModule srcs Node{..} toks = anchored $ case toks of
     go _ [] = mempty
     go [] xs = foldMap renderToken xs
     go (cur : rest) xs =
-      foldMap renderToken before <> renderWithAst thisModule srcs cur during <> go rest after
+      foldMap renderToken before <> renderWithAst srcs cur during <> go rest after
       where
         (before, during, after) = splitTokens cur xs
     anchored c = Map.foldrWithKey anchorOne c (nodeIdentifiers nodeInfo)
@@ -141,8 +137,8 @@ renderToken Token{..}
     tokenSpan = Html.thespan (Html.toHtml tkValue')
 
 -- | Given information about the source position of definitions, render a token
-richToken :: Module -> SrcMaps -> NodeInfo PrintedType -> Token -> Html
-richToken thisModule srcs details Token{..}
+richToken :: SrcMaps -> NodeInfo PrintedType -> Token -> Html
+richToken srcs details Token{..}
   | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue'
   | otherwise = annotate details $ linked content
   where
@@ -159,7 +155,7 @@ richToken thisModule srcs details Token{..}
 
     -- If we have name information, we can make links
     linked = case identDet of
-      Just (n, _) -> hyperlink thisModule srcs n
+      Just (n, _) -> hyperlink srcs n
       Nothing -> id
 
 -- | Remove CRLFs from source
@@ -257,8 +253,8 @@ internalAnchorIdent :: Name -> String
 internalAnchorIdent = ("local-" ++) . show . getKey . nameUnique
 
 -- | Generate the HTML hyperlink for an identifier
-hyperlink :: Module -> SrcMaps -> Identifier -> Html -> Html
-hyperlink thisModule (srcs, srcs') ident = case ident of
+hyperlink :: SrcMaps -> Identifier -> Html -> Html
+hyperlink (srcs, srcs') ident = case ident of
   Right name
     | isInternalName name -> internalHyperlink name
     | otherwise -> externalNameHyperlink name
@@ -274,7 +270,7 @@ hyperlink thisModule (srcs, srcs') ident = case ident of
     externalNameHyperlink name content = case Map.lookup mdl srcs of
       Just SrcLocal ->
         Html.anchor content
-          ! [Html.href $ hypSrcModuleNameUrl' thisModule mdl name]
+          ! [Html.href $ hypSrcModuleNameUrl mdl name]
       Just (SrcExternal path) ->
         let hyperlinkUrl = hypSrcModuleUrlToNameFormat $ makeHyperlinkUrl path
          in Html.anchor content


=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
=====================================
@@ -9,7 +9,6 @@ module Haddock.Backends.Hyperlinker.Utils
   , hypSrcNameUrl
   , hypSrcLineUrl
   , hypSrcModuleNameUrl
-  , hypSrcModuleNameUrl'
   , hypSrcModuleLineUrl
   , hypSrcModuleUrlFormat
   , hypSrcModuleNameUrlFormat
@@ -72,12 +71,6 @@ hypSrcLineUrl line = "line-" ++ show line
 hypSrcModuleNameUrl :: Module -> Name -> String
 hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name
 
-{-# INLINE hypSrcModuleNameUrl' #-}
-hypSrcModuleNameUrl' :: Module -> Module -> Name -> String
-hypSrcModuleNameUrl' this_mdl mdl name
-  | this_mdl == mdl = "#" ++ hypSrcNameUrl name
-  | otherwise = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name
-
 {-# INLINE hypSrcModuleLineUrl #-}
 hypSrcModuleLineUrl :: Module -> Int -> String
 hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6d4eb0db7ecfc45da62c8e3d1b579630...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6d4eb0db7ecfc45da62c8e3d1b579630...
You're receiving this email because of your account on gitlab.haskell.org.

    

Oleg Grenrus (＠phadej)

tags

participants (1)