Apoorv Ingle pushed to branch wip/ani/hie-spans at Glasgow Haskell Compiler / GHC Commits: b4c72787 by Apoorv Ingle at 2025-12-22T00:43:39-06:00 haddock changes for new variant - - - - - 2 changed files: - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs Changes: ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs ===================================== @@ -155,6 +155,53 @@ parse parserOpts sDocContext fpath bs = case unP (go False []) initState of pure (plainTok : [spaceTok | not (BS.null spaceBStr)], inPrag') + GeneratedSrcSpan rsp -> do + let typ = if inPrag then TkPragma else classify tok + RealSrcLoc lStart _ = srcSpanStart sp -- safe since @sp@ is real + (spaceBStr, bStart) = spanPosition lInit lStart bInit + inPragDef = inPragma inPrag tok + + (bEnd', inPrag') <- case tok of + -- Update internal line + file position if this is a LINE pragma + ITline_prag _ -> tryOrElse (bEnd, inPragDef) $ do + L _ (ITinteger (IL{il_value = line})) <- tryP wrappedLexer + L _ (ITstring _ file) <- tryP wrappedLexer + L spF ITclose_prag <- tryP wrappedLexer + + let newLoc = mkRealSrcLoc file (fromIntegral line - 1) (srcSpanEndCol spF) + (bEnd'', _) <- lift getInput + lift $ setInput (bEnd'', newLoc) + + pure (bEnd'', False) + + -- Update internal column position if this is a COLUMN pragma + ITcolumn_prag _ -> tryOrElse (bEnd, inPragDef) $ do + L _ (ITinteger (IL{il_value = col})) <- tryP wrappedLexer + L spF ITclose_prag <- tryP wrappedLexer + + let newLoc = mkRealSrcLoc (srcSpanFile spF) (srcSpanEndLine spF) (fromIntegral col) + (bEnd'', _) <- lift getInput + lift $ setInput (bEnd'', newLoc) + + pure (bEnd'', False) + _ -> pure (bEnd, inPragDef) + + let tokBStr = splitStringBuffer bStart bEnd' + plainTok = + T.Token + { tkType = typ + , tkValue = tokBStr + , tkSpan = rsp + } + spaceTok = + T.Token + { tkType = TkSpace + , tkValue = spaceBStr + , tkSpan = mkRealSrcSpan lInit lStart + } + + pure (plainTok : [spaceTok | not (BS.null spaceBStr)], inPrag') + -- \| Parse whatever remains of the line as an unknown token (can't fail) unknownLine :: P ([T.Token], Bool) unknownLine = do ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs ===================================== @@ -103,6 +103,8 @@ spliceURL' maybe_mod maybe_name maybe_loc = run case span_ of RealSrcSpan span__ _ -> show $ srcSpanStartLine span__ + GeneratedSrcSpan span__ -> + show $ srcSpanStartLine span__ UnhelpfulSpan _ -> "" run "" = "" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b4c72787d6b48e1e0ea29f95a4653897... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b4c72787d6b48e1e0ea29f95a4653897... You're receiving this email because of your account on gitlab.haskell.org.